diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,6 +1,6 @@ G2 -Copyright 2019. William Hallahan, Anton Xue. +Copyright 2022. William Hallahan, Anton Xue, John Kolesar. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -7,21 +7,15 @@ --- #### Dependencies -* GHC 8.2.2: https://www.haskell.org/ghc/ -* Custom Haskell Standard Library: https://github.com/AntonXue/base-4.9.1.0 +* GHC: https://www.haskell.org/ghc/ +* Custom Haskell Standard Library: https://github.com/BillHallahan/base-4.9.1.0 * Z3 SMT Solver: https://github.com/Z3Prover/z3 --- #### Setup: -1) Install GHC 8.2.2 (other GHC 8 versions might also work) -2) Install Z3 -3) Either: - - a) Pull the Custom Haskell Standard Library into ~/.g2 by running `bash base_setup.sh` - - b) Manually pull the base library. Add a file to the G2 folder, called g2.cfg that contains: - `base = /path/to/custom/library` - +1) Install GHC. +2) Install Z3. Ensure Z3 is in your system's path. +3) Pull the Custom Haskell Standard Library into ~/.g2 by running `bash base_setup.sh`. --- #### Command line: @@ -32,7 +26,7 @@ ###### LiquidHaskell: -`cabal run G2 -- --liquid ./tests/Liquid/Peano.hs --liquid-func add` +`cabal run G2LH ./tests/Liquid/Peano.hs add` ###### Arguments: @@ -40,12 +34,3 @@ * `--max-outputs` number of inputs/results to display * `--smt` Pass "z3" or "cvc4" to select a solver [Default: Z3] * `--time` Set a timeout in seconds - ---- - -#### Authors -* Bill Hallahan (Yale) -* Anton Xue (Yale) -* Maxwell Troy Bland (UCSD) -* Ranjit Jhala (UCSD) -* Ruzica Piskac (Yale) diff --git a/exe/Main.hs b/exe/Main.hs --- a/exe/Main.hs +++ b/exe/Main.hs @@ -2,14 +2,18 @@ module Main (main) where -import DynFlags +import G2.Translation.GHC (GeneralFlag(Opt_Hpc)) import System.Environment import System.FilePath +import Data.Foldable (toList) import qualified Data.Map as M import Data.Maybe +import Data.Monoid ((<>)) +import qualified Data.Sequence as S import qualified Data.Text as T +import qualified Data.Text.IO as T import G2.Lib.Printers @@ -18,60 +22,30 @@ import G2.Language import G2.Translation -import G2.Liquid.Interface - main :: IO () main = do as <- getArgs - - let m_liquid_file = mkLiquid as - let m_liquid_func = mkLiquidFunc as - - let libs = maybeToList $ mkMapSrc as - let lhlibs = maybeToList $ mkLiquidLibs as - - case (m_liquid_file, m_liquid_func) of - (Just lhfile, Just lhfun) -> do - let m_idir = mIDir as - proj = maybe (takeDirectory lhfile) id m_idir - runSingleLHFun proj lhfile lhfun libs lhlibs as - _ -> do - runWithArgs as - -runSingleLHFun :: FilePath -> FilePath -> String -> [FilePath] -> [FilePath] -> [String] -> IO () -runSingleLHFun proj lhfile lhfun libs lhlibs ars = do - config <- getConfig ars - _ <- doTimeout (timeLimit config) $ do - ((in_out, _), entry) <- findCounterExamples [proj] [lhfile] (T.pack lhfun) libs lhlibs config - printLHOut entry in_out - return () + runWithArgs as runWithArgs :: [String] -> IO () runWithArgs as = do - - let (src:entry:tail_args) = as + let (_:_:tail_args) = as + (src, entry, m_assume, m_assert, config) <- getConfig proj <- guessProj src --Get args - let m_assume = mAssume tail_args - let m_assert = mAssert tail_args let m_reaches = mReaches tail_args let m_retsTrue = mReturnsTrue tail_args - let m_mapsrc = mkMapSrc tail_args - let tentry = T.pack entry - let libs = maybeToList m_mapsrc - - config <- getConfig as _ <- doTimeout (timeLimit config) $ do ((in_out, b), entry_f@(Id (Name _ mb_modname _ _) _)) <- - runG2FromFile [proj] [src] libs (fmap T.pack m_assume) + runG2FromFile [proj] [src] (fmap T.pack m_assume) (fmap T.pack m_assert) (fmap T.pack m_reaches) (isJust m_assert || isJust m_reaches || m_retsTrue) - tentry config + tentry simplTranslationConfig config case validate config of True -> do @@ -88,17 +62,16 @@ printFuncCalls :: Config -> Id -> Bindings -> [ExecRes t] -> IO () printFuncCalls config entry b = mapM_ (\execr@(ExecRes { final_state = s}) -> do - let funcCall = mkCleanExprHaskell s + let pg = mkPrettyGuide (exprNames $ conc_args execr) + let funcCall = printHaskellPG pg s . foldl (\a a' -> App a a') (Var entry) $ (conc_args execr) - let funcOut = mkCleanExprHaskell s $ (conc_out execr) - - ppStatePiece (printExprEnv config) "expr_env" $ ppExprEnv s - ppStatePiece (printRelExprEnv config) "rel expr_env" $ ppRelExprEnv s b - ppStatePiece (printCurrExpr config) "curr_expr" $ ppCurrExpr s - ppStatePiece (printPathCons config) "path_cons" $ ppPathConds s + let funcOut = printHaskellPG pg s $ (conc_out execr) + sym_gen_out = fmap (printHaskellPG pg s) $ conc_sym_gens execr - putStrLn $ funcCall ++ " = " ++ funcOut) + case sym_gen_out of + S.Empty -> T.putStrLn $ funcCall <> " = " <> funcOut + _ -> T.putStrLn $ funcCall <> " = " <> funcOut <> "\t| generated: " <> T.intercalate ", " (toList sym_gen_out)) ppStatePiece :: Bool -> String -> String -> IO () ppStatePiece b n res = @@ -129,9 +102,3 @@ mkLiquidFunc :: [String] -> Maybe String mkLiquidFunc a = strArg "liquid-func" a M.empty Just Nothing - -mkMapSrc :: [String] -> Maybe String -mkMapSrc a = strArg "mapsrc" a M.empty Just Nothing - -mkLiquidLibs :: [String] -> Maybe String -mkLiquidLibs a = strArg "liquid-libs" a M.empty Just Nothing diff --git a/g2.cabal b/g2.cabal --- a/g2.cabal +++ b/g2.cabal @@ -2,7 +2,7 @@ -- see http://haskell.org/cabal/users-guide/ name: g2 -version: 0.1.0.1 +version: 0.2.0.0 synopsis: Haskell symbolic execution engine. description: A Haskell symbolic execution engine. @@ -10,13 +10,17 @@ License: BSD3 License-file: LICENSE author: William Hallahan, Anton Xue -maintainer: william.hallahan@yale.edu +maintainer: whallahan@binghamton.edu -- copyright: category: Formal Methods, Symbolic Computation build-type: Simple extra-source-files: README.md cabal-version: 1.24 +Flag support-lh + Description: Build modules for reasoning about LiquidHaskell + Default: True + source-repository head type: git location: https://github.com/BillHallahan/G2.git @@ -24,10 +28,32 @@ library exposed-modules: G2.Config + , G2.Config.Config + , G2.Config.Interface + , G2.Config.ParseConfig + , G2.Data.Timer + , G2.Data.UFMap + , G2.Data.UnionFind + , G2.Data.Utils + + , G2.Equiv.Approximation + , G2.Equiv.Config + , G2.Equiv.InitRewrite + , G2.Equiv.EquivADT + , G2.Equiv.G2Calls + , G2.Equiv.Verifier + , G2.Equiv.Tactics + , G2.Equiv.Types + , G2.Equiv.Generalize + , G2.Equiv.Summary + , G2.Equiv.Uninterpreted + , G2.Execution + , G2.Execution.HPC , G2.Execution.Interface , G2.Execution.Memory + , G2.Execution.NewPC , G2.Execution.NormalForms , G2.Execution.PrimitiveEval , G2.Execution.Reducer @@ -41,15 +67,18 @@ , G2.Initialization.InitVarLocs , G2.Initialization.KnownValues , G2.Initialization.MkCurrExpr - , G2.Initialization.StructuralEq , G2.Initialization.Types , G2.Interface + , G2.Interface.Interface + , G2.Interface.OutputTypes , G2.Language , G2.Language.AlgDataTy + , G2.Language.Approximation , G2.Language.ArbValueGen , G2.Language.AST + , G2.Language.CallGraph , G2.Language.Casts , G2.Language.CreateFuncs , G2.Language.Expr @@ -71,6 +100,7 @@ , G2.Language.Naming , G2.Language.PathConds , G2.Language.Primitives + , G2.Language.Simplification , G2.Language.Stack , G2.Language.Support , G2.Language.Syntax @@ -82,7 +112,7 @@ , G2.Lib.Printers - , G2.Liquid.Interface + , G2.Nebula , G2.Postprocessing.Interface @@ -90,8 +120,17 @@ , G2.Preprocessing.Interface , G2.Preprocessing.NameCleaner + , G2.Postprocessing.NameSwitcher + , G2.Solver + , G2.Solver.ADTNumericalSolver + , G2.Solver.Converters , G2.Solver.Interface + , G2.Solver.Language + , G2.Solver.Maximize + , G2.Solver.ParseSMT + , G2.Solver.Simplifier + , G2.Solver.SMT2 , G2.Solver.Solver , G2.QuasiQuotes.Internals.G2Rep @@ -103,35 +142,7 @@ , G2.Translation , G2.Translation.Cabal.Cabal - other-modules: G2.Config.Config - , G2.Config.Interface - , G2.Config.ParseConfig - - , G2.Interface.Interface - , G2.Interface.OutputTypes - - , G2.Liquid.AddCFBranch - , G2.Liquid.AddLHTC - , G2.Liquid.AddOrdToNum - , G2.Liquid.Annotations - , G2.Liquid.Conversion - , G2.Liquid.ConvertCurrExpr - , G2.Liquid.LHReducers - , G2.Liquid.Measures - , G2.Liquid.Simplify - , G2.Liquid.SpecialAsserts - , G2.Liquid.TCGen - , G2.Liquid.TCValues - , G2.Liquid.Types - - , G2.Postprocessing.NameSwitcher - - , G2.Solver.ADTSolver - , G2.Solver.Converters - , G2.Solver.Language - , G2.Solver.ParseSMT - , G2.Solver.SMT2 - + , G2.Translation.GHC , G2.Translation.Haskell , G2.Translation.HaskellCheck , G2.Translation.InjectSpecials @@ -139,96 +150,201 @@ , G2.Translation.PrimInject , G2.Translation.TransTypes - build-depends: array >= 0.5.1.1 && <= 0.5.3.0 - , Cabal >= 2.0.1.0 && <= 2.0.1.1 - , base >= 4.8 && < 5 - , bytestring >= 0.10.8.0 && <= 0.10.8.2 - , concurrent-extra >= 0.7 - , containers >= 0.5 && < 0.6 - , directory >= 1.3.0.2 && <= 1.3.3.2 - , extra >= 1.6.14 && <= 1.6.17 - , filepath == 1.4.1.2 + if flag(support-lh) && impl(ghc < 9.2) + exposed-modules: + G2.Liquid.AddCFBranch + , G2.Liquid.AddLHTC + , G2.Liquid.AddOrdToNum + , G2.Liquid.AddTyVars + , G2.Liquid.Annotations + , G2.Liquid.Config + , G2.Liquid.Conversion + , G2.Liquid.ConvertCurrExpr + , G2.Liquid.Helpers + , G2.Liquid.Interface + , G2.Liquid.LHReducers + , G2.Liquid.Measures + , G2.Liquid.MkLHVals + , G2.Liquid.Simplify + , G2.Liquid.SpecialAsserts + , G2.Liquid.TCGen + , G2.Liquid.TCValues + , G2.Liquid.Types + , G2.Liquid.TyVarBags + , G2.Liquid.G2Calls + , G2.Liquid.Inference.Config + , G2.Liquid.Inference.FuncConstraint + , G2.Liquid.Inference.G2Calls + , G2.Liquid.Inference.InfStack + , G2.Liquid.Inference.Initalization + , G2.Liquid.Inference.Interface + , G2.Liquid.Inference.PolyRef + , G2.Liquid.Inference.Sygus.UnsatCoreElim + , G2.Liquid.Inference.Sygus + , G2.Liquid.Inference.Sygus.FCConverter + , G2.Liquid.Inference.Sygus.RefSynth + , G2.Liquid.Inference.Sygus.LiaSynth + , G2.Liquid.Inference.Sygus.SimplifySygus + , G2.Liquid.Inference.Sygus.SpecInfo + , G2.Liquid.Inference.Sygus.Sygus + , G2.Liquid.Inference.UnionPoly + , G2.Liquid.Inference.Verify + , G2.Liquid.Inference.GeneratedSpecs + , G2.Liquid.Inference.QualifGen + + build-depends: array >= 0.5.1.1 && <= 0.5.5.0 + , Cabal >= 2.0.1.0 && < 3.11 + , base >= 4.8 && < 4.19 + , bimap == 0.3.3 + , bytestring >= 0.10.8.0 && < 0.11.5 + , clock >= 0.8 && < 0.9 + , concurrent-extra >= 0.7 && < 0.8 + , containers >= 0.5 && < 0.7 + , directory >= 1.3.0.2 && <= 1.3.8.1 + , extra >= 1.6.14 && < 1.7.13 + , filepath >= 1.4 && <= 1.5 , ghc-paths >= 0.1 && < 0.2 - , ghc == 8.2.2 - , hashable >= 1.2.6.0 && <= 1.3.0.0 - , hpc >= 0.6.0.0 && < 0.6.1 + , ghc (>= 8.2.2 && < 8.4) || (>= 8.6 && < 8.7) || (>= 8.10 && < 9.7) + , hashable >= 1.2.6.0 && <= 1.4.2.0 , HTTP >= 4000.3.0 && < 4001.0 - , liquidhaskell == 0.8.2.2 - , liquid-fixpoint >= 0.7.0.7 - , MissingH >= 1.4.0.0 && < 1.5 - , mtl >= 2.2 && < 2.3 + , language-sygus >= 0.1.1.3 && < 0.2 + , MissingH >= 1.4.0.0 && < 1.7 + , mtl >= 2.2 && < 2.4 + , random >= 1.1 && < 1.3 , reducers >= 3.12 && < 3.13 , regex-compat >= 0.95 && < 0.96 - , regex-base >= 0.93 && < 0.94 + , regex-base >= 0.93 && < 0.94.0.3 , parsec >= 3.1 && < 3.2 - , process >=1 && < 1.7 + , pretty >= 1.1 && < 1.4 + , process >=1.6 && < 1.7 + , optparse-applicative >=0.15.0.0 && < 0.18.0.0 , split >= 0.2.3 && < 0.2.4 - , template-haskell == 2.12.0.0 + , tasty-quickcheck >= 0.10.1.1 && < 0.11 + , template-haskell >= 2.12.0.0 && <= 2.20.0.0 , temporary-rc >= 1.2 && < 1.3 - , text == 1.2.3.1 - , time >= 1.6 && <= 1.9.3 - , unordered-containers >= 0.2 && < 0.3 + , text >= 1.2.3.1 && <= 2.1 + , text-builder >= 0.6.6.1 && < 0.7 + , time >= 1.6 && <= 1.13 + , unordered-containers >= 0.2.10.0 && < 0.3 + + -- remove this eventually + , deferred-folds <= 0.9.18.3 + + if flag(support-lh) && impl(ghc < 9.2) + build-depends: liquidhaskell >= 0.8.10.2 && <= 0.9.0.2.1 + , liquid-fixpoint >= 0.8.10.2 && < 0.10 + , Diff == 0.3.4 + + if flag(support-lh) && impl(ghc < 9) + build-depends: liquidhaskell == 0.8.10.2 + , liquid-fixpoint == 0.8.10.2 + default-language: Haskell2010 ghc-options: -Wall + -- -O1 + -fno-ignore-asserts + -- -ddump-rule-rewrites -- -ddump-splices - -- -fprof-auto - -- -fexternal-interpreter -opti+RTS -opti-p + -- -fexternal-interpreter + -- ghc-prof-options: -fprof-auto + other-extensions: CPP + if flag(support-lh) && impl(ghc < 9) + cpp-options: -DSUPPORT_LH + hs-source-dirs: src executable G2 -- other-modules: - -- other-extensions: + -- other-extensions: build-depends: g2 , base >= 4.8 && < 5 - , containers >= 0.5 && < 0.6 - , filepath == 1.4.1.2 - , ghc == 8.2.2 - , hpc >= 0.6.0.0 && < 0.6.1 - , text == 1.2.3.1 + , containers + , filepath >= 1.4 && <= 1.5 + , ghc + , text , unordered-containers >= 0.2 && < 0.3 default-language: Haskell2010 ghc-options: -threaded -Wall - -- -fprof-auto "-with-rtsopts=-p" + -- -fexternal-interpreter -opti+RTS -opti-p + -- ghc-prof-options: -fprof-auto "-with-rtsopts=-p" hs-source-dirs: exe main-is: Main.hs -executable QuasiQuote - -- other-extensions: +executable G2LH + if flag(support-lh) && impl(ghc < 9.2) + buildable: True + else + buildable: False + -- other-modules: + -- other-extensions: build-depends: g2 , base >= 4.8 && < 5 - , time >= 1.6 && <= 1.9.3 + , containers + , filepath >= 1.4 && <= 1.5 + , ghc + , text + , unordered-containers >= 0.2 && < 0.3 default-language: Haskell2010 - ghc-options: -Wall - -- -ddump-splices + ghc-options: -threaded -Wall -- -fprof-auto "-with-rtsopts=-p" - hs-source-dirs: quasiquote + -- -fexternal-interpreter -opti+RTS -opti-p + -- ghc-prof-options: -fprof-auto "-with-rtsopts=-p" + hs-source-dirs: lh main-is: Main.hs - other-modules: Arithmetics.Interpreter - , Arithmetics.Test - , DeBruijn.Interpreter - , DeBruijn.Test - , Evaluations - , Lambda.Interpreter - , Lambda.Test - , NQueens.Encoding - , NQueens.Test - , RegEx.RegEx - , RegEx.Test +executable Inference + if flag(support-lh) && impl(ghc < 9.2) + buildable: True + else + buildable: False + -- other-modules: + -- other-extensions: + build-depends: g2 + , base >= 4.8 && < 5 + , containers + , deepseq >= 1.4 && < 2 + , liquid-fixpoint + , liquidhaskell + , text + , time + default-language: Haskell2010 + ghc-options: -threaded -Wall + -- -O1 + -- ghc-prof-options: -fprof-auto "-with-rtsopts=-p" + hs-source-dirs: inference + main-is: Main.hs + +executable Nebula + -- other-modules: + -- other-extensions: + build-depends: g2 + , base >= 4.8 && < 5 + , containers + , filepath >= 1.4 && <= 1.5 + , ghc + , text + , unordered-containers >= 0.2 && < 0.3 + default-language: Haskell2010 + ghc-options: -threaded -Wall + -- ghc-prof-options: -fprof-auto "-with-rtsopts=-p" + hs-source-dirs: nebula + main-is: Main.hs + test-suite test build-depends: g2 , base >= 4.8 && < 5 - , containers >= 0.5 && < 0.6 + , containers + , directory , filepath - , ghc-paths >= 0.1 && < 0.2 + , ghc-paths , ghc , hashable - , hpc , tagged - , tasty >= 1.0 - , tasty-hunit >= 0.10 + , tasty >= 1.0 && < 2.0 + , tasty-hunit >= 0.10 && < 0.10.0.3 + , tasty-quickcheck , text - , time >= 1.6 + , time , unordered-containers default-language: Haskell2010 hs-source-dirs: tests @@ -241,9 +357,92 @@ , InputOutputTest , PeanoTest , Reqs + , Simplifications , TestUtils , Typing + , UFMapTests + , UnionFindTests + , RewriteVerify.RewriteVerifyTest ghc-options: -Wall + -threaded + -- ghc-prof-options: -fprof-auto "-with-rtsopts=-p" + type: exitcode-stdio-1.0 + +test-suite test-lh + if flag(support-lh) && impl(ghc < 9.2) + buildable: True + else + buildable: False + build-depends: g2 + , base >= 4.8 && < 5 + , containers + , directory + , filepath + , ghc-paths + , ghc + , hashable + , liquidhaskell + , tagged + , tasty >= 1.0 && < 2.0 + , tasty-hunit >= 0.10 && < 0.10.0.3 + , tasty-quickcheck + , text + , time + , unordered-containers + default-language: Haskell2010 + hs-source-dirs: tests_lh, tests + main-is: LHTest.hs + other-modules: GetNthTest + , PeanoTest + , Reqs + , TestUtils + , UnionPoly + ghc-options: -Wall + -threaded + -- ghc-prof-options: -fprof-auto "-with-rtsopts=-p" + type: exitcode-stdio-1.0 + +test-suite test-g2q + -- other-extensions: + build-depends: g2 + , base >= 4.8 && < 5 + , tasty >= 1.0 && < 2.0 + , tasty-hunit >= 0.10 && < 0.10.0.3 + , time + default-language: Haskell2010 + ghc-options: -Wall + -- -ddump-splices -- -fprof-auto "-with-rtsopts=-p" + hs-source-dirs: tests_quasiquote + main-is: Main.hs + other-modules: Arithmetics.Interpreter + , Arithmetics.Test + , DeBruijn.Interpreter + , DeBruijn.Test + , Evaluations + , Lambda.Interpreter + , Lambda.Test + , NQueens.Encoding + , NQueens.Test + , RegEx.RegEx + , RegEx.Test + , Simple.Simple1 + , Simple.SimpleTest1 + ghc-options: -Wall -threaded + -- ghc-prof-options: -fprof-auto "-with-rtsopts=-p" + type: exitcode-stdio-1.0 + +test-suite test-nebula-plugin + build-depends: base >= 4.8 && < 5 + , process + , tasty >= 1.0 && < 2.0 + , tasty-hunit >= 0.10 && < 0.10.0.3 + default-language: Haskell2010 + hs-source-dirs: tests_nebula_plugin + main-is: Main.hs + -- other-modules: + ghc-options: -Wall + -threaded + -- ghc-prof-options: -fprof-auto "-with-rtsopts=-p" type: exitcode-stdio-1.0 diff --git a/inference/Main.hs b/inference/Main.hs new file mode 100644 --- /dev/null +++ b/inference/Main.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where + +import G2.Config as G2 +import G2.Interface +import G2.Liquid.Config +import G2.Liquid.Interface +import G2.Liquid.Inference.Config +import G2.Liquid.Inference.G2Calls +import G2.Liquid.Inference.Initalization +import G2.Liquid.Inference.Interface +import G2.Liquid.Inference.Verify +import G2.Liquid.Helpers + +import Language.Fixpoint.Solver +import Language.Fixpoint.Types.Constraints +import Language.Haskell.Liquid.Types as LH + +import Control.DeepSeq +import qualified Data.Map as M +import qualified Data.Text as T +import Data.Time.Clock +import System.Environment + +main :: IO () +main = do + (f, count, config, g2lhconfig, infconfig, func) <- getAllConfigsForInf + + case func of + Nothing -> do + if count + then checkFuncNums f infconfig config g2lhconfig + else callInference f infconfig config g2lhconfig + Just func' -> do + ((in_out, _), entry) <- runLHInferenceAll infconfig config g2lhconfig (T.pack func') [] [f] + printLHOut entry in_out + return () + +-- checkQualifs :: String -> G2.Config -> IO () +-- checkQualifs f config = do +-- undefined +-- -- qualifGen "qualif.hquals" + +-- finfo <- parseFInfo ["qualif.hquals"] + +-- let infconfig = mkInferenceConfig [] +-- lhconfig <- quals finfo `deepseq` defLHConfig [] [] +-- let lhconfig' = lhconfig { pruneUnsorted = True } +-- ghcis <- ghcInfos Nothing lhconfig' [f] +-- let ghcis' = map (\ghci -> +-- let +-- ghci_quals = getQualifiers ghci-- spc = spec ghci +-- new_quals = ghci_quals ++ quals finfo +-- in +-- putQualifiers ghci new_quals) ghcis + +-- start <- getCurrentTime +-- res <- doTimeout 360 $ verify infconfig lhconfig' ghcis' +-- stop <- getCurrentTime + +-- case res of -- print $ quals finfo +-- Just Safe -> do +-- putStrLn "Safe" +-- print (stop `diffUTCTime` start) +-- Just _ -> putStrLn "Unsafe" +-- Nothing -> putStrLn "Timeout" + +callInference :: String -> InferenceConfig -> G2.Config -> LHConfig -> IO () +callInference f infconfig config lhconfig = do + (s, gs) <- inferenceCheck infconfig config lhconfig [] [f] + case gs of + Left gs' -> do + putStrLn "Counterexample" + printCE s gs' + Right gs' -> do + putStrLn "Safe" + print gs' + +checkFuncNums :: String -> InferenceConfig -> G2.Config -> LHConfig -> IO () +checkFuncNums f infconfig config g2lhconfig = do + (ghci, lhconfig) <- getGHCI infconfig [] [f] + (lrs, _, _, _, main_mod) <- getInitState [] [f] ghci infconfig config g2lhconfig + let nls = getNameLevels main_mod lrs + + print nls + + print $ length nls + print $ length (concat nls) - 1 + + return () diff --git a/lh/Main.hs b/lh/Main.hs new file mode 100644 --- /dev/null +++ b/lh/Main.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main (main) where + +import System.FilePath + +import qualified Data.Text as T + +import G2.Config +import G2.Interface + +import G2.Liquid.Config +import G2.Liquid.Interface + +main :: IO () +main = do + runSingleLHFun [] [] + +runSingleLHFun :: [FilePath] -> [FilePath] -> IO () +runSingleLHFun libs lhlibs = do + (src, func, config, lhconfig) <- getLHConfig + let proj = takeDirectory src + _ <- doTimeout (timeLimit config) $ do + ((in_out, _), entry) <- findCounterExamples [proj] [src] (T.pack func) config lhconfig + printLHOut entry in_out + return () diff --git a/nebula/Main.hs b/nebula/Main.hs new file mode 100644 --- /dev/null +++ b/nebula/Main.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} + +module Main (main) where + +import qualified Data.Text as T + +import G2.Config +import G2.Interface +import G2.Language +import G2.Translation + +import G2.Equiv.Config +import G2.Equiv.Verifier + +import Data.List + +main :: IO () +main = do + (src, entry, total, nebula_config) <- getNebulaConfig + + proj <- guessProj src + + let tentry = T.pack entry + + config <- getConfigDirect + + (init_state, bindings) <- initialStateNoStartFunc [proj] [src] + (simplTranslationConfig { simpl = True, load_rewrite_rules = True, hpc_ticks = False }) config + + let rule = find (\r -> tentry == ru_name r) (rewrite_rules bindings) + rule' = case rule of + Just r -> r + Nothing -> error "not found" + res <- checkRule config nebula_config init_state bindings total rule' + print res + return () diff --git a/quasiquote/Arithmetics/Interpreter.hs b/quasiquote/Arithmetics/Interpreter.hs deleted file mode 100644 --- a/quasiquote/Arithmetics/Interpreter.hs +++ /dev/null @@ -1,87 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} - -module Arithmetics.Interpreter where - -import Control.Monad -import Data.Data -import G2.QuasiQuotes.G2Rep - -type Ident = String -type Env = [(Ident, Int)] - -data AExpr = I Int | Var Ident - | Add AExpr AExpr | Mul AExpr AExpr - deriving (Eq, Show, Data) - -$(derivingG2Rep ''AExpr) - -data BExpr = Not BExpr | And BExpr BExpr | Or BExpr BExpr - | Lt AExpr AExpr | Eq AExpr AExpr - deriving (Eq, Show, Data) - -$(derivingG2Rep ''BExpr) - -type Stmts = [Stmt] -data Stmt = Assign Ident AExpr - | If BExpr Stmts Stmts - | While BExpr Stmts - | Assert BExpr - deriving (Eq, Show, Data) - -$(derivingG2Rep ''Stmt) - -type Bound = [Ident] -type Return = Ident -data Func = Func Bound Stmts Return - -$(derivingG2Rep ''Func) - -evalFunc :: [Int] -> Func -> Maybe Int -evalFunc is (Func b s r) = - lookup r =<< evalStmts (zip b is) s - -evalStmts :: Env -> Stmts -> Maybe Env -evalStmts = foldM evalStmt - -evalStmt :: Env -> Stmt -> Maybe Env -evalStmt env (Assign ident aexpr) = - Just $ (ident, evalA env aexpr):env -evalStmt env (If bexpr lhs rhs) = - if evalB env bexpr - then evalStmts env lhs - else evalStmts env rhs -evalStmt env (While bexpr loop) = - if evalB env bexpr - then evalStmts env (loop ++ [While bexpr loop]) - else Just env -evalStmt env (Assert bexpr) = - if evalB env bexpr - then Just env - else Nothing - -evalA :: Env -> AExpr -> Int -evalA _ (I int) = int -evalA env (Add lhs rhs) = - evalA env lhs + evalA env rhs -evalA env (Mul lhs rhs) = - evalA env lhs * evalA env rhs -evalA env (Var ident) = - case lookup ident env of - Just int -> int - _ -> error $ - "lookup with " ++ show (ident, env) - -evalB :: Env -> BExpr -> Bool -evalB env (Not bexpr) = not $ evalB env bexpr -evalB env (And lhs rhs) = - evalB env lhs && evalB env rhs -evalB env (Or lhs rhs) = - evalB env lhs || evalB env rhs -evalB env (Lt lhs rhs) = - evalA env lhs < evalA env rhs -evalB env (Eq lhs rhs) = - evalA env lhs == evalA env rhs - diff --git a/quasiquote/Arithmetics/Test.hs b/quasiquote/Arithmetics/Test.hs deleted file mode 100644 --- a/quasiquote/Arithmetics/Test.hs +++ /dev/null @@ -1,83 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} - -module Arithmetics.Test where - -import Arithmetics.Interpreter -import G2.QuasiQuotes.QuasiQuotes - -productTest :: IO (Maybe (AExpr, AExpr)) -productTest = - [g2| \(a :: Int) -> ?(s1 :: AExpr) - ?(s2 :: AExpr) | - let env = [("x", 23), ("y", 59)] in - let lhs = Mul (Var "x") (Var "y") in - let rhs = Mul s1 s2 in - evalB env (Eq lhs rhs) |] 0 - -envTest :: BExpr -> IO (Maybe Env) -envTest = [g2|\(b :: BExpr) -> ?(env :: Env) | - evalB env b |] - -assertViolation :: Stmts -> IO (Maybe Env) -assertViolation = [g2|\(stmts :: Stmts) -> ?(env :: Env) | - evalStmts env stmts == Nothing|] - -productSumTest :: IO (Maybe Env) -productSumTest = - envTest $ And - ((Eq - (Mul (Var "x") (Var "y")) - (Add (Var "x") (Var "y")))) - (Lt (I 0) (Var "x")) - - -assertViolationTest1 :: IO (Maybe Env) -assertViolationTest1 = assertViolation - [ Assert (Lt (I 5) (I 3)) ] - --- x^2 + y^2 + z^2 < (x + y + z)^2 -assertViolationTest2 :: IO (Maybe Env) -assertViolationTest2 = assertViolation - [ Assign "v1" (Add (Var "x") (Add (Var "y") (Var "z"))) - , Assign "v1" (Mul (Var "v1") (Var "v1")) - , Assign "v2" (Add (Mul (Var "x") (Var "x")) - (Add (Mul (Var "y") (Var "y")) - (Mul (Var "z") (Var "z")))) - , Assert (Lt (Var "v2") (Var "v1")) - ] - - -assertViolationTest3 :: IO (Maybe Env) -assertViolationTest3 = assertViolation - [ - Assign "k" (I 1), - Assign "i" (I 0), - Assign "j" (I 0), - Assign "n" (I 5), - While (Or (Lt (Var "i") (Var "n")) - (Eq (Var "i") (Var "n"))) - [ Assign "i" (Add (Var "i") (I 1)) - , Assign "j" (Add (Var "j") (Var "i")) - ], - Assign "z" (Add (Var "k") (Add (Var "i") (Var "j"))), - Assert (Lt (Mul (Var "n") (I 2)) (Var "z")) - ] - - -assertViolationTest4 :: IO (Maybe Env) -assertViolationTest4 = assertViolation - [ - Assign "k" (I 1), - Assign "i" (I 0), - -- Assign "j" (I 0), - Assign "n" (I 5), - While (Or (Lt (Var "i") (Var "n")) - (Eq (Var "i") (Var "n"))) - [ Assign "i" (Add (Var "i") (I 1)) - , Assign "j" (Add (Var "j") (Var "i")) - ], - Assign "z" (Add (Var "k") (Add (Var "i") (Var "j"))), - Assert (Lt (Mul (Var "n") (I 2)) (Var "z")) - ] - - diff --git a/quasiquote/DeBruijn/Interpreter.hs b/quasiquote/DeBruijn/Interpreter.hs deleted file mode 100644 --- a/quasiquote/DeBruijn/Interpreter.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} - -module DeBruijn.Interpreter ( Expr (..) - , Ident - , eval - , app - , lams - , num) where - -import Data.Data -import G2.QuasiQuotes.G2Rep - -type Ident = Int - -data Expr = Var Ident - | Lam Expr - | App Expr Expr - deriving (Show, Read, Eq, Data) - -$(derivingG2Rep ''Expr) - -type Stack = [Expr] - -eval :: Expr -> Expr -eval = eval' [] - -eval' :: Stack -> Expr -> Expr -eval' (e:stck) (Lam e') = eval' stck (rep 1 e e') -eval' stck (App e1 e2) = eval' (e2:stck) e1 -eval' stck e = app $ e:stck - -rep :: Int -> Expr -> Expr -> Expr -rep i e v@(Var j) - | i == j = e - | otherwise = v -rep i e (Lam e') = Lam (rep (i + 1) e e') -rep i e (App e1 e2) = App (rep i e e1) (rep i e e2) - -app :: [Expr] -> Expr -app = foldl1 App - -lams :: Int -> Expr -> Expr -lams n e = iterate Lam e !! n - -num :: Int -> Expr -num n = Lam $ Lam $ foldr1 App (replicate n (Var 2) ++ [Var 1]) diff --git a/quasiquote/DeBruijn/Test.hs b/quasiquote/DeBruijn/Test.hs deleted file mode 100644 --- a/quasiquote/DeBruijn/Test.hs +++ /dev/null @@ -1,62 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} - -module DeBruijn.Test where - -import DeBruijn.Interpreter -import G2.QuasiQuotes.QuasiQuotes - -solveDeBruijn1 :: IO (Maybe Expr) -solveDeBruijn1 = - [g2| \(x :: Int) -> ?(syExpr :: Expr) | - let expr = App syExpr in - eval (expr (Lam (Var 1))) == (Lam (Var 1)) - && eval (expr (Lam (Var 2))) == (Lam (Var 2)) |] 6 - -solveDeBruijn :: [([Expr], Expr)] -> IO (Maybe Expr) -solveDeBruijn = - [g2| \(es :: [([Expr], Expr)]) -> ?(func :: Expr) | - all (\e -> (eval (app (func:fst e))) == snd e) es |] - -solveDeBruijnI :: IO (Maybe Expr) -solveDeBruijnI = solveDeBruijn [ ([num 1], num 1) - , ([num 2], num 2) ] - -solveDeBruijnK :: IO (Maybe Expr) -solveDeBruijnK = solveDeBruijn [ ([num 1, num 2], num 2) - , ([num 2, num 3], num 3)] - -trueLam :: Expr -trueLam = Lam (Lam (Var 2)) - -falseLam :: Expr -falseLam = Lam (Lam (Var 1)) - -solveDeBruijnAnd :: IO (Maybe Expr) -solveDeBruijnAnd = solveDeBruijn [ ([trueLam, trueLam], trueLam) - , ([falseLam, falseLam], falseLam) - , ([falseLam, trueLam], falseLam) - , ([trueLam, falseLam], falseLam) ] - -solveDeBruijnOr :: IO (Maybe Expr) -solveDeBruijnOr = solveDeBruijn [ ([trueLam, trueLam], trueLam) - , ([falseLam, falseLam], falseLam) - , ([falseLam, trueLam], trueLam) - , ([trueLam, falseLam], trueLam) ] - -solveDeBruijnIte :: IO (Maybe Expr) -solveDeBruijnIte = solveDeBruijn [ ([trueLam, Var 2, Var 4], Var 2) - , ([falseLam, Var 2, Var 4], Var 4) ] - -solveDeBruijnS :: IO (Maybe Expr) -solveDeBruijnS = - solveDeBruijn - [ ([Lam (Lam (Var 1)), Lam (Var 1), num 2], num 2) - , ([Lam (Lam (Var 1)), Lam (Lam (Var 2)), num 3], num 3) ] - -- [g2| \(_ :: ()) -> ?(func :: Expr) | - -- let - -- k = Lam (Lam (Var 2)) - -- in - -- eval (App func (App k (App (num 1) (num 2)))) == num 2 - -- |] () - -- , ([Lam (Lam (Var 1)), Lam (num 3), num 1], num 3)] - -- , ([Lam (Lam (Lam (Var 2))), Lam (Lam (Var 1)), num 1], Lam (Lam (num 1)))] diff --git a/quasiquote/Evaluations.hs b/quasiquote/Evaluations.hs deleted file mode 100644 --- a/quasiquote/Evaluations.hs +++ /dev/null @@ -1,194 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} - -module Evaluations where - -import Data.Time.Clock -import G2.QuasiQuotes.QuasiQuotes - -import Arithmetics.Interpreter as A -import DeBruijn.Interpreter as D -import RegEx.RegEx as R - - -timeIOAction :: IO a -> IO (a, NominalDiffTime) -timeIOAction action = do - start <- getCurrentTime - res <- action - end <- getCurrentTime - let diff = diffUTCTime end start - return (res, diff) - -timeIOActionPrint :: Show a => IO a -> IO () -timeIOActionPrint action = do - (res, time) <- timeIOAction action - putStrLn $ show res - putStrLn $ "time: " ++ show time - - -------------------------------------------- -------------------------------------------- --- Section 2 (Arithmetics) -searchBadEnv :: Stmts -> IO (Maybe Env) -searchBadEnv = - [g2| \(stmts :: Stmts) -> ?(env :: Env) | - evalStmts env stmts == Nothing|] - -envTest :: BExpr -> IO (Maybe Env) -envTest = [g2|\(b :: BExpr) -> ?(env :: Env) | - evalB env b |] - -badProg :: Stmts -badProg = - [ - Assign "k" (I 1), - Assign "i" (I 0), - -- Assign "j" (I 0), - Assign "n" (I 5), - While (A.Or (Lt (A.Var "i") (A.Var "n")) - (Eq (A.Var "i") (A.Var "n"))) - [ Assign "i" (Add (A.Var "i") (I 1)) - , Assign "j" (Add (A.Var "j") (A.Var "i")) - ], - Assign "z" (Add (A.Var "k") (Add (A.Var "i") (A.Var "j"))), - Assert (Lt (Mul (A.Var "n") (I 2)) (A.Var "z")) - ] - -productSumTest :: BExpr -productSumTest = - And - ((Eq - (Mul (A.Var "x") (A.Var "y")) - (Add (A.Var "x") (A.Var "y")))) - (Lt (I 0) (A.Var "x")) - -runArithmeticsEval :: IO () -runArithmeticsEval = do - putStrLn "------------------------" - putStrLn "-- Arithmetics Eval -------" - timeIOActionPrint $ searchBadEnv badProg - timeIOActionPrint $ envTest productSumTest - putStrLn "" - - - -------------------------------------------- -------------------------------------------- --- Section 5.1 (n Queens) - - -------------------------------------------- -------------------------------------------- --- Section 5.2 (Lambda Calculus) - -solveDeBruijn :: [([Expr], Expr)] -> IO (Maybe Expr) -solveDeBruijn = - [g2| \(es :: [([Expr], Expr)]) -> ?(func :: Expr) | - all (\e -> (eval (app (func:fst e))) == snd e) es |] - -idDeBruijn :: [([D.Expr], D.Expr)] -idDeBruijn = [ ([num 1], num 1) - , ([num 2], num 2) ] - -const2Example :: [([D.Expr], D.Expr)] -const2Example = - [ ([num 1, num 2], num 1) - , ([num 2, num 3], num 2) ] - -trueLam :: D.Expr -trueLam = Lam (Lam (D.Var 2)) - -falseLam :: D.Expr -falseLam = Lam (Lam (D.Var 1)) - -notExample :: [([D.Expr], D.Expr)] -notExample = - [ ([trueLam], falseLam) - , ([falseLam], trueLam) ] - -orExample :: [([D.Expr], D.Expr)] -orExample = - [ ([trueLam, trueLam], trueLam) - , ([falseLam, falseLam], falseLam) - , ([falseLam, trueLam], trueLam) - , ([trueLam, falseLam], trueLam )] - -andExample :: [([D.Expr], D.Expr)] -andExample = - [ ([trueLam, trueLam], trueLam) - , ([falseLam, falseLam], falseLam) - , ([falseLam, trueLam], falseLam) - , ([trueLam, falseLam], falseLam )] - - -runDeBruijnEval :: IO () -runDeBruijnEval = do - putStrLn "------------------------" - putStrLn "-- DeBruijn Eval -------" - timeIOActionPrint $ solveDeBruijn idDeBruijn - timeIOActionPrint $ solveDeBruijn const2Example - -- timeIOActionPrint $ solveDeBruijn notExample - timeIOActionPrint $ solveDeBruijn orExample - -- timeIOActionPrint $ solveDeBruijn andExample - putStrLn "" - - -------------------------------------------- -------------------------------------------- --- Section 5.3 (Regular Expressions) - -stringSearch :: RegEx -> IO (Maybe String) -stringSearch = - [g2| \(r :: RegEx) -> ?(str :: String) | - match r str |] - --- (a + b)* c (d + (e f)*) -regex1 :: RegEx -regex1 = - Concat (Star (R.Or (Atom 'a') (Atom 'b'))) - (Concat (Atom 'c') - (R.Or (Atom 'd') - (Concat (Atom 'e') - (Atom 'f')))) - -regex2 :: RegEx -regex2 = Concat (Atom 'a') - (Concat (Atom 'b') - (Concat (Atom 'c') - (Concat (Atom 'd') - (Concat (Atom 'e') - ((Atom 'f')))))) - -regex3 :: RegEx -regex3 = R.Or (Atom 'a') - (R.Or (Atom 'b') - (R.Or (Atom 'c') - (R.Or (Atom 'd') - (R.Or (Atom 'e') - ((Atom 'f')))))) - -regex4 :: RegEx -regex4 = Concat (Star (Atom 'a')) - (Concat (Star (Atom 'b')) - (Concat (Star (Atom 'c')) - (Concat (Star (Atom 'd')) - (Concat (Star (Atom 'e')) - ((Star (Atom 'f'))))))) - - - -runRegExEval :: IO () -runRegExEval = do - putStrLn "------------------------" - putStrLn "-- RegEx Eval ----------" - timeIOActionPrint $ stringSearch regex1 - timeIOActionPrint $ stringSearch regex2 - timeIOActionPrint $ stringSearch regex3 - timeIOActionPrint $ stringSearch regex4 - putStrLn "" - - - -------------------------------------------- -------------------------------------------- - - diff --git a/quasiquote/Lambda/Interpreter.hs b/quasiquote/Lambda/Interpreter.hs deleted file mode 100644 --- a/quasiquote/Lambda/Interpreter.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} - -module Lambda.Interpreter where - -import Data.Data -import Data.List -import G2.QuasiQuotes.QuasiQuotes -import G2.QuasiQuotes.G2Rep - -type Id = String - -data Prim = I Int | B Bool | Fun Id - deriving (Show, Eq, Data) - -$(derivingG2Rep ''Prim) - -data Expr - = Var Id - | Lam Id Expr - | App Expr Expr - | Const Prim - deriving (Show, Eq, Data) - -$(derivingG2Rep ''Expr) - -type Env = [(Id, Expr)] - -eval :: Env -> Expr -> Expr -eval env (Var id) = - case lookup id env of - Just expr -> eval env expr - Nothing -> Const (Fun id) -eval env (App (Lam i body) arg) = - eval ((i, arg) : env) body -eval env expr = expr - diff --git a/quasiquote/Lambda/Test.hs b/quasiquote/Lambda/Test.hs deleted file mode 100644 --- a/quasiquote/Lambda/Test.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} - -module Lambda.Test where - -import Lambda.Interpreter -import G2.QuasiQuotes.QuasiQuotes - -lambdaTest1 :: IO (Maybe Expr) -lambdaTest1 = [g2| \(x :: Int ) -> ?(symExpr :: Expr) | - let env = [] in - let expr = App (Lam "b" (Var "b")) symExpr in - eval env expr == (Const (I 40)) |] 0 - - -lambdaTest2 :: IO (Maybe Expr) -lambdaTest2 = [g2| \(x :: Int ) -> ?(symExpr :: Expr) | - let env = [] in - let expr = symExpr in - eval env expr == (Const (I 43)) |] 0 diff --git a/quasiquote/Main.hs b/quasiquote/Main.hs deleted file mode 100644 --- a/quasiquote/Main.hs +++ /dev/null @@ -1,255 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} - -module Main where - -import DeBruijn.Test -import Arithmetics.Test -import Lambda.Test -import NQueens.Test -import RegEx.Test - -import Evaluations hiding (productSumTest) - -arithmeticsTests :: IO () -arithmeticsTests = do - putStrLn "---------------------" - putStrLn "arithmeticsTests ----" - - putStrLn "-- productTest" - timeIOActionPrint productTest - putStrLn "" - - putStrLn "-- productSumTest" - timeIOActionPrint productSumTest - putStrLn "" - - putStrLn "-- assertViolationTest1" - timeIOActionPrint assertViolationTest1 - putStrLn "" - - -- Technically this is non-linear integer arithm so undecidable - -- putStrLn "-- assertViolationTest2" - -- timeIOActionPrint assertViolationTest2 - -- putStrLn "" - - -- About 6 secs - putStrLn "-- assertViolationTest3" - timeIOActionPrint assertViolationTest3 - putStrLn "" - - -- About 51 secs - putStrLn "-- assertViolationTest4" - timeIOActionPrint assertViolationTest4 - putStrLn "" - - - - - putStrLn "---------------------\n\n" - - -lambdaTests :: IO () -lambdaTests = do - putStrLn "---------------------" - putStrLn "lambdaTests ---------" - - putStrLn "-- lambdaTest1" - timeIOActionPrint lambdaTest1 - putStrLn "" - - putStrLn "-- lambdaTest2" - timeIOActionPrint lambdaTest2 - putStrLn "" - - putStrLn "---------------------\n\n" - return () - - -nqueensTests :: IO () -nqueensTests = do - putStrLn "---------------------" - putStrLn "nqueensTests --------" - - putStrLn "-- queensTestN 4" - timeIOActionPrint $ queensTestN 4 - putStrLn "" - - putStrLn "-- queensTestN 5" - timeIOActionPrint $ queensTestN 5 - putStrLn "" - - putStrLn "-- queensTestN 6" - timeIOActionPrint $ queensTestN 6 - putStrLn "" - - putStrLn "-- queensTestN 7" - timeIOActionPrint $ queensTestN 7 - putStrLn "" - - putStrLn "-- queensTestN 8" - timeIOActionPrint $ queensTestN 8 - putStrLn "" - - putStrLn "---------------------\n\n" - return () - - -debruijnTests :: IO () -debruijnTests = do - putStrLn "---------------------" - putStrLn "debruijnTests -------" - - putStrLn "-- solveDeBruijnI" -- identity - timeIOActionPrint $ solveDeBruijnI - - putStrLn "-- solveDeBruijnK" -- const - timeIOActionPrint $ solveDeBruijnK - - putStrLn "-- solveDeBruijnOr" - timeIOActionPrint $ solveDeBruijnOr - - -- putStrLn "-- solveDeBruijnAnd" - -- timeIOActionPrint $ solveDeBruijnAnd - - putStrLn "-- solveDeBruijnIte" - timeIOActionPrint $ solveDeBruijnIte - - putStrLn "---------------------\n\n" - return () - -regexTests :: IO () -regexTests = do - putStrLn "---------------------" - putStrLn "regexTests ----------" - - putStrLn "-- regexTest1" - timeIOActionPrint regexTest1 - putStrLn "" - - putStrLn "-- regexTest2" - timeIOActionPrint regexTest2 - putStrLn "" - - putStrLn "---------------------\n\n" - return () - - - -main :: IO () -main = do - putStrLn "main: compiles!" - - -- arithmeticsTests - -- lambdaTests - -- nqueensTests - -- debruijnTests - -- regexTests - - nqueensTests - runArithmeticsEval - runDeBruijnEval - runRegExEval - - - - putStrLn "main: done" - - - -- print =<< queensTestN 6 - -- print =<< solveDeBruijnI - -- print =<< solveDeBruijnK - -- print =<< lambdaTest2 - - -- putStrLn "-- Basic Test --" - -- r <- f 8 10 - -- print r - - -- r2 <- g 7 - -- print r2 - - -- r3 <- h 11 - -- print r3 - - -- putStrLn "\n-- Bool Test --" - -- print =<< boolTest 2 - -- print =<< boolTest 4 - - -- putStrLn "\n-- maybeOrdering Test --" - -- print =<< maybeOrderingTest (Just LT) - - -- putStrLn "\n-- Rearrange Tuples Test --" - -- print =<< rearrangeTuples (4, 5) (-6, -4) - - -- putStrLn "\n-- Float Test --" - -- print =<< floatTest (6.7) (9.5) - - -- putStrLn "\n-- Double Test --" - -- print =<< doubleTest (2.2) (4.9) - - -- putStrLn "\n-- String Test --" - -- print =<< stringTest "hiiiiiiiiiiiiiiiit!" - - -- putStrLn "\n-- Import Test --" - -- print =<< importTest 5 - - -- putStrLn "\n-- Infinite Test --" - -- print =<< infiniteTest [5..] - - -- putStrLn "\n-- Infinite Test 2 --" - -- print =<< infiniteTest2 [5..] 3 - - -- putStrLn "\n-- Infinite Return --" - -- ir <- infiniteReturn 8 - -- print $ fmap (headInf . tailInf) ir - --- fBad1 :: Float -> Int -> IO (Maybe Int) --- fBad1 = [g2|(\y z -> \x ? x + 2 == y + z) :: Int -> Int -> Int -> Bool|] - --- fBad2 :: Int -> Int -> IO (Maybe Float) --- fBad2 = [g2|(\y z -> \x ? x + 2 == y + z) :: Int -> Int -> Int -> Bool|] - --- f :: Int -> Int -> IO (Maybe Int) --- f = [g2|\(y :: Int) (z :: Int) -> ?(x :: Int) | x + 2 == y + z|] - --- g :: Int -> IO (Maybe (Int, Int)) --- g = [g2|\(a :: Int) -> ?(x :: Int) ?(y :: Int) | x < a && a < y && y - x > 10|] - --- h :: Int -> IO (Maybe [Int]) --- h = [g2|\(total :: Int) -> ?(lst :: [Int]) | sum lst == total && length lst >= 2|] - --- boolTest :: Int -> IO (Maybe Bool) --- boolTest = [g2|\(i ::Int) -> ?(b :: Bool) | (i == 4) == b|] - --- maybeOrderingTest :: Maybe Ordering -> IO (Maybe (Maybe Ordering)) --- maybeOrderingTest = [g2|\(m1 :: Maybe Ordering) -> ?(m2 :: Maybe Ordering) | (fmap succ m1 == m2)|] - --- rearrangeTuples :: (Int, Int) -> (Int, Int) -> IO (Maybe (Int, Int)) --- rearrangeTuples = [g2|\(ux :: (Int, Int)) (yz :: (Int, Int)) -> ?(ab :: (Int, Int)) | --- let --- (u, x) = ux --- (y, z) = yz --- (a, b) = ab --- in --- (a == u || a == y) --- && (b == x || b == z) && (a + b == 0 )|] - --- floatTest :: Float -> Float -> IO (Maybe Float) --- floatTest = [g2|\(f1 :: Float) (f2 :: Float) -> ?(f3 :: Float) | f1 < f3 && f3 < f2|] - --- doubleTest :: Double -> Double -> IO (Maybe Double) --- doubleTest = [g2|\(d1 :: Double) (d2 :: Double) -> ?(d3 :: Double) | d1 <= d3 && d3 <= d2|] - --- stringTest :: String -> IO (Maybe String) --- stringTest = [g2|\(str1 :: String) -> ?(str2 :: String) | str1 == str2 ++ "!"|] - --- importTest :: Int -> IO (Maybe Int) --- importTest = [g2|\(x :: Int) -> ?(ans :: Int) | addTwo x == ans|] - --- infiniteTest :: [Int] -> IO (Maybe Int) --- infiniteTest = [g2|\(xs :: [Int]) -> ?(x :: Int) | x == head xs|] - --- infiniteTest2 :: [Int] -> Int -> IO (Maybe [Int]) --- infiniteTest2 = [g2|\(xs :: [Int]) (t :: Int) -> ?(ys :: [Int]) | ys == take t xs|] - --- infiniteReturn :: Int -> IO (Maybe (InfList Int)) --- infiniteReturn = [g2|\(t :: Int) -> ?(ys :: InfList Int) | headInf ys == t |] diff --git a/quasiquote/NQueens/Encoding.hs b/quasiquote/NQueens/Encoding.hs deleted file mode 100644 --- a/quasiquote/NQueens/Encoding.hs +++ /dev/null @@ -1,62 +0,0 @@ -module NQueens.Encoding where - -import Data.List - -type Queen = Int - -indexPairs :: Int -> [(Int,Int)] -indexPairs n = [(i, j) | i <- [0..n-1], j <- [i+1..n-1]] - -legal :: Int -> Queen -> Bool -legal n qs = 1 <= qs && qs <= n - -queenPairSafe :: Int -> [Queen] -> (Int, Int) -> Bool -queenPairSafe n qs (i, j) = - let qs_i = qs !! i - qs_j = qs !! j - in (qs_i /= qs_j) - -- && (abs (qs_j - qs_i) /= (j - i)) - && qs_j - qs_i /= j - i - && qs_j - qs_i /= i - j - -allQueensSafe :: Int -> [Queen] -> Bool -allQueensSafe n qs = - (n == length qs) - && all (legal n) qs - && (all (queenPairSafe n qs) (indexPairs n)) - -solveListCompN :: Int -> [Int] -solveListCompN n = - head . filter (allQueensSafe n) $ [x | x <- mapM (const [1..n]) [1..n]] - -{- --- Gets all pairs of unique positions -pairs :: Ord a => [a] -> [(a, a)] -pairs xs = [(a, b) | a <- xs, b <- xs, a < b] - --- Checks if all elements of list are unique -allUnique :: Ord a => [a] -> Bool -allUnique xs = length xs == length (nub xs) - --- Check if two positions are safe -pairSafe :: (Queen, Queen) -> Bool -pairSafe ((x1, y1), (x2, y2)) = - -- No same x and y value - (x1 /= x2) && (y1 /= y2) - -- Not on the same diagonal - && (abs (x1 - x2) /= abs (y1 - y2)) - --- Check that all queens in a list are safe -allSafe :: [Queen] -> Bool -allSafe queens = all pairSafe $ pairs queens - --- Valid Queens on an n x n board -legalQueens :: Int -> [Queen] -> Bool -legalQueens n queens = - (length queens == n) - && (n == length (nub queens)) - && all (\(x, y) -> 1 <= x && x <= n && 1 <= y && y <= n) queens - -- && all (\p -> (1, 1) <= p && p <= (n, n)) queens - --} - diff --git a/quasiquote/NQueens/Test.hs b/quasiquote/NQueens/Test.hs deleted file mode 100644 --- a/quasiquote/NQueens/Test.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} - -module NQueens.Test where - -import NQueens.Encoding -import G2.QuasiQuotes.QuasiQuotes - -{- -queensTestN :: Int -> IO (Maybe [Queen]) -queensTestN n = [g2| \(n :: Int) -> ?(queens :: [Queen]) | - legalQueens n queens - && allSafe queens |] n --} - -queensTestN :: Int -> IO (Maybe [Queen]) -queensTestN num = [g2| \(n :: Int) -> ?(qs :: [Queen]) | - allQueensSafe n qs |] num - - diff --git a/quasiquote/RegEx/RegEx.hs b/quasiquote/RegEx/RegEx.hs deleted file mode 100644 --- a/quasiquote/RegEx/RegEx.hs +++ /dev/null @@ -1,36 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} - -module RegEx.RegEx where - -import Data.Data -import G2.QuasiQuotes.G2Rep - - -data RegEx = Empty | Epsilon | Atom Char - | Star RegEx | Concat RegEx RegEx | Or RegEx RegEx - deriving (Show, Eq, Data) - -$(derivingG2Rep ''RegEx) - -match :: RegEx -> String -> Bool -match Empty _ = False -match Epsilon s = null s -match (Atom x) s = s == [x] -match (Star _) [] = True -match r@(Star x) s = any (match2 x r) - (splits [1..length s] s) -match (Concat a b) s = any (match2 a b) - (splits [0..length s] s) -match (Or a b) s = match a s || match b s - -match2 :: RegEx -> RegEx -> (String, String) -> Bool -match2 a b (sa, sb) = match a sa && match b sb - -splits :: [Int] -> [a] -> [([a], [a])] -splits ns x = map (\n -> splitAt n x) ns - - - - diff --git a/quasiquote/RegEx/Test.hs b/quasiquote/RegEx/Test.hs deleted file mode 100644 --- a/quasiquote/RegEx/Test.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} - -module RegEx.Test where - -import RegEx.RegEx -import G2.QuasiQuotes.QuasiQuotes - -regexTest1 :: IO (Maybe String) -regexTest1 = stringSearch (Concat (Atom 'a') (Atom 'b')) - -regexTest2 :: IO (Maybe String) -regexTest2 = stringSearch r - where - r = Concat - (Star (Or (Atom 'a') (Atom 'b'))) - (Concat (Atom 'c') - (Or (Atom 'd') - (Concat (Atom 'e') - (Atom 'f')))) - - -stringSearch :: RegEx -> IO (Maybe String) -stringSearch = [g2| \(r :: RegEx) -> ?(str :: String) | - match r str |] - diff --git a/src/G2/Config/Config.hs b/src/G2/Config/Config.hs --- a/src/G2/Config/Config.hs +++ b/src/G2/Config/Config.hs @@ -1,27 +1,50 @@ module G2.Config.Config ( Mode (..) + , LogMode (..) + , LogMethod (..) + , Sharing (..) , SMTSolver (..) + , SearchStrategy (..) , HigherOrderSolver (..) , IncludePath , Config (..) , BoolDef (..) , mkConfig + , mkConfigDirect + + , mkLogMode + , strArg - , boolArg) where + , boolArg + , boolArg' + , baseDef + , baseSimple) where + import Data.Char import Data.List import qualified Data.Map as M +import Data.Monoid ((<>)) +import Options.Applicative +import Text.Read -import System.Directory +data Mode = Regular | Liquid deriving (Eq, Show, Read) +data LogMode = Log LogMethod String | NoLog deriving (Eq, Show, Read) -data Mode = Regular | Liquid deriving (Eq, Show, Read) +data LogMethod = Raw | Pretty deriving (Eq, Show, Read) +-- | Do we use sharing to only reduce variables once? +data Sharing = Sharing | NoSharing deriving (Eq, Show, Read) + data SMTSolver = ConZ3 | ConCVC4 deriving (Eq, Show, Read) +data SearchStrategy = Iterative | Subpath deriving (Eq, Show, Read) + data HigherOrderSolver = AllFuncs - | SingleFunc deriving (Eq, Show, Read) + | SingleFunc + | SymbolicFunc + | SymbolicFuncTemplate deriving (Eq, Show, Read) type IncludePath = FilePath @@ -31,82 +54,176 @@ , base :: [FilePath] -- ^ Filepath(s) to base libraries. Get compiled in order from left to right , extraDefaultInclude :: [IncludePath] , extraDefaultMods :: [FilePath] - , logStates :: Maybe String -- ^ If Just, dumps all thes states into the given folder + , logStates :: LogMode -- ^ Determines whether to Log states, and if logging states, how to do so. + , sharing :: Sharing , maxOutputs :: Maybe Int -- ^ Maximum number of examples/counterexamples to output. TODO: Currently works only with LiquidHaskell - , printCurrExpr :: Bool -- ^ Controls whether the curr expr is printed - , printExprEnv :: Bool -- ^ Controls whether the expr env is printed - , printRelExprEnv :: Bool -- ^ Controls whether the portion of the expr env relevant to the curr expr and path constraints is printed - , printPathCons :: Bool -- ^ Controls whether path constraints are printed , returnsTrue :: Bool -- ^ If True, shows only those inputs that do not return True , higherOrderSolver :: HigherOrderSolver -- ^ How to try and solve higher order functions + , search_strat :: SearchStrategy -- ^ The search strategy for the symbolic executor to use + , subpath_length :: Int -- ^ When using subpath search strategy, the length of the subpaths. , smt :: SMTSolver -- ^ Sets the SMT solver to solve constraints with , steps :: Int -- ^ How many steps to take when running States - , cut_off :: Int -- ^ How many steps to take after finding an equally good equiv state, in LH mode - , switch_after :: Int --- ^ How many steps to take in a single step, in LH mode + , hpc :: Bool -- ^ Should HPC ticks be generated and tracked during execution? , strict :: Bool -- ^ Should the function output be strictly evaluated? , timeLimit :: Int -- ^ Seconds - , validate :: Bool -- ^ If True, HPC is run on G2's output, to measure code coverage. TODO: Currently doesn't work - -- , baseLibs :: [BaseLib] + , validate :: Bool -- ^ If True, run on G2's input, and check against expected output. } --- mkConfigDef :: Config --- mkConfigDef = mkConfig [] M.empty +mkConfig :: String -> Parser Config +mkConfig homedir = Config Regular + <$> mkBaseInclude homedir + <*> mkBase homedir + <*> mkExtraDefault homedir + <*> pure [] + <*> mkLogMode + <*> flag Sharing NoSharing (long "no-sharing" <> help "disable sharing") + <*> mkMaxOutputs + <*> switch (long "returns-true" <> help "assert that the function returns true, show only those outputs which return false") + <*> mkHigherOrder + <*> mkSearchStrategy + <*> option auto (long "subpath-len" + <> metavar "L" + <> value 4 + <> help "when using subpath search strategy, the length of the subpaths") + <*> mkSMTSolver + <*> option auto (long "n" + <> metavar "N" + <> value 1000 + <> help "how many steps to take when running states") + <*> flag False True (long "hpc" + <> help "Generate and report on HPC ticks") + <*> flag True False (long "no-strict" <> help "do not evaluate the output strictly") + <*> option auto (long "time" + <> metavar "T" + <> value 600 + <> help "time limit, in seconds") + <*> switch (long "validate" <> help "use GHC to automatically compile and run on generated inputs, and check that generated outputs are correct") -baseRoot :: IO FilePath -baseRoot = do - g2Dir <- getHomeDirectory >>= \f -> return $ f ++ "/.g2" - return $ g2Dir ++ "/base-4.9.1.0" +mkBaseInclude :: String -> Parser [IncludePath] +mkBaseInclude homedir = + option (eitherReader (Right . baseIncludeDef)) + ( long "base" + <> metavar "FILE" + <> value (baseIncludeDef homedir) + <> help "where to look for base files") +mkBase :: String -> Parser [IncludePath] +mkBase homedir = + option (eitherReader (Right . baseDef)) + ( long "base-def" + <> metavar "FILE" + <> value (baseDef homedir) + <> help "where to look for base files") -mkConfig :: String -> [String] -> M.Map String [String] -> Config -mkConfig homedir as m = Config { +mkExtraDefault :: String -> Parser [IncludePath] +mkExtraDefault homedir = + option (eitherReader (\v -> Right (v:extraDefaultIncludePaths homedir))) + ( long "extra-def" + <> metavar "FILE" + <> value (extraDefaultIncludePaths homedir) + <> help "where to look for base files") + +mkLogMode :: Parser LogMode +mkLogMode = + (option (eitherReader (Right . Log Raw)) + (long "log-states" + <> metavar "FOLDER" + <> value NoLog + <> help "log all states with raw printing")) + <|> + (option (eitherReader (Right . Log Pretty)) + (long "log-pretty" + <> metavar "FOLDER" + <> value NoLog + <> help "log all states with pretty printing")) + +mkMaxOutputs :: Parser (Maybe Int) +mkMaxOutputs = + option (maybeReader (Just . readMaybe)) + ( long "max-outputs" + <> metavar "MAX" + <> value Nothing + <> help "the maximum number of input/output pairs to output") + +mkHigherOrder :: Parser HigherOrderSolver +mkHigherOrder = + option (eitherReader (\s -> case s of + "all" -> Right AllFuncs + "single" -> Right SingleFunc + "symbolic" -> Right SymbolicFunc + "symbolic-temp" -> Right SymbolicFuncTemplate + _ -> Left "Unsupported higher order function handling")) + ( long "higher-order" + <> metavar "HANDLING" + <> value SingleFunc + <> help "either all or single, to specify whether all possible higher order instantiations should be searched for, or just a single instantiation") + +mkSMTSolver :: Parser SMTSolver +mkSMTSolver = + option (eitherReader (\s -> case s of + "z3" -> Right ConZ3 + "cvc4" -> Right ConCVC4 + _ -> Left "Unsupported SMT solver")) + ( long "smt" + <> metavar "SMT-SOLVER" + <> value ConZ3 + <> help "either z3 or cvc4, to select the solver to use") + +mkSearchStrategy :: Parser SearchStrategy +mkSearchStrategy = + option (eitherReader (\s -> case s of + "iter" -> Right Iterative + "subpath" -> Right Subpath + _ -> Left "Unsupported search strategy")) + ( long "search" + <> metavar "SEARCH" + <> value Iterative + <> help "either iter or subpath, to select a search strategy") + +mkConfigDirect :: String -> [String] -> M.Map String [String] -> Config +mkConfigDirect homedir as m = Config { mode = Regular , baseInclude = baseIncludeDef (strArg "base" as m id homedir) , base = baseDef (strArg "base" as m id homedir) , extraDefaultInclude = extraDefaultIncludePaths (strArg "extra-base-inc" as m id homedir) - , extraDefaultMods = extraDefaultPaths (strArg "extra-base" as m id homedir) - , logStates = strArg "log-states" as m Just Nothing + , extraDefaultMods = [] + , logStates = strArg "log-states" as m (Log Raw) + (strArg "log-pretty" as m (Log Pretty) NoLog) + , sharing = boolArg' "sharing" as Sharing Sharing NoSharing + , maxOutputs = strArg "max-outputs" as m (Just . read) Nothing - , printCurrExpr = boolArg "print-ce" as m Off - , printExprEnv = boolArg "print-eenv" as m Off - , printPathCons = boolArg "print-pc" as m Off - , printRelExprEnv = boolArg "print-rel-eenv" as m Off , returnsTrue = boolArg "returns-true" as m Off , higherOrderSolver = strArg "higher-order" as m higherOrderSolArg SingleFunc + , search_strat = Iterative + , subpath_length = 4 , smt = strArg "smt" as m smtSolverArg ConZ3 , steps = strArg "n" as m read 1000 - , cut_off = strArg "cut-off" as m read 600 - , switch_after = strArg "switch-after" as m read 300 + , hpc = False , strict = boolArg "strict" as m On , timeLimit = strArg "time" as m read 300 , validate = boolArg "validate" as m Off - -- , baseLibs = [BasePrelude, BaseException] } baseIncludeDef :: FilePath -> [FilePath] baseIncludeDef root = [ root ++ "/.g2/base-4.9.1.0/Control/Exception/" - , root ++ "/.g2/base-4.9.1.0/" , root ++ "/.g2/base-4.9.1.0/" , root ++ "/.g2/base-4.9.1.0/Data/Internal/" ] baseDef :: FilePath -> [FilePath] -baseDef root = +baseDef root = baseSimple root + +baseSimple :: FilePath -> [FilePath] +baseSimple root = [ root ++ "/.g2/base-4.9.1.0/Control/Exception/Base.hs" , root ++ "/.g2/base-4.9.1.0/Prelude.hs" - , root ++ "/.g2/base-4.9.1.0/Control/Monad.hs" - , root ++ "/.g2/base-4.9.1.0/Data/Internal/Map.hs" - ] + , root ++ "/.g2/base-4.9.1.0/Control/Monad.hs" ] extraDefaultIncludePaths :: FilePath -> [FilePath] extraDefaultIncludePaths root = [ root ++ "/.g2/G2Stubs/src/" ] -extraDefaultPaths :: FilePath -> [FilePath] -extraDefaultPaths root = - [ root ++ "/.g2/G2Stubs/src/G2/QuasiQuotes/G2Rep.hs" ] - smtSolverArg :: String -> SMTSolver smtSolverArg = smtSolverArg' . map toLower @@ -142,6 +259,15 @@ Just st -> strToBool st d Nothing -> d +boolArg' :: String -> [String] -> b -> b -> b -> b +boolArg' s a b_default b1 b2 = + if "--" ++ s `elem` a + then b1 + else if "--no-" ++ s `elem` a + then b2 + else b_default + + strToBool :: [String] -> Bool -> Bool strToBool [s] b | s' == "true" = True @@ -167,16 +293,3 @@ strToArg :: [String] -> (String -> a) -> a -> a strToArg [s] f _ = f s strToArg _ _ d = d - -strArgs :: String -> [String] -> M.Map String [String] -> (String -> a) -> [a] -> [a] -strArgs s a m f d = - case elemIndex ("--" ++ s) a of - Just i -> if i >= length a - then error ("Invalid use of " ++ s) - else [f (a !! (i + 1))] - Nothing -> case M.lookup s m of - Just st -> strsToArgs st f - Nothing -> d - -strsToArgs :: [String] -> (String -> a) -> [a] -strsToArgs = flip map diff --git a/src/G2/Config/Interface.hs b/src/G2/Config/Interface.hs --- a/src/G2/Config/Interface.hs +++ b/src/G2/Config/Interface.hs @@ -1,32 +1,50 @@ module G2.Config.Interface where import G2.Config.Config -import G2.Config.ParseConfig -import qualified Data.Map as M +import qualified Data.Map.Lazy as M +import Data.Monoid ((<>)) +import Options.Applicative import System.Directory configName :: FilePath configName = "g2.cfg" -getConfig :: [String] -> IO Config -getConfig ars = do - let con = strArg "config" ars M.empty id configName - - ex <- configExists con +getConfigDirect :: IO Config +getConfigDirect = do + homedir <- getHomeDirectory + return $ mkConfigDirect homedir [] M.empty +getConfig :: IO (String, String, Maybe String, Maybe String, Config) +getConfig = do homedir <- getHomeDirectory - case ex of - True -> do - conf <- parseConfig con + execParser (mkConfigInfo homedir) - case conf of - Right conf' -> return (mkConfig homedir ars conf') - Left e -> do - putStrLn "Configuration file parsing error:" - print e - return (mkConfig homedir ars M.empty) - False -> return (mkConfig homedir ars M.empty) +mkConfigInfo :: String -> ParserInfo (String, String, Maybe String, Maybe String, Config) +mkConfigInfo homedir = + info (((,,,,) + <$> getFileName + <*> getFunctionName + <*> option (eitherReader (Right . Just)) + (long "assume" + <> metavar "F" + <> value Nothing + <> help "a function to use as an assumption") + <*> option (eitherReader (Right . Just)) + (long "assert" + <> metavar "F" + <> value Nothing + <> help "a function to use as an assertion") + <*> mkConfig homedir) <**> helper) + ( fullDesc + <> progDesc "Symbolic Execution of Haskell code" + <> header "The G2 Symbolic Execution Engine" ) + +getFileName :: Parser String +getFileName = argument str (metavar "FILE") + +getFunctionName :: Parser String +getFunctionName = argument str (metavar "FUNCTION") configExists :: FilePath -> IO Bool configExists cn = do diff --git a/src/G2/Data/Timer.hs b/src/G2/Data/Timer.hs new file mode 100644 --- /dev/null +++ b/src/G2/Data/Timer.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE FlexibleInstances #-} + +module G2.Data.Timer ( Timer + , TimerLog + , newTimer + , logEventStart + , logEventEnd + , getLog + + , runTimer + , logEventStartM + , logEventEndM + , getLogM + + , orderLogBySpeed + , sumLog + , mapLabels + , logToSecs ) where + +import Control.Monad.IO.Class +import Control.Monad.State.Lazy +import Data.Ord +import Data.List +import System.Clock + +type TimerLog label = [(label, TimeSpec)] + +data Timer label = + Timer { timer_log :: TimerLog label -- ^ Labelled events with time measurements (in picoseconds) + , for_next :: Maybe (label, TimeSpec) -- ^ What is the next label, and when did we start timing? + } + +newTimer :: IO (Timer label) +newTimer = do + return $ Timer { timer_log = [] + , for_next = Nothing } + +logEventStart :: label -> Timer label -> IO (Timer label) +logEventStart label timer = do + curr <- getTime Realtime + return $ logEventStart' label curr timer + +logEventStart' :: label -> TimeSpec -> Timer label -> Timer label +logEventStart' label curr timer@( Timer { for_next = Nothing }) = + timer { for_next = Just (label, curr) } +logEventStart' _ _ _ = error "Timer started before ending" + +logEventEnd :: Timer label -> IO (Timer label) +logEventEnd timer = do + curr <- getTime Realtime + return $ logEventEnd' curr timer + +logEventEnd' :: TimeSpec -> Timer label -> Timer label +logEventEnd' curr (Timer { timer_log = lg, for_next = Just (label, lst) }) = + Timer { timer_log = (label, curr - lst):lg + , for_next = Nothing } +logEventEnd' _ _ = error "Timer ended but never started" + +getLog :: Timer label -> TimerLog label +getLog = timer_log + +runTimer :: StateT (Timer label) m a -> Timer label -> m (a, Timer label) +runTimer = runStateT + +logEventStartM :: MonadIO m => label -> StateT (Timer label) m () +logEventStartM n = do + curr <- liftIO $ getTime Realtime + modify' (logEventStart' n curr) + +logEventEndM :: MonadIO m => StateT (Timer label) m () +logEventEndM = do + curr <- liftIO $ getTime Realtime + modify' (logEventEnd' curr) + +getLogM :: Monad m => StateT (Timer label) m (TimerLog label) +getLogM = gets getLog + +-- Working with the generated logs +orderLogBySpeed :: TimerLog label -> TimerLog label +orderLogBySpeed = reverse . sortBy (comparing snd) + +sumLog :: Eq label => TimerLog label -> TimerLog label +sumLog tl = + let + labs = nub $ map fst tl + grped = map (sum . map snd) + $ map (\l -> filter (\(l', _) -> l == l') tl) labs + in + zip labs grped + +mapLabels :: (label1 -> label2) -> TimerLog label1 -> TimerLog label2 +mapLabels f = map (\(l, i) -> (f l, i)) + +logToSecs :: TimerLog label -> [(label, Double)] +logToSecs = map (\(l, s) -> (l, fromInteger (toNanoSecs s) / (10 ^ (9 :: Int) :: Double))) diff --git a/src/G2/Data/UFMap.hs b/src/G2/Data/UFMap.hs new file mode 100644 --- /dev/null +++ b/src/G2/Data/UFMap.hs @@ -0,0 +1,288 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TupleSections #-} + +module G2.Data.UFMap ( UFMap + , empty + , toList + , fromList + , toSet + , fromSet + , toSimpleMap + , join + , joinAll + , lookup + , lookupWithRep + , (!) + , find + , insert + , insertWith + , adjust + , alter + , clear + , filterWithKey + + , unionWith + , mergeJoiningWithKey + + , map + + , null + , keys + , joinedKeys + , elems + , member) where + +import qualified G2.Data.UnionFind as UF + +import Control.Exception +import qualified Control.Monad as Mon + +import Data.Data (Data (..), Typeable) +import Data.Hashable +import qualified Data.HashMap.Lazy as M +import qualified Data.HashSet as S +import qualified Data.List as L +import Data.Maybe + +import Prelude hiding (lookup, null, map) +import qualified Prelude as P + +import Text.Read +import qualified Text.Read.Lex as L +import GHC.Read + +import GHC.Generics (Generic) + +import Test.Tasty.QuickCheck + +-- | A map allowing inserts and lookups via keys, and for sets of keys to be +-- unioned so that all keys in the set point to the same element. +-- Keys @k1@ and @k2@ may be unioned regardless of whether both are already in the `UFMap`. +-- If @k1@ and @k2@ are unioned without either being in the `UFMap`, and then a value +-- for either is inserted, the other will also then point to that value. +data UFMap k v = UFMap { joined :: UF.UnionFind k + , store :: M.HashMap k v } + deriving (Typeable, Data, Generic) + +instance (Eq k, Hashable k, Hashable v) => Hashable (UFMap k v) + +-- | An empty `UFMap`. +empty :: UFMap k v +empty = UFMap UF.empty M.empty + +-- | Convert a @`UFMap` k v@ to a list. Each tuple in the list contains a list of +-- unioned keys, alongside a @`Maybe` v@. If the keys were pointing to a value +-- @v@ in the Map, this is @`Just` v@, otherwise it is `Nothing`. +toList :: (Eq k, Hashable k) => UFMap k v -> [([k], Maybe v)] +toList uf = + let + uf_l = UF.toList $ joined uf + + c_uf_l = concat uf_l + not_acc = P.map (:[]) $ keys uf L.\\ c_uf_l + in + P.map (\l -> (l, lookup (head l) uf)) $ uf_l ++ not_acc + +toSet :: (Eq k, Eq v, Hashable k, Hashable v) => UFMap k v -> S.HashSet (S.HashSet k, Maybe v) +toSet = S.fromList . P.map (\(ks, v) -> (S.fromList ks, v)) . toList + +fromList :: (Eq k, Hashable k) => [([k], Maybe v)] -> UFMap k v +fromList xs = + let + xs_j = concatMap (\(ks, v) -> case v of + Just v' -> P.map (\k -> (k, v')) ks + Nothing -> [] ) xs + m = foldr (uncurry insert) empty xs_j + in + foldr (\(ks, _) m' -> + case ks of + [] -> m' + (k:_) -> foldr (\k' -> join const k k') m' ks) + m xs + +fromSet :: (Eq k, Hashable k) => S.HashSet (S.HashSet k, Maybe v) -> UFMap k v +fromSet = fromList . P.map (\(ks, v) -> (S.toList ks, v)) . S.toList + +toSimpleMap :: UFMap k v -> M.HashMap k v +toSimpleMap = store + +-- | Joins two keys, regardless of whether they are present in the map. +-- If the keys are already joined, the map is not changed +join :: (Eq k, Hashable k) => (v -> v -> v) -> k -> k -> UFMap k v -> UFMap k v +join f k1 k2 ufm@(UFMap uf m) + | UF.find k1 uf == UF.find k2 uf = ufm + | otherwise = + let + (r1, v1) = lookupWithRep k1 ufm + (r2, v2) = lookupWithRep k2 ufm + + uf' = UF.union k1 k2 uf + r = UF.find k1 uf' + + m' = M.delete r1 . M.delete r2 $ m + + m'' = case (v1, v2) of + (Just v1', Just v2') -> M.insert r (f v1' v2') m' + (Just v1', _) -> M.insert r v1' m' + (_, Just v2') -> M.insert r v2' m' + _ -> m + in + assert (isNothing (M.lookup k1 m'') || isNothing (M.lookup k2 m'')) + UFMap uf' m'' + +joinAll :: (Eq k, Hashable k) => (v -> v -> v) -> [k] -> UFMap k v -> UFMap k v +joinAll _ [] uf = uf +joinAll f xs@(x:_) uf = foldr (join f x) uf xs + +-- | Lookup the value at a key in the `UFMap`. +-- Returns the corresponding @`Just` v@, or `Nothing` if the key isn't in the map. +lookup :: (Eq k, Hashable k) => k -> UFMap k v -> Maybe v +lookup k = snd . lookupWithRep k + +-- | Lookup the value at a key in the `UFMap`, as well as the representative of the key. +-- Returns the corresponding value as @`Just` v@, or `Nothing` if the key isn't in the map. +lookupWithRep :: (Eq k, Hashable k) => k -> UFMap k v -> (k, Maybe v) +lookupWithRep k (UFMap uf m) = + let r = UF.find k uf in + (r, M.lookup r m) + +-- | Find the representative of the key in the `UFMap`. +find :: (Eq k, Hashable k) => k -> UFMap k v -> k +find k = UF.find k . joined + +-- | Lookup the value at a key in the `UFMap`. +-- The function will call error if the key isn't in the map. +(!) :: (Eq k, Hashable k) => UFMap k v -> k -> v +uf ! k = case lookup k uf of + Just v -> v + Nothing -> error "!: key not found" + +-- | Adds a key-value pair to the `UFMap`. +-- If the key is already in the map, it's value is overwritten. +insert :: (Eq k, Hashable k) => k -> v -> UFMap k v -> UFMap k v +insert k v (UFMap uf m) = + let + m' = M.insert (UF.find k uf) v m + in + assert (UF.find k uf == k || isNothing (M.lookup k m')) + UFMap uf m' + +insertWith :: (Eq k, Hashable k) => (v -> v -> v) -> k -> v -> UFMap k v -> UFMap k v +insertWith f k v (UFMap uf m) = UFMap uf $ M.insertWith f (UF.find k uf) v m + +adjust :: (Eq k, Hashable k) => (v -> v) -> k -> UFMap k v -> UFMap k v +adjust f k (UFMap uf m) = UFMap uf $ M.adjust f (UF.find k uf) m + +alter :: (Eq k, Hashable k) => (Maybe v -> Maybe v) -> k -> UFMap k v -> UFMap k v +alter f k (UFMap uf m) = UFMap uf $ M.alter f (UF.find k uf) m + +-- | Preserves the joined keys, but deletes all contained elements +clear :: UFMap k v -> UFMap k v +clear (UFMap uf _) = UFMap uf M.empty + +filterWithKey :: (k -> v -> Bool) -> UFMap k v -> UFMap k v +filterWithKey p (UFMap uf m) = UFMap uf $ M.filterWithKey p m + +unionWith :: (Eq k, Hashable k) => (v -> v -> v) -> UFMap k v -> UFMap k v -> UFMap k v +unionWith f ufm1 (UFMap uf2 m2) = + let + ufm1' = foldr (joinAll f) ufm1 (UF.toList uf2) + in + M.foldrWithKey (insertWith f) ufm1' m2 + +-- One key (from the joined set of keys) is given +mergeJoiningWithKey :: (Eq k, Hashable k, Show k, Show v, Show v1, Show v2) + => (k -> v1 -> v2 -> (v, [(k, k)])) -- ^ How to merge values that are joined from both maps + -> (k -> v1 -> (v, [(k, k)])) -- ^ How to merge values of keys only in the first map + -> (k -> v2 -> (v, [(k, k)])) -- ^ How to merge values of keys only in the second map + -> (v1 -> v1 -> v1) -- ^ How to merge values that are joined within the first map + -> (v2 -> v2 -> v2) -- ^ How to merge values that are joined within the second map + -> (v -> v -> v) -- ^ Final extra joins, generated by prior higher order functions + -> UFMap k v1 + -> UFMap k v2 + -> UFMap k v +mergeJoiningWithKey fb f1 f2 fj1 fj2 j (UFMap uf1 m1) (UFMap uf2 m2) = + let + j_uf = UF.unionOfUFs uf1 uf2 + + -- We build a map where the keys are the values of j_f, and the values have type (Maybe v1, Maybe v2) + j_m1 = foldr (\(k, v) m -> + let uf_k = UF.find k j_uf in + case M.lookup uf_k m of + Nothing -> M.insert uf_k (Just v, Nothing) m + Just (Nothing, _) -> M.insert uf_k (Just v, Nothing) m + Just (Just v1, v2) -> M.insert uf_k (Just $ fj1 v v1, v2) m + ) M.empty (M.toList m1) + j_m2 = foldr (\(k, v) m -> + let uf_k = UF.find k j_uf in + case M.lookup uf_k m of + Nothing -> M.insert uf_k (Nothing, Just v) m + Just (v1, Nothing) -> M.insert uf_k (v1, Just v) m + Just (v1, Just v2) -> M.insert uf_k (v1, Just $ fj2 v v2) m + ) j_m1 (M.toList m2) + + j_m = M.mapWithKey (\k (v1, v2) -> case (v1, v2) of + (Just v1', Just v2') -> fb k v1' v2' + (Just v1', Nothing) -> f1 k v1' + (Nothing, Just v2') -> f2 k v2' + _ -> error "merge: impossible state!") j_m2 + + ks = concat . M.elems $ M.map snd j_m + + n_ufm = UFMap j_uf $ M.map fst j_m + n_ufm' = foldr (uncurry (join j)) n_ufm ks + in + n_ufm' + +map :: (v1 -> v2) -> UFMap k v1 -> UFMap k v2 +map f uf = uf { store = M.map f $ store uf } + +null :: UFMap k v -> Bool +null = M.null . store + +keys :: (Eq k, Hashable k) => UFMap k v -> [k] +keys = S.toList . keysSet + +keysSet :: (Eq k, Hashable k) => UFMap k v -> S.HashSet k +keysSet uf = + (foldr S.union S.empty . UF.toSet . joined $ uf) `S.union` (M.keysSet . store $ uf) + +joinedKeys :: UFMap k v -> UF.UnionFind k +joinedKeys = joined + +elems :: UFMap k v -> [v] +elems = M.elems . store + +member :: (Eq k, Hashable k) => k -> UFMap k v -> Bool +member k = M.member k . store + +instance (Eq k, Eq v, Hashable k, Hashable v) => Eq (UFMap k v) where + x == y = toSet x == toSet y + +instance (Eq k, Hashable k, Show k, Show v) => Show (UFMap k v) where + show uf = "fromList " ++ show (toList uf) + + +instance (Eq k, Hashable k, Read k, Read v) => Read (UFMap k v) where + readPrec = parens $ + do expectP (L.Ident "fromList") + x <- step readListPrec + return (fromList x) + readListPrec = readListPrecDefault + +instance (Arbitrary k, Arbitrary v, Eq k, Hashable k) => Arbitrary (UFMap k v) where + arbitrary = do + ufsz <- arbitrary + jnum <- arbitrary + ks <- Mon.replicateM ufsz arbitrary + vs <- Mon.replicateM ufsz arbitrary + js <- Mon.replicateM jnum arbitrary + + let uf = foldr (uncurry insert) empty (zip ks vs) + ufm = foldr (uncurry (join const)) uf js + + return ufm + + shrink = P.map fromList . shrink . toList + -- shrink = P.map (fromList . filter (not . P.null . fst)) . shrink . toList diff --git a/src/G2/Data/UnionFind.hs b/src/G2/Data/UnionFind.hs new file mode 100644 --- /dev/null +++ b/src/G2/Data/UnionFind.hs @@ -0,0 +1,168 @@ +-- | A union-find data structure. +-- Based on: +-- +-- A Persistent Union-Find Data Structure +-- +-- by Sylvain Conchon and Jean-Cristophe Filliatre + +{-# OPTIONS_GHC -fno-warn-orphans -fno-full-laziness #-} + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE InstanceSigs #-} + +module G2.Data.UnionFind ( UnionFind + , empty + , fromList + , toList + , toSet + , union + , unionOfUFs + , find) where + +import Data.Data (Data (..), Typeable) +import Data.Hashable +import qualified Data.HashMap.Lazy as M +import qualified Data.HashSet as S +import Data.IORef +import Data.Semigroup (Semigroup (..)) + +import System.IO.Unsafe + +import Text.Read +import qualified Text.Read.Lex as L +import GHC.Read + +import Test.Tasty.QuickCheck + +data UnionFind k = UF { rank :: M.HashMap k Int + , parent :: IORef (M.HashMap k k) } + deriving (Typeable, Data) + +{-# NOINLINE empty #-} +-- | A `UnionFind` with nothing unioned. +empty :: UnionFind k +empty = UF { rank = M.empty + , parent = unsafePerformIO $ newIORef M.empty } + +-- | Build a UnionFind uf, where if k1, k2 are in the same input list, +-- find k1 uf == find k2 uf +fromList :: (Eq k, Hashable k) => [[k]] -> UnionFind k +fromList = foldr unions empty + +unions :: (Eq k, Hashable k) => [k] -> UnionFind k -> UnionFind k +unions ks uf = foldr (uncurry union) uf prod + where prod = [(k1, k2) | k1 <- ks, k2 <- ks] + +-- | Convert a `UnionFind` into a list of lists. +-- Elements in the same list in the returned list were unioned in the `UnionFind`. +toList :: (Eq k, Hashable k) => UnionFind k -> [[k]] +toList = map S.toList . S.toList . toSet + +-- | Convert a `UnionFind` into a `S.HashSet` of `S.HashSet`s. +-- Elements in the same `S.HashSet` in the returned `S.HashSet` were unioned in the `UnionFind`. +toSet :: (Eq k, Hashable k) => UnionFind k -> S.HashSet (S.HashSet k) +toSet uf = + let + par = unsafePerformIO $ readIORef (parent uf) + m = foldr (\k -> M.insertWith S.union (find k uf) $ S.singleton k) M.empty (M.keys par) + in + S.fromList . map (\(k, v) -> S.insert k v) $ M.toList m + +{-# NOINLINE union #-} +-- | @`union` k1 k2 uf@ unions the keys @k1@ and @k2@ in @uf@. +union :: (Eq k, Hashable k) => k -> k -> UnionFind k -> UnionFind k +union x y h = + let + cx = find x h + cy = find y h + in + if cx /= cy + then + let + rx = M.lookupDefault 0 cx (rank h) + ry = M.lookupDefault 0 cy (rank h) + in + if rx > ry + then unsafePerformIO $ do + par_h <- readIORef (parent h) + par_h' <- newIORef (M.insert cy cx par_h) + return $ h { parent = par_h' } + else if rx < ry + then unsafePerformIO $ do + par_h <- readIORef (parent h) + par_h' <- newIORef (M.insert cx cy par_h) + return $ h { parent = par_h' } + else unsafePerformIO $ do + par_h <- readIORef (parent h) + par_h' <- newIORef (M.insert cy cx par_h) + return $ h { rank = M.insert cx (rx + 1) (rank h) + , parent = par_h' } + else h + +-- | Take the union of two `UnionFind`s, by taking the union of any overlapping sets. +{-# NOINLINE unionOfUFs #-} +unionOfUFs :: (Eq k, Hashable k) => UnionFind k -> UnionFind k -> UnionFind k +unionOfUFs uf1 (UF { parent = par }) = unsafePerformIO $ do + par' <- readIORef par + return $ M.foldrWithKey union uf1 par' + +{-# NOINLINE find #-} +-- | @`find` k uf@ returns the representative of @k@ in @uf@. +find :: (Eq k, Hashable k) => k -> UnionFind k -> k +find x h = + unsafePerformIO (do + h_par <- readIORef (parent h) + let (cx, f) = findAux x h_par + atomicWriteIORef (parent h) f + return cx + ) + +findAux :: (Eq k, Hashable k) => k -> M.HashMap k k -> (k, M.HashMap k k) +findAux i f = + let fi = M.lookupDefault i i f in + if fi == i + then (i, f) + else + let + (r, f') = findAux fi f + f'' = M.insert i r f' + in + (r, f'') + +instance (Eq k, Hashable k) => Eq (UnionFind k) where + x == y = toSet x == toSet y + +instance (Eq k, Hashable k, Show k) => Show (UnionFind k) where + {-# NOINLINE show #-} + show uf = "fromList " ++ show (toList uf) + +instance (Eq k, Hashable k, Read k) => Read (UnionFind k) where + readPrec = parens $ + do expectP (L.Ident "fromList") + x <- step readListPrec + return (fromList x) + readListPrec = readListPrecDefault + +instance (Eq k, Hashable k) => Hashable (UnionFind k) where + hashWithSalt i = hashWithSalt i . toList + +instance (Eq k, Hashable k) => Semigroup (UnionFind k) where + (<>) = unionOfUFs + +instance (Eq k, Hashable k) => Monoid (UnionFind k) where + mempty = empty + +instance (Arbitrary k, Eq k, Hashable k) => Arbitrary (UnionFind k) where + arbitrary :: (Arbitrary k, Eq k, Hashable k) => Gen (UnionFind k) + arbitrary = do + ks <- arbitrary + + return $ fromList ks + + shrink = map fromList . shrink . toList + +-- Hack for compilation +instance Typeable a => Data (IORef a) where + toConstr _ = error "toConstr" + gunfold _ _ = error "gunfold" + dataTypeOf _ = error "dataTypeOf" diff --git a/src/G2/Data/Utils.hs b/src/G2/Data/Utils.hs new file mode 100644 --- /dev/null +++ b/src/G2/Data/Utils.hs @@ -0,0 +1,25 @@ +module G2.Data.Utils ( uncurry3 + , uncurry4 + + , fst4 + , snd4 + , thd4 + , fth4) where + +uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d +uncurry3 f (a, b, c) = f a b c + +uncurry4 :: (a -> b -> c -> d -> e) -> ((a, b, c, d) -> e) +uncurry4 f (a,b,c,d) = f a b c d + +fst4 :: (a, b, c, d) -> a +fst4 (a, _, _, _) = a + +snd4 :: (a, b, c, d) -> b +snd4 (_, b, _, _) = b + +thd4 :: (a, b, c, d) -> c +thd4 (_, _, c, _) = c + +fth4 :: (a, b, c, d) -> d +fth4 (_, _, _, d) = d diff --git a/src/G2/Equiv/Approximation.hs b/src/G2/Equiv/Approximation.hs new file mode 100644 --- /dev/null +++ b/src/G2/Equiv/Approximation.hs @@ -0,0 +1,125 @@ +module G2.Equiv.Approximation where + +import G2.Equiv.Types +import G2.Language +import qualified G2.Language.Approximation as A +import qualified G2.Language.ExprEnv as E + +import qualified Data.HashSet as HS +import qualified Data.HashMap.Lazy as HM +import Data.List +import Data.Maybe + +moreRestrictive :: StateET + -> StateET + -> HS.HashSet Name + -> (HM.HashMap Id Expr, HS.HashSet (Expr, Expr)) + -> Either [Lemma] (HM.HashMap Id Expr, HS.HashSet (Expr, Expr)) +moreRestrictive s1 s2 = + let + lkp n s = lookupConcOrSymBoth n (expr_env s) (opp_env $ track s) + in + A.moreRestrictive moreRestrictiveCont generateLemma lkp s1 s2 + +moreRestrictiveCont :: StateET + -> StateET + -> HS.HashSet Name + -> (HM.HashMap Id Expr, HS.HashSet (Expr, Expr)) + -> Bool -- ^ indicates whether this is part of the "active expression" + -> [(Name, Expr)] -- ^ variables inlined previously on the LHS + -> [(Name, Expr)] -- ^ variables inlined previously on the RHS + -> Expr + -> Expr + -> Either [Lemma] (HM.HashMap Id Expr, HS.HashSet (Expr, Expr)) +moreRestrictiveCont s1 s2 ns hm active n1 n2 e1 e2 = + let + lkp n s = lookupConcOrSymBoth n (expr_env s) (opp_env $ track s) + in + case (e1, e2) of + (Tick t1 e1', Tick t2 e2') | labeledErrorName t1 == labeledErrorName t2 -> + A.moreRestrictive' moreRestrictiveCont generateLemma lkp s1 s2 ns hm active n1 n2 e1' e2' + (Tick t e1', _) | isNothing $ labeledErrorName t -> + A.moreRestrictive' moreRestrictiveCont generateLemma lkp s1 s2 ns hm active n1 n2 e1' e2 + (_, Tick t e2') | isNothing $ labeledErrorName t -> + A.moreRestrictive' moreRestrictiveCont generateLemma lkp s1 s2 ns hm active n1 n2 e1 e2' + _ -> Left [] + +-- When we make the two sides for a new lemma, if the two expressions +-- contain any variables that aren't present in the expression environment, +-- we add them to the expression environment as non-total symbolic +-- variables. This can happen if an expression for a lemma is a +-- sub-expression of a Case branch, a Let statement, or a lambda expression +-- body. It is possible that we may lose information about the variables +-- because of these insertions, but this cannot lead to spurious +-- counterexamples because these insertions apply only to lemmas and lemmas +-- are not used for counterexample generation. +generateLemma :: A.GenerateLemma EquivTracker Lemma +generateLemma s1 s2@(State {expr_env = h2}) hm e1 e2 = + let + h2' = opp_env $ track s2 + + v_rep = HM.toList $ fst hm + e1' = replaceVars e1 v_rep + cs (E.Conc e_) = E.Conc e_ + cs (E.Sym i_) = case E.lookupConcOrSym (idName i_) h2' of + Nothing -> E.Sym i_ + Just c -> c + h2_ = envMerge (E.mapConcOrSym cs h2) h2' + h2_' = E.mapConc (flip replaceVars v_rep) h2_ + et' = (track s2) { opp_env = E.empty } + ids1 = varIds e1' + ids1' = filter (\(Id n _) -> not $ E.member n h2_') ids1 + ids2 = varIds e2 + ids2' = filter (\(Id n _) -> not $ E.member n h2_) ids2 + ids_both = nub $ ids1' ++ ids2' + h_lem1 = foldr E.insertSymbolic h2_' ids_both + h_lem2 = foldr E.insertSymbolic h2_ ids_both + ls1 = s2 { expr_env = h_lem1, curr_expr = CurrExpr Evaluate e1', track = et' } + ls2 = s2 { expr_env = h_lem2, curr_expr = CurrExpr Evaluate e2, track = et' } + in + mkProposedLemma "lemma" s1 s2 ls2 ls1 + +replaceVars :: Expr -> [(Id, Expr)] -> Expr +replaceVars = foldr (\(Id n _, e) -> replaceVar n e) + +mkProposedLemma :: String + -> StateET + -> StateET + -> StateET + -> StateET + -> ProposedLemma +mkProposedLemma lm_name or_s1 or_s2 s1 s2 = + let h1 = expr_env s1 + h2 = expr_env s2 + cs _ (E.Conc e) = E.Conc e + cs h (E.Sym i) = case E.lookupConcOrSym (idName i) h of + Nothing -> E.Sym i + Just c -> c + h1' = E.mapConcOrSym (cs h2) h1 + h2' = E.mapConcOrSym (cs h1) h2 + f (E.SymbObj _) e2 = e2 + f e1 _ = e1 + h1'' = E.unionWith f h1' h2' + h2'' = E.unionWith f h2' h1' + s1' = s1 { expr_env = h1'' } + s2' = s2 { expr_env = h2'' } + in + Lemma { lemma_name = lm_name + , lemma_lhs = s1' + , lemma_rhs = s2' + , lemma_lhs_origin = folder_name . track $ or_s1 + , lemma_rhs_origin = folder_name . track $ or_s2 + , lemma_to_be_proven =[(newStateH s1', newStateH s2')] } + +syncEnvs :: StateET -> StateET -> (StateET, StateET) +syncEnvs s1 s2 = + let h1 = envMerge (expr_env s1) (expr_env s2) + h2 = envMerge (expr_env s2) (expr_env s1) + in (s1 { expr_env = h1 }, s2 { expr_env = h2 }) + +-- the left one takes precedence +envMerge :: ExprEnv -> ExprEnv -> ExprEnv +envMerge env h = + let f (E.SymbObj _) e2 = e2 + f e1 _ = e1 + in E.unionWith f env h diff --git a/src/G2/Equiv/Config.hs b/src/G2/Equiv/Config.hs new file mode 100644 --- /dev/null +++ b/src/G2/Equiv/Config.hs @@ -0,0 +1,107 @@ +module G2.Equiv.Config ( NebulaConfig (..) + , SummaryMode (..) + , UseLabeledErrors (..) + , getNebulaConfig + , getNebulaConfigPlugin + , mkNebulaConfigInfo + , mkNebulaConfig) where + +import G2.Config.Config + +import Data.Monoid ((<>)) +import qualified Data.Text as T +import Options.Applicative +import Text.Read + +-- Config options +data NebulaConfig = NC { limit :: Int + , num_lemmas :: Int + , print_summary :: SummaryMode + , use_labeled_errors :: UseLabeledErrors + , log_states :: LogMode -- ^ Determines whether to Log states, and if logging states, how to do so. + , log_rule :: Maybe String -- ^ Allow user to log the states for specific rule. + , sync :: Bool + , symbolic_unmapped :: Bool} + +data SummaryMode = SM { have_summary :: Bool + , have_history :: Bool + , have_lemma_details :: Bool } + +noSummary :: SummaryMode +noSummary = SM False False False + +data UseLabeledErrors = UseLabeledErrors | NoLabeledErrors deriving (Eq, Show, Read) + +getNebulaConfig :: IO (String, String, [T.Text], NebulaConfig) +getNebulaConfig = execParser mkNebulaConfigInfo + +getNebulaConfigPlugin :: [String] -> ParserResult (Maybe String, NebulaConfig) +getNebulaConfigPlugin = + execParserPure defaultPrefs $ + info (((,) <$> maybeGetRuleName <*> mkNebulaConfig) <**> helper) + ( fullDesc + <> progDesc "Equivalence Checking for Haskell Rewrite Rules" + <> header "The Nebula Equivalence Checker" ) + +mkNebulaConfigInfo :: ParserInfo (String, String, [T.Text], NebulaConfig) +mkNebulaConfigInfo = + info (((,,,) <$> getFileName <*> getRuleName <*> getTotal <*> mkNebulaConfig) <**> helper) + ( fullDesc + <> progDesc "Equivalence Checking for Haskell Rewrite Rules" + <> header "The Nebula Equivalence Checker" ) + +getFileName :: Parser String +getFileName = argument str (metavar "FILE") + +getRuleName :: Parser String +getRuleName = argument str (metavar "RULE") + +maybeGetRuleName :: Parser (Maybe String) +maybeGetRuleName = + argument (maybeReader (Just . Just)) (metavar "RULE" <> value Nothing) + +getTotal :: Parser [T.Text] +getTotal = many (argument (maybeReader (Just . T.pack)) (metavar "TOTAL")) + +mkNebulaConfig :: Parser NebulaConfig +mkNebulaConfig = NC + <$> option auto (long "limit" + <> metavar "N" + <> value (-1) + <> help "how many iterations the equivalence checker should go through before giving up") + <*> option auto (long "num_lemmas" + <> metavar "L" + <> value 2 + <> help "how many lemmas can be applied to an expression simultaneously") + <*> mkSummaryMode + <*> flag UseLabeledErrors NoLabeledErrors (long "no-labeled-errors" <> help "disable labeled errors, treating all errors as equivalent") + <*> mkLogMode + <*> mkLogRule + <*> flag False True (long "sync" <> help "sync the left and right expressions prior to symbolic execution") + <*> flag True False (long "sym-unmapped" <> help "automatically treat unmapped function as symbolic") + +mkLogRule :: Parser (Maybe String) +mkLogRule = + option (maybeReader (Just . Just)) + ( long "log-rule" + <> metavar "RULE" + <> value Nothing + <> help "Output states for this rule when logging") + +mkSummaryMode :: Parser SummaryMode +mkSummaryMode = + (flag noSummary (SM True False False) + (long "summarize" + <> help "provide a summary with no history")) + <|> + (flag noSummary (SM True True False) + (long "hist-summarize" + <> help "provide a summary with history")) + <|> + (flag noSummary (SM True False True) + (long "lemmas-summarize" + <> help "provide a summary with all lemma results")) + <|> + (flag noSummary (SM True True True) + (long "lemmas-hist-summarize" + <> help "provide a summary with history and lemma results")) diff --git a/src/G2/Equiv/EquivADT.hs b/src/G2/Equiv/EquivADT.hs new file mode 100644 --- /dev/null +++ b/src/G2/Equiv/EquivADT.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} + +module G2.Equiv.EquivADT ( + proofObligations + , Obligation (..) + , unAppNoTicks + ) where + +import G2.Language +import qualified G2.Language.ExprEnv as E +import qualified G2.Language.Typing as T +import qualified Data.HashSet as HS + +import G2.Execution.NormalForms +import G2.Equiv.G2Calls + +import GHC.Generics (Generic) +import Data.Data +import Data.Hashable +import Data.Maybe + +-- The information that comes before the Expr pair is used for checking +-- the validity of guarded coinduction and also for counterexample +-- summarization in the event of a SAT output. +-- earlier DataCons in the list are farther out +-- the first Int tag indicates which argument of the constructor this was +-- the second one indicates the total number of arguments for that constructor +-- if there are lambdas, we handle them in Verifier +data Obligation = Ob [(DataCon, Int, Int)] Expr Expr + deriving (Show, Eq, Read, Generic, Typeable, Data) + +instance Hashable Obligation + +proofObligations :: HS.HashSet Name + -> State t + -> State t + -> Expr + -> Expr + -> Maybe (HS.HashSet Obligation) +proofObligations ns s1 s2 e1 e2 = + exprPairing ns s1 s2 e1 e2 HS.empty [] [] + +removeTicks :: Expr -> Expr +removeTicks (Tick _ e) = removeTicks e +removeTicks e = e + +removeAllTicks :: Expr -> Expr +removeAllTicks = modifyASTs removeTicks + +unAppNoTicks :: Expr -> [Expr] +unAppNoTicks e = + let e_list = unApp e + in case e_list of + e':t -> (removeTicks e'):t + _ -> e_list + +exprPairing :: HS.HashSet Name -- ^ vars that should not be inlined on either side + -> State t + -> State t + -> Expr + -> Expr + -> HS.HashSet Obligation -- ^ accumulator for output obligations + -> [Name] -- ^ variables inlined previously on the LHS + -> [Name] -- ^ variables inlined previously on the RHS + -> Maybe (HS.HashSet Obligation) +exprPairing ns s1@(State {expr_env = h1}) s2@(State {expr_env = h2}) e1 e2 pairs n1 n2 = + case (e1, e2) of + _ | e1 == e2 -> Just pairs + -- ignore all Ticks + (Tick t1 e1', Tick t2 e2') | labeledErrorName t1 == labeledErrorName t2 -> exprPairing ns s1 s2 e1' e2' pairs n1 n2 + (Tick t e1', _) | isNothing $ labeledErrorName t -> exprPairing ns s1 s2 e1' e2 pairs n1 n2 + (_, Tick t e2') | isNothing $ labeledErrorName t -> exprPairing ns s1 s2 e1 e2' pairs n1 n2 + -- catch mismatches between labeled errors and other SWHNF expressions + (Tick _ _, _) | isExprValueForm h2 (removeAllTicks e2) -> Nothing + (_, Tick _ _) | isExprValueForm h1 (removeAllTicks e1) -> Nothing + -- We have two error labels that are different from each other + (Tick _ _, Tick _ _) -> Nothing + -- keeping track of inlined vars prevents looping + (Var i1, Var i2) | (idName i1) `elem` n1 + , (idName i2) `elem` n2 -> Just $ HS.insert (Ob [] e1 e2) pairs + -- reject distinct polymorphic variables as inequivalent + -- this works for function variables too + | E.isSymbolic (idName i1) h1 + , E.isSymbolic (idName i2) h2 + , idName i1 /= idName i2 + , not (concretizable $ T.typeOf e1) -> Nothing + (Var i, _) | E.isSymbolic (idName i) h1 -> Just $ HS.insert (Ob [] e1 e2) pairs + | m <- idName i + , not $ m `elem` ns + , Just e <- E.lookup m h1 -> exprPairing ns s1 s2 e e2 pairs (m:n1) n2 + | not $ (idName i) `elem` ns -> error "unmapped variable" + (_, Var i) | E.isSymbolic (idName i) h2 -> Just $ HS.insert (Ob [] e1 e2) pairs + | m <- idName i + , not $ m `elem` ns + , Just e <- E.lookup m h2 -> exprPairing ns s1 s2 e1 e pairs n1 (m:n2) + | not $ (idName i) `elem` ns -> error $ "unmapped variable" ++ show (idName i) + (Prim p1 _, Prim p2 _) | p1 == Error || p1 == Undefined + , p2 == Error || p2 == Undefined -> Just pairs + -- extra cases for avoiding Error problems + (Prim p _, _) | (p == Error || p == Undefined) + , isExprValueForm h2 (removeAllTicks e2) -> Nothing + (_, Prim p _) | (p == Error || p == Undefined) + , isExprValueForm h1 (removeAllTicks e1) -> Nothing + (Lit l1, Lit l2) | l1 == l2 -> Just pairs + | otherwise -> Nothing + -- assume that all types line up between the two expressions + (Type _, Type _) -> Just pairs + -- See note in `moreRestrictive` regarding comparing DataCons + _ + | (Data d@(DataCon d1 _)):l1 <- unAppNoTicks e1 + , (Data (DataCon d2 _)):l2 <- unAppNoTicks e2 -> + if d1 == d2 then + let ep = uncurry (exprPairing ns s1 s2) + ep' hs p = ep p hs n1 n2 + l = zip l1 l2 + extend i (Ob ds e1_ e2_) = Ob ((d, i, length l):ds) e1_ e2_ + make_exts (i, l_pair) = case ep' HS.empty l_pair of + Nothing -> Nothing + Just hs -> Just $ map (extend i) $ HS.toList hs + hl = map make_exts $ zip [0..] l + in + if any isNothing hl + then Nothing + else Just $ HS.union pairs $ HS.fromList $ concat (map fromJust hl) + else Nothing + | otherwise -> Just $ HS.insert (Ob [] e1 e2) pairs diff --git a/src/G2/Equiv/G2Calls.hs b/src/G2/Equiv/G2Calls.hs new file mode 100644 --- /dev/null +++ b/src/G2/Equiv/G2Calls.hs @@ -0,0 +1,504 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveGeneric #-} + +module G2.Equiv.G2Calls ( StateET + , EquivTracker (..) + , BlockInfo (..) + , emptyEquivTracker + , runG2ForNebula + , totalExpr + , argCount + , concretizable + + , isLabeledErrorName + , labeledErrorName + , isLabeledError + + , lookupBoth + , lookupConcOrSymBoth + , isSymbolicBoth ) where + +import G2.Config +import G2.Execution +import G2.Execution.NormalForms +import G2.Interface +import G2.Language +import G2.Lib.Printers +import qualified G2.Language.ExprEnv as E +import qualified G2.Language.Stack as S +import qualified G2.Language.Typing as TY +import G2.Solver +import G2.Equiv.Config + +import Control.Monad.IO.Class +import qualified Control.Monad.State as SM +import qualified Data.HashMap.Lazy as HM +import qualified Data.HashSet as HS + +import qualified Data.Text as T + +import Data.Hashable +import qualified Data.List as L + +import GHC.Generics (Generic) + +-- get names from symbolic ids in the state +runG2ForNebula :: Solver solver => + solver -> + StateET -> + E.ExprEnv -> + EquivTracker -> + Config -> + NebulaConfig -> + Bindings -> + IO ([ExecRes EquivTracker], Bindings) +runG2ForNebula solver state h_opp track_opp config nc bindings = do + --SomeSolver solver <- initSolver config + let simplifier = IdSimplifier + sym_config = PreserveAllMC + {- + sym_config = addSearchNames (namesList $ track state) + $ addSearchNames (input_names bindings) + $ addSearchNames (M.keys $ deepseq_walkers bindings) emptyMemConfig + -} + + state' = state { track = (track state) { saw_tick = Nothing } } + + (in_out, bindings') <- case rewriteRedHaltOrd solver simplifier h_opp track_opp config nc of + (red, hal, ord) -> + SM.evalStateT (runG2WithSomes red hal ord solver simplifier sym_config state' bindings) (mkPrettyGuide ()) + + --close solver + + return (in_out, bindings') + +rewriteRedHaltOrd :: (MonadIO m, Solver solver, Simplifier simplifier) => + solver -> + simplifier -> + E.ExprEnv -> + EquivTracker -> + Config -> + NebulaConfig -> + ( SomeReducer (SM.StateT PrettyGuide m) EquivTracker + , SomeHalter (SM.StateT PrettyGuide m) EquivTracker + , SomeOrderer (SM.StateT PrettyGuide m) EquivTracker) +rewriteRedHaltOrd solver simplifier h_opp track_opp config (NC { use_labeled_errors = use_labels }) = + let + share = sharing config + state_name = Name "state" Nothing 0 Nothing + + m_logger = fmap SomeReducer $ getLogger config + some_std_red = enforceProgressRed :== NoProgress --> stdRed share retReplaceSymbFuncVar solver simplifier + extra_red = symbolicSwapperRed h_opp track_opp ~> concSymReducer use_labels ~> labeledErrorsRed + red = equivReducer :== NoProgress .--> extra_red :== NoProgress .--> some_std_red + in + (case m_logger of + Just logger -> logger .~> red + Nothing -> red + , SomeHalter + (discardIfAcceptedTagHalter state_name + <~> enforceProgressHalter + <~> swhnfHalter + <~> labeledErrorsHalter) + , SomeOrderer $ pickLeastUsedOrderer) + +type StateET = State EquivTracker + +data BlockInfo = BlockDC DataCon Int Int + | BlockLam Id + deriving (Show, Eq, Generic) + +instance Hashable BlockInfo + +instance Named BlockInfo where + names (BlockDC dc _ _) = names dc + names (BlockLam i) = names i + rename old new (BlockDC dc n1 n2) = BlockDC (rename old new dc) n1 n2 + rename old new (BlockLam i) = BlockLam (rename old new i) + +-- Maps higher order function calls to symbolic replacements. +-- This allows the same call to be replaced by the same Id consistently. +data EquivTracker = EquivTracker { higher_order :: HM.HashMap Expr Id + , saw_tick :: Maybe Int + , total_vars :: HS.HashSet Name + , dc_path :: [BlockInfo] + , opp_env :: ExprEnv + , folder_name :: String } deriving (Show, Eq, Generic) + +instance Hashable EquivTracker + +-- | Forces a lone symbolic variable with a type corresponding to an ADT +-- to evaluate to some value of that ADT +concSymReducer :: Monad m => UseLabeledErrors -> Reducer m () EquivTracker +concSymReducer use_labels = mkSimpleReducer + (const ()) + rr + where + rr _ + s@(State { curr_expr = CurrExpr _ (Var (Id n t)) + , expr_env = eenv + , type_env = tenv + , track = EquivTracker et m total dcp opp fname }) + b@(Bindings { name_gen = ng }) + | E.isSymbolic n eenv + , Just (dc_symbs, ng') <- arbDC use_labels tenv ng t n total = do + let new_names = map idName $ concat $ map snd dc_symbs + total' = if n `elem` total + then foldr HS.insert total new_names + else total + xs = map (\(e, symbs') -> + s { curr_expr = CurrExpr Evaluate e + , expr_env = + foldr E.insertSymbolic + (E.insert n e eenv) + symbs' + , track = EquivTracker et m total' dcp opp fname + }) dc_symbs + b' = b { name_gen = ng' } + -- only add to total if n was total + -- not all of these will be used on each branch + -- they're all fresh, though, so overlap is not a problem + return (InProgress, zip xs (repeat ()) , b') + rr _ s b = return (NoProgress, [(s, ())], b) + +-- | Build a case expression with one alt for each data constructor of the given type +-- and symbolic arguments. Thus, the case expression could evaluate to any value of the +-- given type. +arbDC :: UseLabeledErrors + -> TypeEnv + -> NameGen + -> Type + -> Name + -> HS.HashSet Name + -> Maybe ([(Expr, [Id])], NameGen) +arbDC use_labels tenv ng t n total + | TyCon tn _:ts <- unTyApp t + , Just adt <- HM.lookup tn tenv = + let + dcs = dataCon adt + + bound = bound_ids adt + bound_ts = zip bound ts + + (err_lab, ng') = freshLabeledError ng + err = if use_labels == UseLabeledErrors + then Tick (NamedLoc err_lab) (Prim Error TyBottom) + else Prim Error TyBottom + + ty_apped_dcs = map (\dc -> mkApp $ Data dc:map Type ts) dcs + ty_apped_dcs' = err:ty_apped_dcs + (ng'', dc_symbs) = + L.mapAccumL + (\ng_ dc -> + let + anon_ts = anonArgumentTypes dc + re_anon = foldr (\(i, ty) -> retype i ty) anon_ts bound_ts + (ars, ng_') = freshIds re_anon ng_ + in + (ng_', (mkApp $ dc:map Var ars, ars)) + ) + ng' + (if n `elem` total then ty_apped_dcs else ty_apped_dcs') + in + Just (dc_symbs, ng'') + | otherwise = Nothing + +symbolicSwapperRed :: Monad m => E.ExprEnv -> EquivTracker -> Reducer m () EquivTracker +symbolicSwapperRed h_opp track_opp = mkSimpleReducer + (const ()) + rr + where + rr rv + s@(State { curr_expr = CurrExpr _ e + , expr_env = h + , track = EquivTracker et m tot dcp opp fname }) + b = + case e of + Var (Id n _) | E.isSymbolic n h -> + case E.lookupConcOrSym n h_opp of + Just (E.Conc e') -> + let vi = varIds e' + vi_hs = HS.fromList $ map idName vi + h' = foldr (\j -> E.insertSymbolic j) (E.insert n e' h) (L.nub vi) + total' = HS.union (HS.intersection (total_vars track_opp) vi_hs) tot + track' = EquivTracker et m total' dcp opp fname + s' = s { + expr_env = h' + , track = track' + } + in return (InProgress, [(s', rv)], b) + _ -> return (NoProgress, [(s, rv)], b) + _ -> return (NoProgress, [(s, rv)], b) + +enforceProgressRed :: Monad m => Reducer m () EquivTracker +enforceProgressRed = mkSimpleReducer + (const ()) + rr + where + rr rv s@(State { curr_expr = CurrExpr _ e + , num_steps = n + , track = EquivTracker et m total dcp opp fname }) + b = + let s' = s { track = EquivTracker et (Just n) total dcp opp fname } + need_more = case m of + Nothing -> True + Just n0 -> n > n0 + 1 + in + case e of + Tick (NamedLoc (Name p _ _ _)) _ -> + if p == T.pack "STACK" && need_more + then return (InProgress, [(s', ())], b) + else return (NoProgress, [(s, ())], b) + _ -> return (NoProgress, [(s, rv)], b) + +labeledErrorStringSeed :: T.Text +labeledErrorStringSeed = "__ERROR_LABEL__" + +labeledErrorNameSeed :: Name +labeledErrorNameSeed = Name "__ERROR_LABEL__" Nothing 0 Nothing + +isLabeledErrorName :: Name -> Bool +isLabeledErrorName (Name n _ _ _) = n == labeledErrorStringSeed + +labeledErrorName :: Tickish -> Maybe Name +labeledErrorName (NamedLoc n) | isLabeledErrorName n = Just n +labeledErrorName _ = Nothing + +freshLabeledError :: NameGen -> (Name, NameGen) +freshLabeledError = freshSeededName labeledErrorNameSeed + +isLabeledError :: Expr -> Bool +isLabeledError (Tick (NamedLoc n) (Prim Error _)) = isLabeledErrorName n +isLabeledError (Tick (NamedLoc n) (Prim Undefined _)) = isLabeledErrorName n +isLabeledError _ = False + +labeledErrorsRed :: Monad m => Reducer m () t +labeledErrorsRed = mkSimpleReducer + (const ()) + rr + where + rr rv s@(State { curr_expr = CurrExpr _ ce }) b + | isLabeledError ce = return (Finished, [(s { exec_stack = S.empty }, rv)], b) + | otherwise = return (NoProgress, [(s, rv)], b) + +labeledErrorsHalter :: Monad m => Halter m () t +labeledErrorsHalter = mkSimpleHalter (const ()) + (\hv _ _ -> hv) + stop + (\hv _ _ _ -> hv) + where + stop _ _ (State { curr_expr = CurrExpr _ ce, exec_stack = stck }) + | isLabeledError ce, S.null stck = return Accept + | otherwise = return Continue + + +-- this does not account for type arguments +argCount :: Type -> Int +argCount = length . spArgumentTypes . PresType + +exprFullApp :: ExprEnv -> Expr -> Bool +exprFullApp h e | (Tick (NamedLoc (Name p _ _ _)) f):as <- unApp e + , p == T.pack "REC" = exprFullApp h (mkApp $ f:as) +exprFullApp h e | (Var (Id n t)):_ <- unApp e + -- We require that the variable be the center of a function + -- application, have at least one argument, and not map to a variable for two reasons: + -- (1) We do not want to count symbolic function applications as in FAF form + -- (2) We need to ensure we make sufficient progress to avoid + -- moreRestrictive matching states spuriously. + -- Consider an expression environment with a mapping of `x :: Int` to `f y`. + -- We want to avoid storing a previous state using x, + -- having the symbolic execution inline `f y`, and then deciding that + -- the two states match and are sufficient for verification to succeed, + -- when, in isMoreRestrictive, x is inlined. + , Just e' <- E.lookup n h + , not (isVar e') + , c_unapp <- length (unApp e) + , c_unapp >= 2 = c_unapp == 1 + argCount t +exprFullApp _ _ = False + +isVar :: Expr -> Bool +isVar (Tick _ e) = isVar e +isVar (Var _) = True +isVar _ = False + +-- induction only works if both states in a pair satisfy this +-- there's no harm in stopping here for just one, though +-- TODO removing the Case requirement doesn't fix forceIdempotent +recursionInCase :: State t -> Bool +recursionInCase (State { curr_expr = CurrExpr _ e }) = + case e of + Tick (NamedLoc (Name p _ _ _)) _ -> + p == T.pack "REC" -- && containsCase sk + _ -> False + +enforceProgressHalter :: Monad m => Halter m () EquivTracker +enforceProgressHalter = mkSimpleHalter + (const ()) + (\_ _ _ -> ()) + stop + (\_ _ _ _ -> ()) + where + stop _ _ s = + let CurrExpr _ e = curr_expr s + n' = num_steps s + EquivTracker _ m _ _ _ _ = track s + h = expr_env s + in + case m of + Nothing -> return Continue + -- Execution needs to take strictly more than one step beyond the + -- point when it reaches the Tick because the act of unwrapping the + -- expression inside the Tick counts as one step. + Just n0 -> do + if (isExecValueForm s) || (exprFullApp h e) || (recursionInCase s) + then return (if n' > n0 + 1 then Accept else Continue) + else return Continue + +emptyEquivTracker :: EquivTracker +emptyEquivTracker = EquivTracker HM.empty Nothing HS.empty [] E.empty "" + +equivReducer :: Monad m => Reducer m () EquivTracker +equivReducer = mkSimpleReducer + (const ()) + rr + where + rr _ + s@(State { expr_env = eenv + , curr_expr = CurrExpr Evaluate e + , track = EquivTracker et m total dcp opp fname }) + b@(Bindings { name_gen = ng }) + | isSymFuncApp eenv (removeAllTicks e) = + let + -- We inline variables to have a higher chance of hitting in the Equiv Tracker + e' = removeAllTicks $ inlineApp eenv e + in + case HM.lookup e' et of + Just v -> + let eenv' = case E.lookup (idName v) eenv of + Just _ -> eenv + Nothing -> E.insertSymbolic v eenv + s' = s { + curr_expr = CurrExpr Evaluate (Var v) + , expr_env = eenv' + } + in + return (InProgress, [(s', ())], b) + Nothing -> + let + (v, ng') = freshId (typeOf e) ng + et' = HM.insert e' v et + -- carry over totality if function and all args are total + all_total = all (totalExpr s HS.empty []) $ unApp e' + total' = if all_total + then HS.insert (idName v) total + else total + s' = s { curr_expr = CurrExpr Evaluate (Var v) + , track = EquivTracker et' m total' dcp opp fname + , expr_env = E.insertSymbolic v eenv } + b' = b { name_gen = ng' } + in + return (InProgress, [(s', ())], b') + rr rv s b = return (NoProgress, [(s, rv)], b) + +-- not exhaustive, but totality is undecidable in general +-- cyclic expressions do not count as total for now +-- if a cycle never goes through a Data constructor, it's not total +totalExpr :: StateET -> + HS.HashSet Name -> + [Name] -> -- variables inlined previously + Expr -> + Bool +totalExpr s@(State { expr_env = h, track = EquivTracker _ _ total _ h' _ }) ns n e = + case e of + Tick _ e' -> totalExpr s ns n e' + Var i | m <- idName i + , isSymbolicBoth m h h' -> m `elem` total + | m <- idName i + , not $ HS.member m ns + , not $ m `elem` n + , Just e' <- lookupBoth m h h' -> totalExpr s ns (m:n) e' + | (idName i) `elem` n -> False + | HS.member (idName i) ns -> False + | otherwise -> error $ "unmapped variable " ++ show i ++ " " ++ (folder_name $ track s) + App f a -> totalExpr s ns n f && totalExpr s ns n a + Data _ -> True + Prim p _ -> not (p == Error || p == Undefined) + Lit _ -> True + Lam _ _ _ -> False + Type _ -> True + Let _ _ -> False + Case _ _ _ _ -> False + _ -> False + +-- helper function to circumvent syncSymbolic +-- for symbolic things, lookup returns the variable +lookupBoth :: Name -> ExprEnv -> ExprEnv -> Maybe Expr +lookupBoth n h1 = fmap E.concOrSymToExpr . lookupConcOrSymBoth n h1 + +lookupConcOrSymBoth :: Name -> ExprEnv -> ExprEnv -> Maybe E.ConcOrSym +lookupConcOrSymBoth n h1 h2 = case E.lookupConcOrSym n h1 of + e@(Just (E.Conc _)) -> e + sym@(Just (E.Sym _)) -> case E.lookupConcOrSym n h2 of + Nothing -> sym + m -> m + Nothing -> E.lookupConcOrSym n h2 + +-- doesn't count as symbolic if it's unmapped +-- condition we need: n is symbolic in every env where it's mapped +isSymbolicBoth :: Name -> ExprEnv -> ExprEnv -> Bool +isSymbolicBoth n h1 h2 = + case E.lookupConcOrSym n h1 of + Just (E.Sym _) -> case E.lookupConcOrSym n h2 of + Just (E.Conc _) -> False + _ -> True + Just (E.Conc _) -> False + Nothing -> E.isSymbolic n h2 + +isSymFuncApp :: ExprEnv -> Expr -> Bool +isSymFuncApp eenv e + | v@(Var _):(_:_) <- unApp e + , (Var (Id f t)) <- inlineVars eenv v = + E.isSymbolic f eenv && hasFuncType (PresType t) + | otherwise = False + +removeTicks :: Expr -> Expr +removeTicks (Tick _ e) = removeTicks e +removeTicks e = e + +removeAllTicks :: Expr -> Expr +removeAllTicks = modifyASTs removeTicks + +inlineApp :: ExprEnv -> Expr -> Expr +inlineApp eenv = mkApp . map (inlineVars eenv) . unApp + +inlineVars :: ExprEnv -> Expr -> Expr +inlineVars = inlineVars' HS.empty + +inlineVars' :: HS.HashSet Name -> ExprEnv -> Expr -> Expr +inlineVars' seen eenv (Var (Id n _)) + | not (n `HS.member` seen) + , Just e <- E.lookup n eenv = inlineVars' (HS.insert n seen) eenv e +inlineVars' seen eenv (App e1 e2) = App (inlineVars' seen eenv e1) (inlineVars' seen eenv e2) +inlineVars' _ _ e = e + +instance ASTContainer EquivTracker Expr where + containedASTs (EquivTracker hm _ _ _ _ _) = HM.keys hm + modifyContainedASTs f (EquivTracker hm m total dcp opp fname) = + (EquivTracker . HM.fromList . map (\(k, v) -> (f k, v)) $ HM.toList hm) + m total dcp opp fname + +instance ASTContainer EquivTracker Type where + containedASTs (EquivTracker hm _ _ _ _ _) = containedASTs $ HM.keys hm + modifyContainedASTs f (EquivTracker hm m total dcp opp fname) = + ( EquivTracker + . HM.fromList + . map (\(k, v) -> (modifyContainedASTs f k, modifyContainedASTs f v)) + $ HM.toList hm ) + m total dcp opp fname + +instance Named EquivTracker where + names (EquivTracker hm _ _ _ _ _) = names hm + rename old new (EquivTracker hm m total dcp opp fname) = + EquivTracker (rename old new hm) m (rename old new total) (rename old new dcp) (rename old new opp) fname diff --git a/src/G2/Equiv/Generalize.hs b/src/G2/Equiv/Generalize.hs new file mode 100644 --- /dev/null +++ b/src/G2/Equiv/Generalize.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE OverloadedStrings #-} + +module G2.Equiv.Generalize ( generalizeFull ) where + +import G2.Language + +import qualified G2.Language.ExprEnv as E + +import Data.Maybe + +import qualified Data.HashSet as HS +import qualified G2.Solver as S + +import G2.Equiv.G2Calls +import G2.Equiv.Tactics + +import Data.Monoid (Any (..)) + +import qualified Control.Monad.Writer.Lazy as W + +innerScrutinees :: Expr -> [Expr] +innerScrutinees (Tick _ e) = innerScrutinees e +innerScrutinees e@(Case e' _ _ _) = e:(innerScrutinees e') +innerScrutinees e = [e] + +replaceScrutinee :: Expr -> Expr -> Expr -> Expr +replaceScrutinee e1 e2 e | e1 == e = e2 +replaceScrutinee e1 e2 (Tick nl e) = Tick nl (replaceScrutinee e1 e2 e) +replaceScrutinee e1 e2 (Case e i t a) = Case (replaceScrutinee e1 e2 e) i t a +replaceScrutinee _ _ e = e + +generalizeAux :: S.Solver solver => + solver -> + Int -> + HS.HashSet Name -> + Lemmas -> + [StateET] -> + StateET -> + W.WriterT [Marker] IO (Maybe (PrevMatch EquivTracker)) +generalizeAux solver num_lems ns lemmas s1_list s2 = do + -- Originally, this equality check did not allow for lemma usage + -- because it was supposed to check only for syntactic equality. + -- However, there do not seem to be any soundness issues with + -- enabling lemma usage here to make the tactic more powerful. + let check_equiv s1_ = moreRestrictiveEqual solver num_lems ns lemmas s1_ s2 + res <- mapM check_equiv s1_list + let res' = filter isJust res + case res' of + [] -> return Nothing + h:_ -> return h + +adjustStateForGeneralization :: Expr -> Name -> StateET -> StateET +adjustStateForGeneralization e_old fresh_name s = + let e = getExpr s + fresh_id = Id fresh_name (typeOf e) + fresh_var = Var fresh_id + e' = replaceScrutinee e fresh_var e_old + h = expr_env s + h' = E.insertSymbolic fresh_id h + in s { + curr_expr = CurrExpr Evaluate e' + , expr_env = h' + } + +-- replace the largest sub-expression possible with a fresh symbolic var +generalize :: S.Solver solver => + solver -> + Int -> + HS.HashSet Name -> + Lemmas -> + Name -> + (StateET, StateET) -> + W.WriterT [Marker] IO (Maybe (StateET, StateET)) +generalize solver num_lems ns lemmas fresh_name (s1, s2) | dc_path (track s1) == dc_path (track s2) = do + -- expressions are ordered from outer to inner + -- the largest ones are on the outside + -- take the earliest array entry that works + -- for anything on one side, there can only be one match on the other side + let e1 = getExpr s1 + scr1 = innerScrutinees e1 + scr_states1 = map (\e -> s1 { curr_expr = CurrExpr Evaluate e }) scr1 + e2 = getExpr s2 + scr2 = innerScrutinees e2 + scr_states2 = map (\e -> s2 { curr_expr = CurrExpr Evaluate e }) scr2 + res <- mapM (generalizeAux solver num_lems ns lemmas scr_states1) scr_states2 + -- no equiv tracker changes seem to be necessary + let res' = filter isJust res + case res' of + (Just pm):_ -> let (s1', s2') = present pm + s1'' = adjustStateForGeneralization e1 fresh_name s1' + s2'' = adjustStateForGeneralization e2 fresh_name s2' + in return $ Just $ syncSymbolic s1'' s2'' + _ -> return Nothing + | otherwise = return Nothing + +generalizeFoldL :: S.Solver solver => + solver -> + Int -> + HS.HashSet Name -> + Lemmas -> + Name -> + [StateET] -> + StateET -> + W.WriterT [Marker] IO (Maybe (StateET, StateET, StateET, StateET)) +generalizeFoldL solver num_lems ns lemmas fresh_name prev2 s1 = do + case prev2 of + [] -> return Nothing + p2:t -> do + gen <- generalize solver num_lems ns lemmas fresh_name (s1, p2) + case gen of + Just (s1', s2') -> return $ Just (s1, p2, s1', s2') + _ -> generalizeFoldL solver num_lems ns lemmas fresh_name t s1 + +generalizeFold :: S.Solver solver => + solver -> + Int -> + HS.HashSet Name -> + Lemmas -> + Name -> + (StateH, StateH) -> + (StateET, StateET) -> + W.WriterT [Marker] IO (Maybe (StateET, StateET, StateET, StateET)) +generalizeFold solver num_lems ns lemmas fresh_name (sh1, sh2) (s1, s2) = do + fl <- generalizeFoldL solver num_lems ns lemmas fresh_name (s2:history sh2) s1 + case fl of + Just _ -> return fl + Nothing -> do + fr <- generalizeFoldL solver num_lems ns lemmas fresh_name (s1:history sh1) s2 + case fr of + Just (q2, q1, q2', q1') -> return $ Just (q1, q2, q1', q2') + Nothing -> return Nothing + +generalizeFull :: S.Solver s => Tactic s +generalizeFull solver num_lems ns lemmas (fresh_name:_) sh_pair s_pair = do + gfold <- generalizeFold solver num_lems ns lemmas fresh_name sh_pair s_pair + case gfold of + Nothing -> return $ NoProof [] + Just (s1, s2, q1, q2) -> let lem = mkProposedLemma "Generalization" s1 s2 q1 q2 + in return $ NoProof $ [lem] +generalizeFull _ _ _ _ _ _ _ = return $ NoProof [] diff --git a/src/G2/Equiv/InitRewrite.hs b/src/G2/Equiv/InitRewrite.hs new file mode 100644 --- /dev/null +++ b/src/G2/Equiv/InitRewrite.hs @@ -0,0 +1,38 @@ +module G2.Equiv.InitRewrite (initWithRHS, initWithLHS) where + +import G2.Language +import qualified G2.Language.ExprEnv as E +import qualified G2.Language.Typing as T +import qualified G2.Language.Expr as X + +import G2.Execution.Memory + +initWithRHS :: State t -> Bindings -> RewriteRule -> (State t, Bindings) +initWithRHS s b r = + let s' = s { + curr_expr = CurrExpr Evaluate (ru_rhs r) + , expr_env = foldr E.insertSymbolic (expr_env s) (ru_bndrs r) + } + b' = b { input_names = map idName $ ru_bndrs r } + in + markAndSweepPreserving emptyMemConfig s' b' + +initWithLHS :: State t -> Bindings -> RewriteRule -> (State t, Bindings) +initWithLHS s b r = + -- make LHS into a single expr + let f_name = ru_head r + f_maybe = E.lookup f_name (expr_env s) + in + case f_maybe of + Nothing -> error "function name not found" + Just f -> let t = T.typeOf f + i = Id f_name t + v = Var i + app = X.mkApp (v:ru_args r) + s' = s { + curr_expr = CurrExpr Evaluate app + , expr_env = foldr E.insertSymbolic (expr_env s) (ru_bndrs r) + } + b' = b { input_names = map idName $ ru_bndrs r } + in + markAndSweepPreserving emptyMemConfig s' b' diff --git a/src/G2/Equiv/Summary.hs b/src/G2/Equiv/Summary.hs new file mode 100644 --- /dev/null +++ b/src/G2/Equiv/Summary.hs @@ -0,0 +1,588 @@ +{-# LANGUAGE OverloadedStrings #-} + +module G2.Equiv.Summary + ( SummaryMode (..) + , summarize + , summarizeAct + , summarizeLemmaMarker + , printPG + , showCX + , showCycle + , stateMaxDepth + , stateSumDepths + , minMaxDepth + , minSumDepth + ) + where + +import G2.Language + +import qualified G2.Language.ExprEnv as E +import qualified G2.Language.Expr as X + +import Data.List +import Data.Maybe +import Data.Tuple +import qualified Data.Text as DT + +import qualified Data.HashSet as HS +import qualified Data.HashMap.Lazy as HM + +import G2.Equiv.Config +import G2.Equiv.EquivADT +import G2.Equiv.G2Calls +import G2.Equiv.Tactics + +import G2.Lib.Printers + +sideName :: Side -> String +sideName ILeft = "Left" +sideName IRight = "Right" + +trackName :: StateET -> String +trackName s = + let str = folder_name $ track s + substrs = DT.splitOn (DT.pack "/") $ DT.pack str + final_sub = case reverse substrs of + [] -> error "No Substring" + fs:_ -> DT.unpack fs + in case final_sub of + "" -> "Start" + _ -> final_sub + +printPG :: PrettyGuide -> HS.HashSet Name -> [Id] -> StateET -> String +printPG pg ns sym_ids s = + let label_str = trackName s + h = expr_env s + e = inlineVars ns h $ getExpr s + e_str = DT.unpack $ printHaskellDirtyPG pg e + -- sym exec keeps higher_order in sync but not concretizations + -- this means that the ids in func_ids are not always mapped + -- if they are unmapped, they will not be printed for a state + depth_str1 = "\nMax Depth: " ++ (show $ maxArgDepth ns sym_ids s) + depth_str2 = "\nSum Depth: " ++ (show $ sumArgDepths ns sym_ids s) + func_ids = map snd $ HM.toList $ higher_order $ track s + sym_vars = varsFullList h ns $ sym_ids ++ func_ids + sym_str = printVars pg ns s sym_vars + sym_print = case sym_str of + "" -> "" + _ -> "\nMain Symbolic Variables:\n" ++ sym_str + other_vars = varsFull h ns e \\ sym_vars + var_str = printVars pg ns s other_vars + var_print = case var_str of + "" -> "" + _ -> "\nOther Variables:\n" ++ var_str + map_str = printMappings pg s + map_print = case map_str of + "" -> "" + _ -> "\nSymbolic Function Mappings:\n" ++ map_str + dc_print = "\nPath Length: " ++ (show $ length $ dc_path $ track s) + in label_str ++ "\n" ++ e_str ++ depth_str1 ++ depth_str2 ++ + sym_print ++ var_print ++ map_print ++ dc_print ++ "\n---" + +inlineVars :: HS.HashSet Name -> ExprEnv -> Expr -> Expr +inlineVars = inlineVars' HS.empty + +inlineVars' :: HS.HashSet Name -> HS.HashSet Name -> ExprEnv -> Expr -> Expr +inlineVars' seen ns eenv v@(Var (Id n _)) + | n `elem` ns = v + | n `HS.member` seen = v + | Just (E.Conc e) <- E.lookupConcOrSym n eenv = inlineVars' (HS.insert n seen) ns eenv e +inlineVars' seen ns eenv e = modifyChildren (inlineVars' seen ns eenv) e + +data ChainEnd = Symbolic Id + | Cycle Id + | Terminal Expr + | Unmapped + +-- don't include ns names in the result here +-- this does not remove duplicates +varsInExpr :: HS.HashSet Name -> Expr -> [Id] +varsInExpr ns e = filter (\i -> not ((idName i) `elem` ns)) $ X.vars e + +-- new function for getting all of the variables right away +-- some of the computations here are redundant with what happens later +-- need to prune out repeats +-- should things count as repeats if they appear in the chain? +-- no need to remove duplicates if HashSet used internally +varsFull :: ExprEnv -> HS.HashSet Name -> Expr -> [Id] +varsFull h ns e = + let v_ids = varsInExpr ns e + in HS.toList $ varsFullRec ns h (HS.fromList v_ids) v_ids + +varsFullList :: ExprEnv -> HS.HashSet Name -> [Id] -> [Id] +varsFullList h ns v_ids = + HS.toList $ varsFullRec ns h (HS.fromList v_ids) v_ids + +varsFullRec :: HS.HashSet Name -> ExprEnv -> HS.HashSet Id -> [Id] -> HS.HashSet Id +varsFullRec ns h seen search + | null search = seen + | otherwise = + let all_exprs = mapMaybe (flip E.lookup h) $ map idName search + all_vars = vars all_exprs + all_new = filter + (\i -> not (((idName i) `elem` ns) || HS.member i seen)) + all_vars + new_seen = HS.union (HS.fromList all_new) seen + in varsFullRec ns h new_seen all_new + +-- the terminal expression can have variables of its own +-- seemingly, they're not needed for anything +varChain :: ExprEnv -> HS.HashSet Name -> [Id] -> Id -> ([Id], ChainEnd) +varChain h ns inlined i = + if i `elem` inlined then (reverse inlined, Cycle i) + else if (idName i) `elem` ns then (reverse inlined, Terminal (Var i)) + else case E.lookupConcOrSym (idName i) h of + Nothing -> ([], Unmapped) + Just (E.Sym i') -> (reverse (i:inlined), Symbolic i') + Just (E.Conc e) -> exprChain h ns (i:inlined) e + +exprChain :: ExprEnv -> HS.HashSet Name -> [Id] -> Expr -> ([Id], ChainEnd) +exprChain h ns inlined e = case e of + Tick _ (Prim Error _) -> (reverse inlined, Terminal e) + Tick _ e' -> exprChain h ns inlined e' + Var i -> varChain h ns inlined i + _ -> (reverse inlined, Terminal e) + +-- stop inlining when something in ns reached +printVar :: PrettyGuide -> HS.HashSet Name -> StateET -> Id -> String +printVar pg ns (State{ expr_env = h }) i = + let (chain, c_end) = varChain h ns [] i + chain_strs = map (\i_ -> DT.unpack . printHaskellDirtyPG pg $ Var i_) chain + end_str = case c_end of + Symbolic (Id _ t) -> "Symbolic " ++ DT.unpack (mkTypeHaskellPG pg t) + Cycle i' -> "Cycle " ++ DT.unpack (printHaskellDirtyPG pg (Var i')) + Terminal e -> DT.unpack $ printHaskellDirtyPG pg e + Unmapped -> "" + in case c_end of + Unmapped -> "" + _ -> (foldr (\str acc -> str ++ " = " ++ acc) "" chain_strs) ++ end_str + +printVars :: PrettyGuide -> HS.HashSet Name -> StateET -> [Id] -> String +printVars pg ns s v_ids = + let var_strs = map (printVar pg ns s) v_ids + non_empty_strs = filter (not . null) var_strs + in intercalate "\n" non_empty_strs + +printMapping :: PrettyGuide -> (Expr, Id) -> String +printMapping pg (e, i) = + let e_str = DT.unpack $ printHaskellDirtyPG pg e + i_str = DT.unpack $ printHaskellDirtyPG pg (Var i) + in e_str ++ " --> " ++ i_str + +printMappings :: PrettyGuide -> StateET -> String +printMappings pg s = + let mapping_list = HM.toList $ higher_order $ track s + in intercalate "\n" $ map (printMapping pg) mapping_list + +printLemma :: PrettyGuide -> HS.HashSet Name -> [Id] -> Lemma -> String +printLemma pg ns sym_ids (Lemma{ + lemma_name = n + , lemma_lhs = s1 + , lemma_rhs = s2 + , lemma_lhs_origin = n1 + , lemma_rhs_origin = n2 + }) = + n ++ ": from " ++ + n1 ++ ", " ++ n2 ++ "\n" ++ + (summarizeStatePairTrack "States" pg ns sym_ids s1 s2) + +-- no new line at end +summarizeStatePairTrack :: String -> + PrettyGuide -> + HS.HashSet Name -> + [Id] -> + StateET -> + StateET -> + String +summarizeStatePairTrack str pg ns sym_ids s1 s2 = + str ++ ": " ++ + (trackName s1) ++ ", " ++ + (trackName s2) ++ "\n" ++ + (printPG pg ns sym_ids s1) ++ "\n" ++ + (printPG pg ns sym_ids s2) + +summarizeLemma :: String + -> PrettyGuide + -> HS.HashSet Name + -> [Id] + -> Lemma + -> String +summarizeLemma str pg ns sym_ids lem = + str ++ ":\n" ++ + printLemma pg ns sym_ids lem + +summarizeLemmaSubst :: String + -> PrettyGuide + -> HS.HashSet Name + -> [Id] + -> (StateET, Lemma) + -> String +summarizeLemmaSubst str pg ns sym_ids (s, lem) = + "\n" ++ str ++ " Lemma:\n" ++ printLemma pg ns sym_ids lem ++ + "\n" ++ str ++ " Before Lemma Usage:\n" ++ printPG pg ns sym_ids s + +summarizeCoinduction :: PrettyGuide -> HS.HashSet Name -> [Id] -> CoMarker -> String +summarizeCoinduction pg ns sym_ids (CoMarker { + co_used_present = (q1, q2) + , co_past = (p1, p2) + , lemma_used_left = lemma_l + , lemma_used_right = lemma_r + }) = + "Coinduction:\n" ++ + --(summarizeStatePairTrack "Real Present" pg ns sym_ids s1 s2) ++ "\n" ++ + (summarizeStatePairTrack "Used Present" pg ns sym_ids q1 q2) ++ "\n" ++ + (summarizeStatePairTrack "Past" pg ns sym_ids p1 p2) ++ + (intercalate "\n" $ map (summarizeLemmaSubst "Left" pg ns sym_ids) lemma_l) ++ + (intercalate "\n" $ map (summarizeLemmaSubst "Right" pg ns sym_ids) lemma_r) + +-- variables: find all names used in here +-- look them up, find a fixed point +-- print all relevant vars beside the expressions +-- don't include definitions from the initial state (i.e. things in ns) +summarizeEquality :: PrettyGuide -> HS.HashSet Name -> [Id] -> EqualMarker -> String +summarizeEquality pg ns sym_ids (EqualMarker { eq_used_present = (q1, q2) }) = + "Equivalent Expressions:\n" ++ + --(summarizeStatePairTrack "Real Present" pg ns sym_ids s1 s2) ++ "\n" ++ + (summarizeStatePairTrack "Used States" pg ns sym_ids q1 q2) + +summarizeCycleFound :: PrettyGuide -> + HS.HashSet Name -> + [Id] -> + CycleMarker -> + String +summarizeCycleFound pg ns sym_ids (CycleMarker (s1, s2) p _ sd) = + "CYCLE FOUND:\n" ++ + (summarizeStatePairTrack "Real Present" pg ns sym_ids s1 s2) ++ + "\nPast State:\n" ++ (printPG pg ns sym_ids p) ++ + "\nSide: " ++ (sideName sd) + +summarizeNoObligations :: PrettyGuide -> + HS.HashSet Name -> + [Id] -> + (StateET, StateET) -> + String +summarizeNoObligations = summarizeStatePair "No Obligations Produced" + +summarizeNotEquivalent :: PrettyGuide -> + HS.HashSet Name -> + [Id] -> + (StateET, StateET) -> + String +summarizeNotEquivalent = summarizeStatePair "NOT EQUIVALENT" + +summarizeSolverFail :: PrettyGuide -> + HS.HashSet Name -> + [Id] -> + (StateET, StateET) -> + String +summarizeSolverFail = summarizeStatePair "SOLVER FAIL" + +summarizeLemmaProposed :: PrettyGuide -> + HS.HashSet Name -> + [Id] -> + Lemma -> + String +summarizeLemmaProposed = summarizeLemma "Lemma Proposed" + +summarizeLemmaProven :: PrettyGuide -> + HS.HashSet Name -> + [Id] -> + Lemma -> + String +summarizeLemmaProven = summarizeLemma "Lemma Proven" + +summarizeLemmaRejected :: PrettyGuide -> + HS.HashSet Name -> + [Id] -> + Lemma -> + String +summarizeLemmaRejected = summarizeLemma "Lemma Rejected" + +summarizeLemmaProvenEarly :: PrettyGuide -> + HS.HashSet Name -> + [Id] -> + (Lemma, Lemma) -> + String +summarizeLemmaProvenEarly = summarizeLemmaPair "Lemma Superseded" + +summarizeLemmaRejectedEarly :: PrettyGuide -> + HS.HashSet Name -> + [Id] -> + (Lemma, Lemma) -> + String +summarizeLemmaRejectedEarly = summarizeLemmaPair "Lemma Discarded" + +summarizeLemmaUnresolved :: PrettyGuide -> + HS.HashSet Name -> + [Id] -> + Lemma -> + String +summarizeLemmaUnresolved = summarizeLemma "Lemma Unresolved" + +summarizeUnresolved :: PrettyGuide -> + HS.HashSet Name -> + [Id] -> + (StateET, StateET) -> + String +summarizeUnresolved = summarizeStatePair "Unresolved" + +summarizeStatePair :: String -> + PrettyGuide -> + HS.HashSet Name -> + [Id] -> + (StateET, StateET) -> + String +summarizeStatePair str pg ns sym_ids (s1, s2) = + str ++ ":\n" ++ + trackName s1 ++ ", " ++ + trackName s2 ++ "\n" ++ + printPG pg ns sym_ids s1 ++ "\n" ++ + printPG pg ns sym_ids s2 + +-- we care principally about l2 here +summarizeLemmaPair :: String -> + PrettyGuide -> + HS.HashSet Name -> + [Id] -> + (Lemma, Lemma) -> + String +summarizeLemmaPair str pg ns sym_ids (l1, l2) = + str ++ ":\n" ++ + lemma_lhs_origin l2 ++ ", " ++ + lemma_rhs_origin l2 ++ "\n" ++ + printLemma pg ns sym_ids l1 ++ "\n" ++ + printLemma pg ns sym_ids l2 + +-- TODO s_mode not used for now +summarizeAct :: PrettyGuide + -> HS.HashSet Name + -> [Id] + -> ActMarker + -> String +summarizeAct pg ns sym_ids m = case m of + Coinduction cm -> summarizeCoinduction pg ns sym_ids cm + Equality em -> summarizeEquality pg ns sym_ids em + NoObligations s_pair -> summarizeNoObligations pg ns sym_ids s_pair + NotEquivalent s_pair -> summarizeNotEquivalent pg ns sym_ids s_pair + SolverFail s_pair -> summarizeSolverFail pg ns sym_ids s_pair + CycleFound cm -> summarizeCycleFound pg ns sym_ids cm + Unresolved s_pair -> summarizeUnresolved pg ns sym_ids s_pair + +summarizeLemmaMarker :: PrettyGuide + -> HS.HashSet Name + -> [Id] + -> LemmaMarker + -> String +summarizeLemmaMarker pg ns sym_ids lm = case lm of + LemmaProposed l -> summarizeLemmaProposed pg ns sym_ids l + LemmaProven l -> summarizeLemmaProven pg ns sym_ids l + LemmaRejected l -> summarizeLemmaRejected pg ns sym_ids l + LemmaProvenEarly lp -> summarizeLemmaProvenEarly pg ns sym_ids lp + LemmaRejectedEarly lp -> summarizeLemmaRejectedEarly pg ns sym_ids lp + LemmaUnresolved l -> summarizeLemmaUnresolved pg ns sym_ids l + +summarizeHistory :: PrettyGuide -> HS.HashSet Name -> [Id] -> StateH -> String +summarizeHistory pg ns sym_ids = + intercalate "\n" . map (printPG pg ns sym_ids) . reverse . history + +tabsAfterNewLines :: String -> String +tabsAfterNewLines [] = [] +tabsAfterNewLines ('\n':t) = '\n':'\t':(tabsAfterNewLines t) +tabsAfterNewLines (c:t) = c:(tabsAfterNewLines t) + +-- generate the guide for the whole summary externally +summarize :: SummaryMode -> PrettyGuide -> HS.HashSet Name -> [Id] -> Marker -> String +summarize s_mode pg ns sym_ids (Marker (sh1, sh2) m) = + let names1 = map trackName $ (latest sh1):history sh1 + names2 = map trackName $ (latest sh2):history sh2 + in + "***\nLeft Path: " ++ + (intercalate " -> " $ (reverse names1)) ++ + "\nRight Path: " ++ + (intercalate " -> " $ (reverse names2)) ++ "\n" ++ + (if have_history s_mode + then "Left:\n\t" ++ tabsAfterNewLines (summarizeHistory pg ns sym_ids sh1) + ++ "\nRight:\n\t" ++ tabsAfterNewLines (summarizeHistory pg ns sym_ids sh2) ++ "\n" + else "") + ++ + (tabsAfterNewLines $ summarizeAct pg ns sym_ids m) +summarize s_mode pg ns sym_ids (LMarker lm) = + if have_lemma_details s_mode + then "***\n" ++ (tabsAfterNewLines $ summarizeLemmaMarker pg ns sym_ids lm) + else "" + +printDC :: PrettyGuide -> [BlockInfo] -> String -> String +printDC _ [] str = str +printDC pg ((BlockDC d i n):ds) str = + let d_str = DT.unpack $ printHaskellDirtyPG pg $ Data d + str' = "(" ++ printDC pg ds str ++ ")" + pre_blanks = replicate i "_" + post_blanks = replicate (n - (i + 1)) "_" + in intercalate " " $ d_str:(pre_blanks ++ (str':post_blanks)) +printDC pg (_:ds) str = printDC pg ds str + +-- instead of interleaving DCs and lambdas, we handle them separately +-- for lambdas, we wrap applications around the starting exprs +-- earlier list entries represent applications that are farther in +printLams :: PrettyGuide -> + HS.HashSet Name -> + ExprEnv -> + [BlockInfo] -> + String -> + String +printLams _ _ _ [] str = str +printLams pg ns h ((BlockLam i):ds) str = + let arg = inlineVars ns h $ Var i + arg_str = DT.unpack $ printHaskellDirtyPG pg arg + str' = "(" ++ str ++ ") " ++ arg_str + in printLams pg ns h ds str' +printLams pg ns h (_:ds) str = printLams pg ns h ds str + +-- for both cycles and regular counterexamples +printCX :: PrettyGuide -> + HS.HashSet Name -> + [Id] -> + (StateH, StateH) -> + (State t, State t) -> + (StateET, StateET) -> + String -> + String -> + String +printCX pg ns sym_ids (sh1, sh2) (s1, s2) (q1', q2') end1_str end2_str = + let h = expr_env q2' + names1 = map trackName $ (latest sh1):history sh1 + names2 = map trackName $ (latest sh2):history sh2 + e1 = inlineVars ns (expr_env q1') $ getExpr s1 + e1_str = DT.unpack $ printHaskellPG pg q1' e1 + e1_str' = printLams pg ns (expr_env q1') (dc_path $ track q1') e1_str + e2 = inlineVars ns h $ getExpr s2 + e2_str = DT.unpack $ printHaskellPG pg q2' e2 + e2_str' = printLams pg ns (expr_env q2') (dc_path $ track q2') e2_str + cx_str = e1_str' ++ " = " ++ end1_str ++ " but " ++ + e2_str' ++ " = " ++ end2_str + func_ids = map snd $ HM.toList $ higher_order $ track q2' + sym_vars = varsFullList h ns $ sym_ids ++ func_ids + sym_str = printVars pg ns q2' sym_vars + sym_print = case sym_str of + "" -> "" + _ -> "\nMain Symbolic Variables:\n" ++ sym_str + other_vars = varsFull h ns (App (getExpr q1') (getExpr q2')) \\ sym_vars + var_str = printVars pg ns q2' other_vars + var_print = case var_str of + "" -> "" + _ -> "\nOther Variables:\n" ++ var_str + map_str = printMappings pg q2' + map_print = case map_str of + "" -> "" + _ -> "\nSymbolic Function Mappings:\n" ++ map_str + in + "Left Path: " ++ + (intercalate " -> " $ (reverse names1)) ++ + "\nRight Path: " ++ + (intercalate " -> " $ (reverse names2)) ++ "\n" ++ + intercalate "" [cx_str, sym_print, var_print, map_print] + +-- counterexample printing +-- first state pair is initial states, second is from counterexample +showCX :: PrettyGuide -> + HS.HashSet Name -> + [Id] -> + (StateH, StateH) -> + (State t, State t) -> + (StateET, StateET) -> + String +showCX pg ns sym_ids sh_pair s_pair (q1, q2) = + -- main part showing contradiction + let (q1', q2') = syncEnvs q1 q2 + end1 = inlineVars ns (expr_env q1') $ getExpr q1' + end1_str = printDC pg (dc_path $ track q1') . DT.unpack $ printHaskellPG pg q1' end1 + end2 = inlineVars ns (expr_env q2') $ getExpr q2' + end2_str = printDC pg (dc_path $ track q2') . DT.unpack $ printHaskellPG pg q2' end2 + in printCX pg ns sym_ids sh_pair s_pair (q1', q2') end1_str end2_str + +showCycle :: PrettyGuide -> + HS.HashSet Name -> + [Id] -> + (StateH, StateH) -> + (State t, State t) -> + CycleMarker -> + String +showCycle pg ns sym_ids sh_pair s_pair cm = + let (q1, q2) = cycle_real_present cm + (q1', q2') = syncEnvs q1 q2 + end1 = inlineVars ns (expr_env q1') $ getExpr q1' + end1_str = case cycle_side cm of + ILeft -> "{HAS NON-TERMINATING PATH}" + IRight -> printDC pg (dc_path $ track q1') . DT.unpack $ printHaskellPG pg q1' end1 + end2 = inlineVars ns (expr_env q2') $ getExpr q2' + end2_str = case cycle_side cm of + ILeft -> printDC pg (dc_path $ track q2') . DT.unpack $ printHaskellPG pg q2' end2 + IRight -> "{HAS NON-TERMINATING PATH}" + mappings = map swap $ HM.toList $ cycle_mapping cm + mapping_str = intercalate "\n" $ map (printMapping pg) mappings + mapping_print = "\nMapping for Cycle:\n" ++ mapping_str + in + (printCX pg ns sym_ids sh_pair s_pair (q1', q2') end1_str end2_str) ++ mapping_print + +-- type arguments do not contribute to the depth of an expression +-- this takes the opposite side's expression environment into account +exprDepth :: ExprEnv -> ExprEnv -> HS.HashSet Name -> [Name] -> Expr -> Int +exprDepth h h' ns n e = case e of + Tick _ e' -> exprDepth h h' ns n e' + Var i | isSymbolicBoth (idName i) h h' -> 0 + | m <- idName i + , not $ m `elem` ns + , Just e' <- lookupBoth m h h' -> exprDepth h h' ns (m:n) e' + | not $ (idName i) `elem` ns -> error "unmapped variable" + _ | d@(Data (DataCon _ _)):l <- unAppNoTicks e + , not $ null (anonArgumentTypes d) -> + 1 + (maximum $ 0:(map (exprDepth h h' ns n) l)) + | otherwise -> 0 + +getDepth :: StateET -> HS.HashSet Name -> Id -> Int +getDepth s ns i = exprDepth (expr_env s) (opp_env $ track s) ns [] (Var i) + +maxArgDepth :: HS.HashSet Name -> [Id] -> StateET -> Int +maxArgDepth ns sym_ids s = case sym_ids of + [] -> 0 + _ -> maximum $ map (getDepth s ns) sym_ids + +sumArgDepths :: HS.HashSet Name -> [Id] -> StateET -> Int +sumArgDepths ns sym_ids s = foldr (+) 0 $ map (getDepth s ns) sym_ids + +minDepthMetric :: (HS.HashSet Name -> [Id] -> StateET -> Int) -> + HS.HashSet Name -> + [Id] -> + [(StateH, StateH)] -> + Int +minDepthMetric m ns sym_ids states = + let lefts = map (\(sh1, _) -> latest sh1) states + rights = map (\(_, sh2) -> latest sh2) states + (lefts', rights') = unzip $ map (uncurry syncSymbolic) (zip lefts rights) + depths = map (m ns sym_ids) $ lefts' ++ rights' + in case states of + [] -> 0 + _ -> minimum depths + +stateDepthMetric :: (HS.HashSet Name -> [Id] -> StateET -> Int) -> + HS.HashSet Name -> + [Id] -> + (StateH, StateH) -> + Int +stateDepthMetric m ns sym_ids (sh1, sh2) = + let (s1, s2) = syncSymbolic (latest sh1) (latest sh2) + in min (m ns sym_ids s1) (m ns sym_ids s2) + +stateMaxDepth :: HS.HashSet Name -> [Id] -> (StateH, StateH) -> Int +stateMaxDepth = stateDepthMetric maxArgDepth + +stateSumDepths :: HS.HashSet Name -> [Id] -> (StateH, StateH) -> Int +stateSumDepths = stateDepthMetric sumArgDepths + +minMaxDepth :: HS.HashSet Name -> [Id] -> [(StateH, StateH)] -> Int +minMaxDepth = minDepthMetric maxArgDepth + +-- correct to sync beforehand for all these +minSumDepth :: HS.HashSet Name -> [Id] -> [(StateH, StateH)] -> Int +minSumDepth = minDepthMetric sumArgDepths diff --git a/src/G2/Equiv/Tactics.hs b/src/G2/Equiv/Tactics.hs new file mode 100644 --- /dev/null +++ b/src/G2/Equiv/Tactics.hs @@ -0,0 +1,729 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +module G2.Equiv.Tactics + ( module G2.Equiv.Types + , TacticResult (..) + , Tactic + + , Lemmas (..) + + , isSWHNF + , tryEquality + , moreRestrictiveEqual + , tryCoinduction + , checkObligations + , LA.applySolver + , backtrackOne + , syncSymbolic + , A.syncEnvs + + , emptyLemmas + , insertProposedLemma + , proposedLemmas + , replaceProposedLemmas + , insertProvenLemma + , provenLemmas + + , disprovenLemmas + , insertDisprovenLemma + + , A.mkProposedLemma + , checkCycle + ) + where + +import G2.Language + +import qualified Control.Monad.State.Lazy as CM + +import qualified G2.Equiv.Approximation as A +import qualified G2.Language.Approximation as LA +import qualified G2.Language.ExprEnv as E +import G2.Language.Monad.AST +import qualified G2.Language.Typing as T + +import Data.List +import Data.Maybe +import Data.Tuple +import qualified Data.HashSet as HS +import qualified G2.Solver as S + +import qualified G2.Language.PathConds as P + +import G2.Equiv.G2Calls +import G2.Equiv.Types + +import Data.Either +import Data.Either.Extra +import qualified Data.HashMap.Lazy as HM +import Data.Monoid ((<>)) + +import G2.Execution.NormalForms +import Control.Monad.Extra + +import qualified Control.Monad.Writer.Lazy as W + +-- the Bool value for Failure is True if a cycle has been found +data TacticResult = Success + | NoProof [Lemma] + | Failure Bool + +-- this takes a list of fresh names as input +-- equality and coinduction don't need them +-- induction just needs one +-- all tactics now take a lemma count +type Tactic s = s -> + Int -> + HS.HashSet Name -> + Lemmas -> + [Name] -> + (StateH, StateH) -> + (StateET, StateET) -> + W.WriterT [Marker] IO TacticResult + +validTotal :: StateET -> + StateET -> + HS.HashSet Name -> + HM.HashMap Id Expr -> + Bool +validTotal s1 s2 ns hm = + let hm_list = HM.toList hm + total_hs = total_vars $ track s1 + check (i, e) = (not $ (idName i) `elem` total_hs) || (totalExpr s2 ns [] e) + in all check hm_list + +validTypes :: HM.HashMap Id Expr -> Bool +validTypes hm = all (\((Id _ t), e) -> e T..:: t) $ HM.toList hm + +restrictHelper :: StateET -> + StateET -> + HS.HashSet Name -> + Either [Lemma] (HM.HashMap Id Expr, HS.HashSet (Expr, Expr)) -> + Either [Lemma] (HM.HashMap Id Expr, HS.HashSet (Expr, Expr)) +restrictHelper s1 s2 ns hm_hs = + (\(hm, hs) -> if (validTotal s1 s2 ns hm) && (validTypes hm) + then Right (hm, hs) + else Left []) + =<< A.moreRestrictive s1 s2 ns =<< hm_hs + +syncSymbolic :: StateET -> StateET -> (StateET, StateET) +syncSymbolic s1 s2 = + let et1 = (track s1) { opp_env = expr_env s2 } + et2 = (track s2) { opp_env = expr_env s1 } + in (s1 { track = et1 }, s2 { track = et2 }) + +obligationWrap :: HS.HashSet (Expr, Expr) -> Maybe PathCond +obligationWrap obligations = + let obligation_list = HS.toList obligations + eq_list = map (\(e1, e2) -> App (App (Prim Eq TyUnknown) e1) e2) obligation_list + conj = foldr1 (\o1 o2 -> App (App (Prim And TyUnknown) o1) o2) eq_list + in + if null eq_list + then Nothing + else Just $ ExtCond (App (Prim Not TyUnknown) conj) True + +checkObligations :: S.Solver solver => + solver -> + StateET -> + StateET -> + HS.HashSet (Expr, Expr) -> + IO (S.Result () () ()) +checkObligations solver s1 s2 obligation_set | not $ HS.null obligation_set = + case obligationWrap $ modifyASTs stripTicks obligation_set of + Nothing -> LA.applySolver solver P.empty s1 s2 + Just allPO -> LA.applySolver solver (P.insert allPO P.empty) s1 s2 + | otherwise = return $ S.UNSAT () + +-- extra filter on top of isJust for maybe_pairs +-- if restrictHelper end result is Just, try checking the corresponding PCs +-- for True output, there needs to be an entry for which that check succeeds +-- return the previous state pair that was used for the discharge +-- return Nothing if there was no discharge +-- if there are multiple, just return the first +-- first pair is "current," second pair is the match from the past +-- the third entry in a prev triple is the original for left or right +moreRestrictivePair :: S.Solver solver => + solver -> + ((StateET, StateET) -> (StateET, StateET) -> Bool) -> + HS.HashSet Name -> + [(StateET, StateET)] -> + (StateET, StateET) -> + W.WriterT [Marker] IO (Either [Lemma] (PrevMatch EquivTracker)) +moreRestrictivePair solver valid ns prev (s1, s2) | dc_path (track s1) == dc_path (track s2) = do + let (s1', s2') = syncSymbolic s1 s2 + mr (p1, p2) = + if valid (p1, p2) (s1', s2') then + let hm_obs = let (p1', p2') = syncSymbolic p1 p2 + in restrictHelper p2' s2' ns $ + restrictHelper p1' s1' ns (Right (HM.empty, HS.empty)) + hm_obs_ = case hm_obs of + Left lems -> Left $ zip lems [1..length lems] + Right hmo -> Right hmo + in + mapLeft (fmap (\(l, i) -> l { lemma_name = "Lem" ++ show i + ++ " past_1 = " ++ folder p1 + ++ " present_1 = " ++ folder s1 + ++ " past_2 = " ++ folder p2 + ++ " present_2 = " ++ folder s2 })) + $ fmap (\hm_obs' -> PrevMatch (s1, s2) (p1, p2) hm_obs' p2) hm_obs_ + else Left [] + + (possible_lemmas, possible_matches) = partitionEithers $ map mr prev + + folder = folder_name . track + -- As a heuristic, take only lemmas where both sides are not in SWHNF + possible_lemmas' = filter (\(Lemma { lemma_lhs = s1_, lemma_rhs = s2_ }) -> + not (isSWHNF s1_) + && not (isSWHNF s2_)) + $ concat possible_lemmas + + mpc (PrevMatch _ (p1, p2) (hm, _) _) = + andM [LA.moreRestrictivePC solver p1 s1 hm, LA.moreRestrictivePC solver p2 s2 hm] + + possible_matches' <- filterM mpc possible_matches + -- check obligations individually rather than as one big group + res_list <- W.liftIO (findM (\pm -> isUnsat =<< checkObligations solver s1 s2 (snd . conditions $ pm)) (possible_matches')) + return $ maybe (Left possible_lemmas') Right res_list + | otherwise = return $ Left [] + where + isUnsat (S.UNSAT _) = return True + isUnsat _ = return False + +moreRestrictiveSingle :: S.Solver solver => + solver -> + HS.HashSet Name -> + StateET -> + StateET -> + W.WriterT [Marker] IO (Either [Lemma] (HM.HashMap Id Expr)) +moreRestrictiveSingle solver ns s1 s2 = do + case restrictHelper s1 s2 ns $ Right (HM.empty, HS.empty) of + (Left l) -> return $ Left l + Right (hm, obs) -> do + more_res_pc <- LA.moreRestrictivePC solver s1 s2 hm + case more_res_pc of + False -> return $ Left [] + True -> do + obs' <- W.liftIO (checkObligations solver s1 s2 obs) + case obs' of + S.UNSAT _ -> return (Right hm) + _ -> return $ Left [] + +------------------------------------------------------------------------------- +-- Equality +------------------------------------------------------------------------------- + +-- approximation should be the identity map +-- needs to be enforced, won't just happen naturally +moreRestrictiveEqual :: S.Solver solver => + solver -> + Int -> + HS.HashSet Name -> + Lemmas -> + StateET -> + StateET -> + W.WriterT [Marker] IO (Maybe (PrevMatch EquivTracker)) +moreRestrictiveEqual solver num_lems ns lemmas s1 s2 = do + let (s1', s2') = syncSymbolic s1 s2 + if dc_path (track s1') /= dc_path (track s2') then return Nothing + else do + -- no need to enforce dc path condition for this function + pm_maybe <- moreRestrictivePairWithLemmasPast solver num_lems ns lemmas [(s2', s1')] (s1', s2') + case pm_maybe of + Left _ -> return Nothing + Right (_, _, pm@(PrevMatch _ _ (hm, _) _)) -> + if all isIdentity $ HM.toList hm + then return $ Just pm + else return Nothing + where + isIdentity :: (Id, Expr) -> Bool + isIdentity (i1, Tick _ e2) = isIdentity (i1, e2) + isIdentity (i1, (Var i2)) = i1 == i2 + isIdentity _ = False + +-- This tries all of the allowable combinations for equality checking. First +-- it tries matching the left-hand present state with all of the previously +-- encountered right-hand states. If all of those fail, it tries matching the +-- right-hand present state with all of the previously encountered left-hand +-- states. +equalFold :: S.Solver solver => + solver -> + Int -> + HS.HashSet Name -> + Lemmas -> + (StateH, StateH) -> + (StateET, StateET) -> + W.WriterT [Marker] IO (Maybe (PrevMatch EquivTracker)) +equalFold solver num_lems ns lemmas (sh1, sh2) (s1, s2) = do + -- This attempts to find a pair of equal expressions between the left and right + -- sides. The state used for the left side stays constant, but the recursion + -- iterates through all of the states in the right side's history. + let equalFoldL s = firstJustM (moreRestrictiveEqual solver num_lems ns lemmas s) + + pm_l <- equalFoldL s1 (s2:history sh2) + case pm_l of + Just pm -> return $ Just pm + _ -> do + pm_r <- equalFoldL s2 (s1:history sh1) + return $ fmap (\pm -> pm { present = swap $ present pm }) pm_r + +tryEquality :: S.Solver s => Tactic s +tryEquality solver num_lems ns lemmas _ sh_pair (s1, s2) = do + res <- equalFold solver num_lems ns lemmas sh_pair (s1, s2) + case res of + Just pm -> do + W.tell $ [Marker sh_pair $ Equality $ EqualMarker (s1, s2) (present pm)] + return Success + _ -> return (NoProof []) + +------------------------------------------------------------------------------- +-- Coinduction +------------------------------------------------------------------------------- + +-- This attempts to find a past-present combination that works for coinduction. +-- The left-hand present state stays fixed, but the recursion iterates through +-- all of the possible options for the right-hand present state. +coinductionFoldL :: S.Solver solver => + solver -> + Int -> + HS.HashSet Name -> + Lemmas -> + [Lemma] -> + (StateH, StateH) -> + (StateET, StateET) -> + W.WriterT [Marker] IO (Either [Lemma] ([(StateET, Lemma)], [(StateET, Lemma)], PrevMatch EquivTracker)) +coinductionFoldL solver num_lems ns lemmas gen_lemmas (sh1, sh2) (s1, s2) = do + let prev = [(p1, p2) | p1 <- history sh1, p2 <- history sh2] + res <- moreRestrictivePairWithLemmasOnFuncApps solver num_lems validCoinduction ns lemmas prev (s1', s2') + case res of + Right _ -> return res + Left new_lems -> backtrack new_lems + where + (s1', s2') = syncSymbolic s1 s2 + + backtrack new_lems_ = + case backtrackOne sh2 of + Nothing -> return . Left $ new_lems_ ++ gen_lemmas + Just sh2' -> coinductionFoldL solver num_lems ns lemmas + (new_lems_ ++ gen_lemmas) (sh1, sh2') (s1, latest sh2') + +validCoinduction :: (StateET, StateET) -> (StateET, StateET) -> Bool +validCoinduction (p1, p2) (q1, q2) = + let dcp1 = dc_path $ track p1 + dcp2 = dc_path $ track p2 + dcq1 = dc_path $ track q1 + dcq2 = dc_path $ track q2 + consistent = dcp1 == dcp2 && dcq1 == dcq2 + unguarded = all (not . isSWHNF) [p1, p2, q1, q2] + guarded = length dcp1 < length dcq1 + in consistent && (guarded || unguarded) + +backtrackOne :: StateH -> Maybe StateH +backtrackOne sh = + case history sh of + [] -> Nothing + h:t -> Just $ sh { latest = h + , history = t + } + +tryCoinduction :: S.Solver s => Tactic s +tryCoinduction solver num_lems ns lemmas _ (sh1, sh2) (s1, s2) = do + res_l <- coinductionFoldL solver num_lems ns lemmas [] (sh1, sh2) (s1, s2) + case res_l of + Right (lem_l, lem_r, pm) -> do + let cml = CoMarker { + co_real_present = (s1, s2) + , co_used_present = present pm + , co_past = past pm + , lemma_used_left = lem_l + , lemma_used_right = lem_r + } + W.tell [Marker (sh1, sh2) $ Coinduction cml] + return Success + Left l_lemmas -> do + res_r <- coinductionFoldL solver num_lems ns lemmas [] (sh2, sh1) (s2, s1) + case res_r of + Right (lem_l, lem_r, pm) -> do + let cmr = CoMarker { + co_real_present = (s2, s1) + , co_used_present = present pm + , co_past = past pm + , lemma_used_left = lem_l + , lemma_used_right = lem_r + } + W.tell [Marker (sh1, sh2) $ Coinduction $ reverseCoMarker cmr] + return Success + Left r_lemmas -> return . NoProof $ l_lemmas ++ r_lemmas + +------------------------------------------------------------------------------- +-- Lemmas +------------------------------------------------------------------------------- + +data Lemmas = Lemmas { proposed_lemmas :: [ProposedLemma] + , proven_lemmas :: [ProvenLemma] + , disproven_lemmas :: [DisprovenLemma]} + +emptyLemmas :: Lemmas +emptyLemmas = Lemmas [] [] [] + +insertProposedLemma :: S.Solver solver => solver -> HS.HashSet Name -> Lemma -> Lemmas -> W.WriterT [Marker] IO Lemmas +insertProposedLemma solver ns lem lems@(Lemmas { proposed_lemmas = prop_lems + , proven_lemmas = proven_lems + , disproven_lemmas = disproven_lems }) = do + same_as_proposed <- equivLemma solver ns lem prop_lems + implied_by_proven <- moreRestrictiveLemma solver ns lem proven_lems + implies_disproven <- anyM (\dl -> moreRestrictiveLemma solver ns dl [lem]) disproven_lems + case same_as_proposed || implied_by_proven || implies_disproven of + True -> return lems + False -> do + W.tell [LMarker $ LemmaProposed lem] + return lems { proposed_lemmas = lem:prop_lems } + +proposedLemmas :: Lemmas -> [ProposedLemma] +proposedLemmas = proposed_lemmas + +provenLemmas :: Lemmas -> [ProposedLemma] +provenLemmas = proven_lemmas + +disprovenLemmas :: Lemmas -> [ProposedLemma] +disprovenLemmas = disproven_lemmas + +replaceProposedLemmas :: [ProposedLemma] -> Lemmas -> Lemmas +replaceProposedLemmas pl lems = lems { proposed_lemmas = pl } + +-- proactively confirm lemmas implied by this +-- this might be redundant with the verifier's work +insertProvenLemma :: S.Solver solver => + solver + -> HS.HashSet Name + -> Lemmas + -> ProvenLemma + -> W.WriterT [Marker] IO Lemmas +insertProvenLemma solver ns lems lem = do + W.tell [LMarker $ LemmaProven lem] + let prop_lems = proposed_lemmas lems + (extra_proven, still_prop) <- partitionM (\l -> moreRestrictiveLemma solver ns l [lem]) prop_lems + W.tell $ map (\l -> LMarker $ LemmaProvenEarly (lem, l)) extra_proven + return $ lems { + proposed_lemmas = still_prop + , proven_lemmas = lem:(extra_proven ++ proven_lemmas lems) + } + +-- remove lemmas that imply the disproven lemma +-- for every discarded lemma, add a marker +insertDisprovenLemma :: S.Solver solver => + solver + -> HS.HashSet Name + -> Lemmas + -> DisprovenLemma + -> W.WriterT [Marker] IO Lemmas +insertDisprovenLemma solver ns lems lem = do + W.tell [LMarker $ LemmaRejected lem] + -- the one implied is the more specific one + -- the one doing the implying is the more general one + let prop_lems = proposed_lemmas lems + (extra_disproven, still_prop) <- partitionM (\l -> moreRestrictiveLemma solver ns lem [l]) prop_lems + W.tell $ map (\l -> LMarker $ LemmaRejectedEarly (lem, l)) extra_disproven + return $ lems { + proposed_lemmas = still_prop + , disproven_lemmas = lem:(extra_disproven ++ disproven_lemmas lems) + } + +moreRestrictiveLemma :: S.Solver solver => solver -> HS.HashSet Name -> Lemma -> [Lemma] -> W.WriterT [Marker] IO Bool +moreRestrictiveLemma solver ns (Lemma { lemma_lhs = l1_1, lemma_rhs = l1_2 }) lems = do + mr <- moreRestrictivePair solver (\_ _ -> True) ns + (map (\(Lemma { lemma_lhs = l2_1, lemma_rhs = l2_2 }) -> (l2_1, l2_2)) lems) + (l1_1, l1_2) + case mr of + Left _ -> return False + Right _ -> return True + +equivLemma :: S.Solver solver => solver -> HS.HashSet Name -> Lemma -> [Lemma] -> W.WriterT [Marker] IO Bool +equivLemma solver ns (Lemma { lemma_lhs = l1_1, lemma_rhs = l1_2 }) lems = do + anyM (\(Lemma { lemma_lhs = l2_1, lemma_rhs = l2_2 }) -> do + mr1 <- moreRestrictivePair solver (\_ _ -> True) ns [(l2_1, l2_2)] (l1_1, l1_2) + mr2 <- moreRestrictivePair solver (\_ _ -> True) ns [(l1_1, l1_2)] (l2_1, l2_2) + case (mr1, mr2) of + (Right _, Right _) -> return True + _ -> return False) lems + +-- TODO: Does substLemma need to do something more to check correctness of path constraints? +-- `substLemma state lemmas` tries to apply each proven lemma in `lemmas` to `state`. +-- In particular, for each `lemma = (lemma_l `equiv lemma_r` in the proven lemmas, it +-- searches for a subexpression `e'` of `state`'s current expression such that `e' <=_V lemma_l`. +-- If it find such a subexpression, it adds state[e'[V(x)/x]] to the returned +-- list of States. +substLemma :: S.Solver solver => + solver -> + HS.HashSet Name -> + StateET -> + Lemmas -> + W.WriterT [Marker] IO [(Lemma, StateET)] +substLemma solver ns s = + mapMaybeM (\lem -> replaceMoreRestrictiveSubExpr solver ns lem s) . provenLemmas + +-- int counter is a safeguard against divergence +-- optimization: lemmas that go unused in one iteration are removed for +-- the next iteration; lost opportunities possible but not observed yet +substLemmaLoopAux :: S.Solver solver => + Int -> + solver -> + HS.HashSet Name -> + Lemmas -> + [(Lemma, StateET)] -> + StateET -> + W.WriterT [Marker] IO [([(Lemma, StateET)], StateET)] +substLemmaLoopAux 0 _ _ _ _ _ = + return [] +substLemmaLoopAux i solver ns lems past_lems s = do + lem_states <- substLemma solver ns s lems + let lem_states' = map (\(l, s') -> ((l, s):past_lems, s')) lem_states + lems_used = lems { proven_lemmas = nub $ map fst lem_states } + lem_state_lists <- mapM (uncurry (substLemmaLoopAux (i - 1) solver ns lems_used)) lem_states' + return $ lem_states' ++ concat lem_state_lists + +substLemmaLoop :: S.Solver solver => + Int -> + solver -> + HS.HashSet Name -> + StateET -> + Lemmas -> + W.WriterT [Marker] IO [([(Lemma, StateET)], StateET)] +substLemmaLoop i solver ns s lems = substLemmaLoopAux i solver ns lems [] s + +replaceMoreRestrictiveSubExpr :: S.Solver solver => + solver -> + HS.HashSet Name -> + Lemma -> + StateET -> + W.WriterT [Marker] IO (Maybe (Lemma, StateET)) +replaceMoreRestrictiveSubExpr solver ns lemma s@(State { curr_expr = CurrExpr er _ }) = do + let sound = lemmaSound ns s lemma + (e, replaced) <- CM.runStateT (replaceMoreRestrictiveSubExpr' solver ns lemma s sound $ getExpr s) Nothing + case replaced of + Nothing -> return Nothing + Just new_vars -> let new_ids = map fst new_vars + h = foldr E.insertSymbolic (expr_env s) new_ids + new_total = map (idName . fst) $ filter snd new_vars + total' = foldr HS.insert (total_vars $ track s) new_total + track' = (track s) { total_vars = total' } + s' = s { + curr_expr = CurrExpr er e + , expr_env = h + , track = track' + } + in return $ Just (lemma, s') + +{- +If a symbolic variable is on the RHS of a lemma but not the LHS, add it to the +expression environment of the state receiving the substitution. +No need to carry over concretized ones because of inlineEquiv. +Get all of the symbolic IDs that are not in v_rep from the lemma RHS. +Keep track of totality info for variables that get migrated. +If the variable is concrete in one location but symbolic in another, making the +substitution from the symbolic place to the concrete place is still valid. +If it's unmapped, put it in as symbolic. +If it's concrete or symbolic, just leave it as it is. +This implementation does not cover finiteness information. +The Bool argument of this function is used to determine whether a lemma +substitution can be applied soundly at the current location. If an +expression is in FAF with no nested applications of the function at the +outermost layer, substitutions are sound. Any sub-expression of an FAF +expression like this can also receive substitutions soundly. If the +recursion has ever passed through a sub-expression that fits the FAF +format, then the Bool argument carries that information down to lower +recursive calls. +-} +replaceMoreRestrictiveSubExpr' :: S.Solver solver => + solver -> + HS.HashSet Name -> + Lemma -> + StateET -> + Bool -> + Expr -> + CM.StateT (Maybe [(Id, Bool)]) (W.WriterT [Marker] IO) Expr +replaceMoreRestrictiveSubExpr' solver ns lemma@(Lemma { lemma_lhs = lhs_s, lemma_rhs = rhs_s }) + s2 sound e = do + replaced <- CM.get + if isNothing replaced then do + mr_sub <- CM.lift $ moreRestrictiveSingle solver ns lhs_s (s2 { curr_expr = CurrExpr Evaluate e }) + case mr_sub of + Right hm -> do + let v_rep = HM.toList hm + ids_l = E.symbolicIds $ opp_env $ track rhs_s + ids_r = E.symbolicIds $ expr_env rhs_s + ids_both = nub (ids_l ++ ids_r) + new_ids = filter (\(Id n _) -> not (E.member n (expr_env s2) || E.member n (opp_env $ track s2))) ids_both + new_info = map (\(Id n _) -> n `elem` (total_vars $ track rhs_s)) new_ids + + lkp n s = lookupConcOrSymBoth n (expr_env s) (opp_env $ track s) + rhs_e' = A.replaceVars (LA.inlineEquiv lkp rhs_s ns $ getExpr rhs_s) v_rep + CM.put $ Just $ zip new_ids new_info + return rhs_e' + Left _ -> do + let ns' = foldr HS.insert ns (bind e) + sound' = lemmaSound ns' s2 lemma + modifyChildrenM (replaceMoreRestrictiveSubExpr' solver ns' lemma s2 (sound || sound')) e + else return e + where + bind (Lam _ i _) = [idName i] + bind (Case _ i _ as) = idName i:concatMap altBind as + bind (Let b _) = map (idName . fst) b + bind _ = [] + + altBind (Alt (DataAlt _ is) _) = map idName is + altBind _ = [] + +-- This is a looser version of the lemma soundness check from the paper. +-- Instead of checking that the expression receiving the substitution is +-- a suitable function application at the outermost level, we simply look +-- for a sub-expression that fits that mold. Substitutions can only +-- happen within sub-expressions that satisfy the conditions. +-- This is still just as safe as the original soundness check. The +-- original soundness check serves to prevent lemmas from reversing +-- evaluation steps so that a substitution does not trick Nebula into +-- thinking that it has reached a cycle when it has not. If we confirm +-- that evaluation steps are not being reversed within a sub-expression, +-- that same guarantee should extend to the expression as a whole. +lemmaSound :: HS.HashSet Name -> StateET -> Lemma -> Bool +lemmaSound ns s lem = + let lkp n s_ = lookupConcOrSymBoth n (expr_env s_) (opp_env $ track s_) in + case unApp . modifyASTs stripTicks . LA.inlineEquiv lkp s ns $ getExpr s of + Var (Id f _):_ -> + let + lem_vars = varNames $ LA.inlineEquiv lkp s ns $ getExpr (lemma_rhs lem) + in + not $ f `elem` lem_vars + _ -> False + +-- Tries to apply lemmas to expressions only in FAF form, and only if the function being applied can not be +-- called in any way by the lemma. +moreRestrictivePairWithLemmasOnFuncApps :: S.Solver solver => + solver -> + Int -> + ((StateET, StateET) -> (StateET, StateET) -> Bool) -> + HS.HashSet Name -> + Lemmas -> + [(StateET, StateET)] -> + (StateET, StateET) -> + W.WriterT [Marker] IO (Either [Lemma] ([(StateET, Lemma)], [(StateET, Lemma)], PrevMatch EquivTracker)) +moreRestrictivePairWithLemmasOnFuncApps solver num_lems valid ns = + moreRestrictivePairWithLemmas solver num_lems valid ns + +moreRestrictivePairWithLemmas :: S.Solver solver => + solver -> + Int -> + ((StateET, StateET) -> (StateET, StateET) -> Bool) -> + HS.HashSet Name -> + Lemmas -> + [(StateET, StateET)] -> + (StateET, StateET) -> + W.WriterT [Marker] IO (Either [Lemma] ([(StateET, Lemma)], [(StateET, Lemma)], PrevMatch EquivTracker)) +moreRestrictivePairWithLemmas solver num_lems valid ns lemmas past_list (s1, s2) = do + let (s1', s2') = syncSymbolic s1 s2 + xs1 <- substLemmaLoop num_lems solver ns s1' lemmas + xs2 <- substLemmaLoop num_lems solver ns s2' lemmas + + let xs1' = ([], s1'):xs1 + xs2' = ([], s2'):xs2 + pairs = [ (pair1, pair2) | pair1 <- xs1', pair2 <- xs2' ] + + rp <- mapM (\((l1, s1_), (l2, s2_)) -> do + mrp <- moreRestrictivePair solver valid ns past_list (s1_, s2_) + -- the underscore states here are ones with substs applied + let l1' = map swap l1 + let l2' = map swap l2 + return $ fmap (l1', l2', ) mrp) pairs + let (possible_lemmas, possible_matches) = partitionEithers rp + + case possible_matches of + x:_ -> return $ Right x + [] -> return . Left $ concat possible_lemmas + +moreRestrictivePairWithLemmasPast :: S.Solver solver => + solver -> + Int -> + HS.HashSet Name -> + Lemmas -> + [(StateET, StateET)] -> + (StateET, StateET) -> + W.WriterT [Marker] IO (Either [Lemma] ([(StateET, Lemma)], [(StateET, Lemma)], PrevMatch EquivTracker)) +moreRestrictivePairWithLemmasPast solver num_lems ns lemmas past_list s_pair = do + let (past1, past2) = unzip past_list + xs_past1 <- mapM (\(q1, _) -> substLemmaLoop num_lems solver ns q1 lemmas) past_list + xs_past2 <- mapM (\(_, q2) -> substLemmaLoop num_lems solver ns q2 lemmas) past_list + let plain_past1 = map (\s_ -> (Nothing, s_)) past1 + plain_past2 = map (\s_ -> (Nothing, s_)) past2 + xs_past1' = plain_past1 ++ (map (\(l, s) -> (Just l, s)) $ concat xs_past1) + xs_past2' = plain_past2 ++ (map (\(l, s) -> (Just l, s)) $ concat xs_past2) + pair_past (_, p1) (_, p2) = syncSymbolic p1 p2 + past_list' = [pair_past pair1 pair2 | pair1 <- xs_past1', pair2 <- xs_past2'] + moreRestrictivePairWithLemmas solver num_lems (\_ _ -> True) ns lemmas past_list' s_pair + +------------------------------------------------------------------------------- +-- CounterExample Generation +------------------------------------------------------------------------------- + +checkCycle :: S.Solver s => Tactic s +checkCycle solver _ ns _ _ (sh1, sh2) (s1, s2) = do + --W.liftIO $ putStrLn $ "Cycle?" ++ (folder_name $ track s1) ++ (folder_name $ track s2) + let (s1', s2') = syncSymbolic s1 s2 + hist1 = filter (\p -> dc_path (track p) == dc_path (track s1')) $ history sh1 + hist2 = filter (\p -> dc_path (track p) == dc_path (track s2')) $ history sh2 + hist1' = zip hist1 (map expr_env hist2) + hist2' = zip hist2 (map expr_env hist1) + -- histories must have the same length and have matching entries + mr1 <- mapM (\(p1, hp2) -> moreRestrictiveSingle solver ns s1' (p1 { track = (track p1) { opp_env = hp2 } })) hist1' + mr2 <- mapM (\(p2, hp1) -> moreRestrictiveSingle solver ns s2' (p2 { track = (track p2) { opp_env = hp1 } })) hist2' + let vh _ (Left _, _) = False + vh s (Right hm, p) = validHigherOrder s p ns $ Right (hm, HS.empty) + mr1_pairs = zip mr1 hist1 + mr1_pairs' = filter (vh s1') mr1_pairs + mr1_pair = find (isRight . fst) mr1_pairs' + mr2_pairs = zip mr2 hist2 + mr2_pairs' = filter (vh s2') mr2_pairs + mr2_pair = find (isRight . fst) mr2_pairs' + case (isSWHNF s1', isSWHNF s2', mr2_pair) of + (True, False, Just (Right hm, p2)) -> do + W.tell [Marker (sh1, sh2) $ CycleFound $ CycleMarker (s1, s2) p2 hm IRight] + return $ Failure True + _ -> case (isSWHNF s1', isSWHNF s2', mr1_pair) of + (False, True, Just (Right hm, p1)) -> do + W.tell [Marker (sh1, sh2) $ CycleFound $ CycleMarker (s1, s2) p1 hm ILeft] + return $ Failure True + _ -> return $ NoProof [] + +-- This function helps us to avoid certain spurious counterexamples when +-- dealing with symbolic functions. Specifically, it detects apparent +-- counterexamples that are invalid because they map expressions with +-- differently-concretized symbolic function mappings to each other. +validHigherOrder :: StateET -> + StateET -> + HS.HashSet Name -> + Either [Lemma] (HM.HashMap Id Expr, HS.HashSet (Expr, Expr)) -> + Bool +validHigherOrder s1 s2 ns hm_hs | Right (hm, _) <- hm_hs = + let -- empty these to avoid an infinite loop + s1' = s1 { track = (track s1) { higher_order = HM.empty } } + s2' = s2 { track = (track s2) { higher_order = HM.empty } } + -- if the Id isn't present, the mapping isn't relevant + mappings1 = HM.toList $ higher_order $ track s1 + mappings2 = HM.toList $ higher_order $ track s2 + old_pairs = filter (\(_, i) -> (E.member (idName i) (expr_env s1)) || (E.member (idName i) (opp_env $ track s1))) mappings1 + new_pairs = filter (\(_, i) -> (E.member (idName i) (expr_env s2)) || (E.member (idName i) (opp_env $ track s2))) mappings2 + old_states = map (\(e, i) -> (s1' { curr_expr = CurrExpr Evaluate e }, + s1' { curr_expr = CurrExpr Evaluate (Var i) })) old_pairs + new_states = map (\(e, i) -> (s2' { curr_expr = CurrExpr Evaluate e }, + s2' { curr_expr = CurrExpr Evaluate (Var i) })) new_pairs + zipped = [(p, q) | p <- old_states, q <- new_states] + -- only current expressions change between all these states + -- I can keep the other-side expr envs the same + check ((p1, p2), (q1, q2)) = + case restrictHelper p1 q1 ns hm_hs of + Right (hm', hs') -> if HM.size hm' == HM.size hm + then restrictHelper p2 q2 ns (Right (hm', hs')) + else Right (hm', hs') + _ -> hm_hs + in all isRight $ map check zipped + | otherwise = False diff --git a/src/G2/Equiv/Types.hs b/src/G2/Equiv/Types.hs new file mode 100644 --- /dev/null +++ b/src/G2/Equiv/Types.hs @@ -0,0 +1,202 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveDataTypeable #-} + +module G2.Equiv.Types ( module G2.Equiv.Config + , module G2.Equiv.Types + , module G2.Equiv.G2Calls) where + +import G2.Equiv.Config +import G2.Equiv.G2Calls +import G2.Language + +import GHC.Generics (Generic) +import Data.Data (Typeable) +import qualified Data.HashMap.Lazy as HM +import qualified Data.HashSet as HS +import qualified Data.Sequence as DS + + +-- States + +data StateH = StateH { + latest :: StateET + , history :: [StateET] + , discharge :: Maybe StateET + } + deriving (Eq, Generic) + +instance Named StateH where + names (StateH s h d) = + names s DS.>< names h DS.>< names d + rename old new (StateH s h d) = + StateH (rename old new s) (rename old new h) (rename old new d) + +newStateH :: StateET -> StateH +newStateH s = StateH { + latest = s + , history = [] + , discharge = Nothing + } + +-- The container field is only relevant for induction. When the expression for +-- one past state is actually an inner scrutinee of an expression that really +-- was encountered in the past, the container holds the full expression. +data PrevMatch t = PrevMatch { + present :: (State t, State t) + , past :: (State t, State t) + , conditions :: (HM.HashMap Id Expr, HS.HashSet (Expr, Expr)) + , container :: State t +} + +data ActMarker = Coinduction CoMarker + | Equality EqualMarker + | NoObligations (StateET, StateET) + | NotEquivalent (StateET, StateET) + | SolverFail (StateET, StateET) + | CycleFound CycleMarker + | Unresolved (StateET, StateET) + +instance Named ActMarker where + names (Coinduction cm) = names cm + names (Equality em) = names em + names (NoObligations s_pair) = names s_pair + names (NotEquivalent s_pair) = names s_pair + names (SolverFail s_pair) = names s_pair + names (CycleFound cm) = names cm + names (Unresolved s_pair) = names s_pair + rename old new m = case m of + Coinduction cm -> Coinduction $ rename old new cm + Equality em -> Equality $ rename old new em + NoObligations s_pair -> NoObligations $ rename old new s_pair + NotEquivalent s_pair -> NotEquivalent $ rename old new s_pair + SolverFail s_pair -> SolverFail $ rename old new s_pair + CycleFound cm -> CycleFound $ rename old new cm + Unresolved s_pair -> Unresolved $ rename old new s_pair + +data LemmaMarker = LemmaProposed Lemma + | LemmaProven Lemma + | LemmaRejected Lemma + | LemmaProvenEarly (Lemma, Lemma) + | LemmaRejectedEarly (Lemma, Lemma) + | LemmaUnresolved Lemma + +instance Named LemmaMarker where + names (LemmaProposed l) = names l + names (LemmaProven l) = names l + names (LemmaRejected l) = names l + names (LemmaProvenEarly l_pair) = names l_pair + names (LemmaRejectedEarly l_pair) = names l_pair + names (LemmaUnresolved l) = names l + rename old new lm = case lm of + LemmaProposed l -> LemmaProposed $ rename old new l + LemmaProven l -> LemmaProven $ rename old new l + LemmaRejected l -> LemmaRejected $ rename old new l + LemmaProvenEarly lp -> LemmaProvenEarly $ rename old new lp + LemmaRejectedEarly lp -> LemmaRejectedEarly $ rename old new lp + LemmaUnresolved l -> LemmaUnresolved $ rename old new l + +data Marker = Marker (StateH, StateH) ActMarker + | LMarker LemmaMarker + +instance Named Marker where + names (Marker (sh1, sh2) m) = + names sh1 DS.>< names sh2 DS.>< names m + names (LMarker lm) = names lm + rename old new (Marker (sh1, sh2) m) = + Marker (rename old new sh1, rename old new sh2) $ rename old new m + rename old new (LMarker lm) = + LMarker $ rename old new lm + +data Side = ILeft | IRight deriving (Eq, Show, Typeable, Generic) + +data IndMarker = IndMarker { + ind_real_present :: (StateET, StateET) + , ind_used_present :: (StateET, StateET) + , ind_past :: (StateET, StateET) + , ind_result :: (StateET, StateET) + , ind_present_scrutinees :: (Expr, Expr) + , ind_past_scrutinees :: (StateET, StateET) + , ind_side :: Side + , ind_fresh_name :: Name + } + deriving (Eq, Generic) + +-- states paired with lemmas show what the state was before lemma usage +data CoMarker = CoMarker { + co_real_present :: (StateET, StateET) + , co_used_present :: (StateET, StateET) + , co_past :: (StateET, StateET) + , lemma_used_left :: [(StateET, Lemma)] + , lemma_used_right :: [(StateET, Lemma)] +} + +instance Named CoMarker where + names (CoMarker (s1, s2) (q1, q2) (p1, p2) lemma_l lemma_r) = + (DS.><) (names [s1, s2, q1, q2, p1, p2]) ((names lemma_l) DS.>< (names lemma_r)) + rename old new (CoMarker (s1, s2) (q1, q2) (p1, p2) lemma_l lemma_r) = + let r = rename old new + s1' = r s1 + s2' = r s2 + q1' = r q1 + q2' = r q2 + p1' = r p1 + p2' = r p2 + lemma_l' = rename old new lemma_l + lemma_r' = rename old new lemma_r + in CoMarker (s1', s2') (q1', q2') (p1', p2') lemma_l' lemma_r' + +reverseCoMarker :: CoMarker -> CoMarker +reverseCoMarker (CoMarker (s1, s2) (q1, q2) (p1, p2) lemma_l lemma_r) = + CoMarker (s2, s1) (q2, q1) (p2, p1) lemma_r lemma_l + +data EqualMarker = EqualMarker { + eq_real_present :: (StateET, StateET) + , eq_used_present :: (StateET, StateET) +} + +instance Named EqualMarker where + names (EqualMarker (s1, s2) (q1, q2)) = + foldr (DS.><) DS.empty $ map names [s1, s2, q1, q2] + rename old new (EqualMarker (s1, s2) (q1, q2)) = + let r = rename old new + s1' = r s1 + s2' = r s2 + q1' = r q1 + q2' = r q2 + in EqualMarker (s1', s2') (q1', q2') + +-- the indicated side is the one with the cycle +-- cycle_past is the past state that matches the present +data CycleMarker = CycleMarker { + cycle_real_present :: (StateET, StateET) + , cycle_past :: StateET + , cycle_mapping :: HM.HashMap Id Expr + , cycle_side :: Side +} + +instance Named CycleMarker where + names (CycleMarker (s1, s2) p _ _) = + names s1 DS.>< names s2 DS.>< names p + rename old new (CycleMarker (s1, s2) p hm sd) = + let r = rename old new + s1' = r s1 + s2' = r s2 + p' = r p + in CycleMarker (s1', s2') p' hm sd + +data Lemma = Lemma { lemma_name :: String + , lemma_lhs :: StateET + , lemma_rhs :: StateET + , lemma_lhs_origin :: String + , lemma_rhs_origin :: String + , lemma_to_be_proven :: [(StateH, StateH)] } + deriving (Eq, Generic) + +instance Named Lemma where + names (Lemma _ s1 s2 _ _ sh) = names s1 DS.>< names s2 DS.>< names sh + rename old new (Lemma lnm s1 s2 f1 f2 sh) = + Lemma lnm (rename old new s1) (rename old new s2) f1 f2 (rename old new sh) + +type ProposedLemma = Lemma +type ProvenLemma = Lemma +type DisprovenLemma = Lemma diff --git a/src/G2/Equiv/Uninterpreted.hs b/src/G2/Equiv/Uninterpreted.hs new file mode 100644 --- /dev/null +++ b/src/G2/Equiv/Uninterpreted.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE FlexibleContexts, OverloadedStrings #-} + + +module G2.Equiv.Uninterpreted where + +import G2.Language +import qualified G2.Language.ExprEnv as E +import Data.Foldable +import Data.Maybe +import qualified Data.Monoid as DM +import qualified Data.HashMap.Lazy as HM +import qualified Data.HashSet as HS +import Debug.Trace +import qualified Data.Text as T + +-- | Find variables that don't have binding and adjust the epxression environment to treat them as symbolic +addFreeVarsAsSymbolic :: ExprEnv -> ExprEnv +addFreeVarsAsSymbolic eenv = let xs = freeVars eenv eenv + in foldl' (flip E.insertSymbolic) eenv xs + +-- | changing the signature of addFreeTypes so that we have +-- we want to modify the rewrite-rules passed in checkrule +-- (AstContainer c Expr, Astcontainer c Type, AstContainer t Expr, Astcontainer t Type) => c -> State t -> NameGen -> (c, State t, NameGen) +-- | apply subvars to the rule +addFreeTypes :: (ASTContainer c Expr, ASTContainer c Type, ASTContainer t Expr, ASTContainer t Type) => c -> State t -> NameGen -> (c, State t, NameGen) +addFreeTypes c s@(State {type_env = tenv }) ng = + let + (tenv', ng') = freeTypesToTypeEnv (freeTypes tenv s) ng + tenv'' = HM.union tenv tenv' + free_dc = HS.toList $ freeDC tenv'' s + m = dataConMapping free_dc + s' = subVars m s + c' = subVars m c + n_te = addDataCons tenv'' free_dc + in (c', s' { type_env = n_te }, ng' ) + -- trace ("show map " ++ show m) (s' { type_env = n_te }, ng') + + +allDC :: ASTContainer t Expr => t -> HS.HashSet DataCon +allDC = evalASTs allDC' + +allDC' :: Expr -> HS.HashSet DataCon +allDC' e = case e of + Data dc -> HS.singleton dc + Case _ _ _ as -> + HS.fromList $ mapMaybe (\(Alt am _) -> case am of + DataAlt dc _ -> Just dc + _ -> Nothing) as + _ -> HS.empty + + + +freeDC :: ASTContainer e Expr => TypeEnv -> e -> HS.HashSet DataCon +freeDC typeEnv e = + let al = allDC e + inTEnv = HS.map (\(DataCon n _) -> n) + . HS.fromList + . concatMap dataCon + . HM.elems $ typeEnv in + HS.filter (\(DataCon n _) -> not (HS.member n inTEnv)) al + + +allTypes :: ASTContainer t Type => t -> [(Name, Kind)] +allTypes = evalASTs allTypes' + +allTypes' :: Type -> [(Name, Kind)] +allTypes' t = case t of + TyCon n k -> [(n,k)] + _ -> [] + + +freeTypes :: ASTContainer t Type => TypeEnv -> t -> [(Name, Kind)] +freeTypes typeEnv t = HM.toList $ HM.difference (HM.fromList $ allTypes t) typeEnv + + +-- | we getting "free" typesnames and insert it into the TypeEnv with a "uninterprted " dataCons +-- Uninterpreted means there are potentially unlimited amount of datacons for a free type +freeTypesToTypeEnv :: [(Name,Kind)] -> NameGen -> (TypeEnv, NameGen) +freeTypesToTypeEnv nks ng = + let (adts, ng') = mapNG freeTypesToTypeEnv' nks ng + in (HM.fromList adts, ng') + +freeTypesToTypeEnv' :: (Name, Kind) -> NameGen -> ( (Name, AlgDataTy), NameGen) +freeTypesToTypeEnv' (n,k) ng = + let (bids, ng') = freshIds (argumentTypes $ PresType k) ng + (dcs,ng'') = unknownDC ng' n k bids + n_adt = (n, DataTyCon {bound_ids = bids, + data_cons = [dcs]}) + in (n_adt, ng'') + +unknownDC :: NameGen -> Name -> Kind -> [Id] -> (DataCon, NameGen) +unknownDC ng n@(Name occn _ _ _) k is = + let tc = TyCon n k + tv = map TyVar is + ta = foldl' TyApp tc tv + ti = TyLitInt `TyFun` ta + tfa = foldl' (flip TyForAll) ti is + (dc_n, ng') = freshSeededString ("Unknown" DM.<> occn) ng + in (DataCon dc_n tfa, ng') + +-- | add free Datacons into the TypeEnv at the appriorpate Type) +addDataCons :: TypeEnv -> [DataCon] -> TypeEnv +addDataCons = foldl' addDataCon + +addDataCon :: TypeEnv -> DataCon -> TypeEnv +addDataCon te dc | (TyCon n _):_ <- unTyApp $ returnType dc = + let dtc = HM.lookup n te + adt = case dtc of + Just (DataTyCon ids' dcs) -> DataTyCon {bound_ids = ids', data_cons = dc : dcs} + Nothing -> error "addDataCons: cannot find corresponding Name in TypeEnv" + Just _ -> error "addDataCons: Not DataTyCon AlgDataTy found" + in HM.insert n adt te +addDataCon _ _ = error "addDataCon: Type of DataCon had incorrect form" + +-- | addMapping will handle classification between the DataCon and Type +addMapping :: [DataCon] -> ExprEnv -> ExprEnv +addMapping dcs ee = foldl' addMapping' ee dcs + +addMapping' :: ExprEnv -> DataCon -> ExprEnv +addMapping' ee dc@(DataCon name _) = E.insert name (Data dc) ee + + +-- | The translation between GHC and g2 didn't have a matching id for the same occurence name +-- so we are using brute force by matching the same occurence name + +dataConMapping :: [DataCon] -> HM.HashMap (T.Text, Maybe T.Text) DataCon +dataConMapping dcs = HM.fromList $ map dataConMapping' dcs + +dataConMapping' :: DataCon -> ((T.Text, Maybe T.Text ), DataCon) +dataConMapping' dc@(DataCon (Name t mt _ _ ) _ ) = ((t,mt), dc) + +subVars :: ASTContainer t Expr => HM.HashMap (T.Text, Maybe T.Text) DataCon -> t -> t +subVars m = modifyASTs (subVars' m) + +subVars' :: HM.HashMap (T.Text, Maybe T.Text) DataCon -> Expr -> Expr +subVars' m expr@(Var (Id (Name t mt _ _) _ )) = case HM.lookup (t,mt) m of + Just (DataCon n' k) -> Data (DataCon n' k) + Nothing -> expr +subVars' _ expr = expr diff --git a/src/G2/Equiv/Verifier.hs b/src/G2/Equiv/Verifier.hs new file mode 100644 --- /dev/null +++ b/src/G2/Equiv/Verifier.hs @@ -0,0 +1,816 @@ +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} + +module G2.Equiv.Verifier + ( verifyLoop + , checkRule + ) where + +import G2.Language + +import G2.Config + +import G2.Interface + +import qualified Control.Monad.State.Lazy as CM + + +import qualified G2.Language.ExprEnv as E +import qualified G2.Language.CallGraph as G +import qualified G2.Language.Typing as T + +import Data.Maybe +import Data.List +import qualified Data.Text as DT +import qualified Data.Text.IO as DT + +import qualified Data.HashSet as HS +import qualified G2.Solver as S + +import qualified G2.Language.PathConds as P + +import G2.Equiv.InitRewrite +import G2.Equiv.EquivADT +import G2.Equiv.G2Calls +import G2.Equiv.Tactics +import G2.Equiv.Generalize +import G2.Equiv.Summary +import G2.Equiv.Uninterpreted + +import qualified Data.Map as M +import G2.Execution.Memory +import Data.Monoid (Any (..)) + +import qualified G2.Language.Stack as Stck +import Control.Monad + +import G2.Lib.Printers + +-- reader / writer monad source consulted +-- https://mmhaskell.com/monads/reader-writer + +import qualified Control.Monad.Writer.Lazy as W + +import System.IO + +statePairReadyForSolver :: (State t, State t) -> Bool +statePairReadyForSolver (s1, s2) = + let h1 = expr_env s1 + h2 = expr_env s2 + CurrExpr _ e1 = curr_expr s1 + CurrExpr _ e2 = curr_expr s2 + in + exprReadyForSolver h1 e1 && exprReadyForSolver h2 e2 + +exprReadyForSolver :: ExprEnv -> Expr -> Bool +exprReadyForSolver h (Tick _ e) = exprReadyForSolver h e +exprReadyForSolver h (Var i) = E.isSymbolic (idName i) h && T.isPrimType (typeOf i) +exprReadyForSolver h (App f a) = exprReadyForSolver h f && exprReadyForSolver h a +exprReadyForSolver _ (Prim _ _) = True +exprReadyForSolver _ (Lit _) = True +exprReadyForSolver _ _ = False + +-- don't log when the base folder name is empty +logStatesFolder :: String -> LogMode -> LogMode +logStatesFolder pre (Log method n) = Log method $ n ++ "/" ++ pre +logStatesFolder _ NoLog = NoLog + +logStatesET :: String -> LogMode -> String +logStatesET pre (Log _ n) = n ++ "/" ++ pre +logStatesET pre NoLog = "/" ++ pre + +runSymExec :: S.Solver solver => + solver -> + Config -> + NebulaConfig -> + HS.HashSet Name -> + StateET -> + StateET -> + CM.StateT (Bindings, Int) IO [(StateET, StateET)] +runSymExec solver config nc@(NC { sync = sy }) ns s1 s2 = do + (bindings, k) <- CM.get + let config' = config { logStates = logStatesFolder ("a" ++ show k) (log_states nc) } + t1 = (track s1) { folder_name = logStatesET ("a" ++ show k) (log_states nc) } + CurrExpr r1 e1 = curr_expr s1 + e1' = addStackTickIfNeeded ns (expr_env s1) e1 + s1' = s1 { track = t1, curr_expr = CurrExpr r1 e1' } + --CM.liftIO $ putStrLn $ (folder_name $ track s1) ++ " becomes " ++ (folder_name t1) + (er1, bindings') <- CM.lift $ runG2ForNebula solver s1' (expr_env s2) (track s2) config' nc bindings + CM.put (bindings', k + 1) + let final_s1 = map final_state er1 + pairs <- mapM (\s1_ -> do + (b_, k_) <- CM.get + let s2_ = transferInfo sy s1_ (snd $ syncSymbolic s1_ s2) + let config'' = config { logStates = logStatesFolder ("b" ++ show k_) (log_states nc) } + t2 = (track s2_) { folder_name = logStatesET ("b" ++ show k_) (log_states nc) } + CurrExpr r2 e2 = curr_expr s2_ + e2' = addStackTickIfNeeded ns (expr_env s2) e2 + s2' = s2_ { track = t2, curr_expr = CurrExpr r2 e2' } + --CM.liftIO $ putStrLn $ (folder_name $ track s2_) ++ " becomes " ++ (folder_name t2) + (er2, b_') <- CM.lift $ runG2ForNebula solver s2' (expr_env s1_) (track s1_) config'' nc b_ + CM.put (b_', k_ + 1) + return $ map (\er2_ -> + let + s2_' = final_state er2_ + s1_' = transferInfo sy s2_' (snd $ syncSymbolic s2_' s1_) + in + (addStamps k $ prepareState s1_', addStamps k_ $ prepareState s2_') + ) er2) final_s1 + CM.liftIO $ filterM (pathCondsConsistent solver) (concat pairs) + +pathCondsConsistent :: S.Solver solver => + solver -> + (StateET, StateET) -> + IO Bool +pathCondsConsistent solver (s1, s2) = do + res <- applySolver solver P.empty s1 s2 + case res of + S.UNSAT () -> return False + _ -> return True + +-- info goes from left to right for expression environment too +transferInfo :: Bool -> StateET -> StateET -> StateET +transferInfo True s1 s2 = + transferTrackerInfo s1 (s2 { expr_env = expr_env s1 }) +transferInfo False s1 s2 = transferTrackerInfo s1 s2 + +-- Don't share expr env and path constraints between sides +-- info goes from left to right +transferTrackerInfo :: StateET -> StateET -> StateET +transferTrackerInfo s1 s2 = + let t1 = track s1 + t2 = track s2 + t2' = t2 { + higher_order = higher_order t1 + , total_vars = total_vars t1 + --, opp_env = expr_env s1 + } + in s2 { track = t2' } + +frameWrap :: Frame -> Expr -> Expr +frameWrap (CaseFrame i t alts) e = Case e i t alts +frameWrap (ApplyFrame e') e = App e e' +frameWrap (UpdateFrame _) e = e +frameWrap (CastFrame co) e = Cast e co +frameWrap _ _ = error "unsupported frame" + +stackWrap :: Stck.Stack Frame -> Expr -> Expr +stackWrap sk e = + case Stck.pop sk of + Nothing -> e + Just (fr, sk') -> stackWrap sk' $ frameWrap fr e + +loc_name :: Name +loc_name = Name (DT.pack "STACK") Nothing 0 Nothing + +rec_name :: Name +rec_name = Name (DT.pack "REC") Nothing 0 Nothing + +wrapRecursiveCall :: Name -> Expr -> Expr +-- This first case prevents recursive calls from being wrapped twice +wrapRecursiveCall n e@(Tick (NamedLoc n'@(Name t _ _ _)) e') = + if t == DT.pack "REC" + then e + else Tick (NamedLoc n') $ wrapRecursiveCall n e' +wrapRecursiveCall n e@(Var (Id n' _)) = + if n == n' + then Tick (NamedLoc rec_name) e + else wrcHelper n e +wrapRecursiveCall n e = wrcHelper n e + +wrcHelper :: Name -> Expr -> Expr +wrcHelper n e = case e of + Tick (NamedLoc (Name t _ _ _)) _ | t == DT.pack "REC" -> e + _ -> modifyChildren (wrapRecursiveCall n) e + +-- Creating a new expression environment lets us use the existing reachability +-- functions. +-- look inside the bindings and inside the body for recursion +wrapLetRec :: ExprEnv -> Expr -> Expr +wrapLetRec h (Let binds e) = + let binds1 = map (\(i, e_) -> (idName i, e_)) binds + fresh_name = Name (DT.pack "FRESH") Nothing 0 Nothing + h' = foldr (\(n_, e_) h_ -> E.insert n_ e_ h_) h ((fresh_name, e):binds1) + wrap_cg = wrapAllRecursion (G.getCallGraph h') h' + binds2 = map (\(n_, e_) -> (n_, wrap_cg n_ e_)) binds1 + e' = foldr (wrapIfCorecursive (G.getCallGraph h') h' fresh_name) e (map fst binds1) + e'' = wrapLetRec h' $ modifyChildren (wrapLetRec h') e' + binds3 = map ((wrapLetRec h') . modifyChildren (wrapLetRec h')) (map snd binds2) + binds4 = zip (map fst binds) binds3 + in + -- REC tick getting inserted in binds but not in body + -- it's only needed where the recursion actually happens + -- need to apply wrap_cg over it with the new names? + -- wrap_cg with fresh_name won't help because nothing can reach fresh_name + Let binds4 e'' +wrapLetRec h e = modifyChildren (wrapLetRec h) e + +-- first Name is the one that maps to the Expr in the environment +-- second Name is the one that might be wrapped +-- do not allow wrapping for symbolic variables +-- modifyChildren can't see a REC tick that was just inserted above it +wrapIfCorecursive :: G.CallGraph -> ExprEnv -> Name -> Name -> Expr -> Expr +wrapIfCorecursive cg h n m e = + let n_list = G.reachable n cg + m_list = G.reachable m cg + in + if (n `elem` m_list) && (m `elem` n_list) + then + if E.isSymbolic m h + then e + else wrcHelper m (wrapRecursiveCall m e) + else e + +-- the call graph must be based on the given environment +-- the Name must map to the Expr in the environment +wrapAllRecursion :: G.CallGraph -> ExprEnv -> Name -> Expr -> Expr +wrapAllRecursion cg h n e = + let n_list = G.reachable n cg + in + if (not $ E.isSymbolic n h) && (n `elem` n_list) + then foldr (wrapIfCorecursive cg h n) e n_list + else e + +-- stack tick not added here anymore +prepareState :: StateET -> StateET +prepareState s = + let e = getExpr s + in s { + curr_expr = CurrExpr Evaluate $ stackWrap (exec_stack s) $ e + , num_steps = 0 + , rules = [] + , exec_stack = Stck.empty + } + +-- "stamps" for Case statements enforce induction validity +stampName :: Int -> Int -> Name +stampName x k = + Name (DT.pack $ (show x) ++ "STAMP:" ++ (show k)) Nothing 0 Nothing + +-- leave existing stamp ticks unaffected; don't cover them with more layers +-- only stamp strings should contain a colon +insertStamps :: Int -> Int -> Expr -> Expr +insertStamps x k (Tick nl e) = Tick nl (insertStamps x k e) +insertStamps x k (Case e i t a) = + case a of + (Alt am1 a1):as -> case a1 of + Tick (NamedLoc (Name n _ _ _)) _ | str <- DT.unpack n + , ':' `elem` str -> + Case (insertStamps (x + 1) k e) i t a + _ -> let sn = stampName x k + a1' = Alt am1 (Tick (NamedLoc sn) a1) + in Case (insertStamps (x + 1) k e) i t (a1':as) + _ -> error "Empty Alt List" +insertStamps _ _ e = e + +addStamps :: Int -> StateET -> StateET +addStamps k s = + let CurrExpr c e = curr_expr s + e' = insertStamps 0 k e + in s { curr_expr = CurrExpr c e' } + +getLatest :: (StateH, StateH) -> (StateET, StateET) +getLatest (StateH { latest = s1 }, StateH { latest = s2 }) = (s1, s2) + +type NewLemmaTactic solver = String -> String -> Tactic solver + +-- discharge only has a meaningful value when execution is done for a branch +appendH :: StateH -> StateET -> StateH +appendH sh s = + StateH { + latest = s + , history = (latest sh):(history sh) + , discharge = discharge sh + } + +replaceH :: StateH -> StateET -> StateH +replaceH sh s = sh { latest = s } + +allTactics :: S.Solver s => [Tactic s] +allTactics = [ + tryEquality + , tryCoinduction + , generalizeFull + , trySolver + , checkCycle + ] + +allNewLemmaTactics :: S.Solver s => [NewLemmaTactic s] +allNewLemmaTactics = map applyTacticToLabeledStates [tryEquality, tryCoinduction] + +-- negative loop iteration count means there's no limit +-- The (null states) check ensures that we return UNSAT rather than +-- Unknown when states is empty and n = 0. +verifyLoop :: S.Solver solver => + solver -> + Int -> + HS.HashSet Name -> + Lemmas -> + [(StateH, StateH)] -> + Bindings -> + Config -> + NebulaConfig -> + [Id] -> + Int -> + Int -> + W.WriterT [Marker] IO (S.Result () () ()) +verifyLoop solver num_lems ns lemmas states b config nc sym_ids k n | (n /= 0) || (null states) = do + W.liftIO $ putStrLn "" + W.liftIO $ putStrLn $ show n + -- this printing allows our Python script to report depth stats + let min_max_depth = minMaxDepth ns sym_ids states + min_sum_depth = minSumDepth ns sym_ids states + case states of + [] -> return () + _ -> do + W.liftIO $ putStrLn $ "<> " ++ show min_max_depth + W.liftIO $ putStrLn $ "<> " ++ show min_sum_depth + W.liftIO $ hFlush stdout + (b', k', proven, lemmas') <- verifyLoopPropLemmas solver allTactics num_lems ns lemmas b config nc k + + -- W.liftIO $ putStrLn $ "proposed_lemmas: " ++ show (length $ proposed_lemmas lemmas') + -- W.liftIO $ putStrLn $ "proven_lemmas: " ++ show (length $ proven_lemmas lemmas') + -- W.liftIO $ putStrLn $ "continued_lemmas: " ++ show (length continued_lemmas) + -- W.liftIO $ putStrLn $ "disproven_lemmas: " ++ show (length $ disproven_lemmas lemmas') + + (b'', k'', proven', lemmas'') <- verifyLemmasWithNewProvenLemmas solver allNewLemmaTactics num_lems ns proven lemmas' b' config nc k' + (pl_sr, b''') <- verifyWithNewProvenLemmas solver allNewLemmaTactics num_lems ns proven' lemmas'' b'' states + + case pl_sr of + CounterexampleFound -> return $ S.SAT () + Proven -> return $ S.UNSAT () + ContinueWith _ pl_lemmas -> do + (sr, b'''', k''') <- verifyLoopWithSymEx solver allTactics num_lems ns lemmas'' b''' config nc k'' states + case sr of + ContinueWith new_obligations new_lemmas -> do + let n' = if n > 0 then n - 1 else n + --W.liftIO $ putStrLn $ show $ length new_obligations + --W.liftIO $ putStrLn $ "length new_lemmas = " ++ show (length $ pl_lemmas ++ new_lemmas) + + final_lemmas <- foldM (flip (insertProposedLemma solver ns)) + lemmas'' + (pl_lemmas ++ new_lemmas) + verifyLoop solver num_lems ns final_lemmas new_obligations b'''' config nc sym_ids k''' n' + CounterexampleFound -> do + let un l = LMarker $ LemmaUnresolved l + un_lemmas = (proposedLemmas lemmas \\ provenLemmas lemmas) \\ disprovenLemmas lemmas + W.tell $ map un un_lemmas + return $ S.SAT () + Proven -> do + let un l = LMarker $ LemmaUnresolved l + un_lemmas = (proposedLemmas lemmas \\ provenLemmas lemmas) \\ disprovenLemmas lemmas + W.tell $ map un un_lemmas + W.liftIO $ putStrLn $ "proposed = " ++ show (length $ proposedLemmas lemmas) + W.liftIO $ putStrLn $ "proven = " ++ show (length $ provenLemmas lemmas) + W.liftIO $ putStrLn $ "disproven = " ++ show (length $ disprovenLemmas lemmas) + return $ S.UNSAT () + | otherwise = do + W.liftIO $ putStrLn $ "proposed = " ++ show (length $ proposedLemmas lemmas) + W.liftIO $ putStrLn $ "proven = " ++ show (length $ provenLemmas lemmas) + W.liftIO $ putStrLn $ "disproven = " ++ show (length $ disprovenLemmas lemmas) + W.liftIO $ putStrLn $ "Unresolved Obligations: " ++ show (length states) + let ob (sh1, sh2) = Marker (sh1, sh2) $ Unresolved (latest sh1, latest sh2) + un l = LMarker $ LemmaUnresolved l + un_lemmas = (proposedLemmas lemmas \\ provenLemmas lemmas) \\ disprovenLemmas lemmas + W.tell $ map ob states + W.tell $ map un un_lemmas + return $ S.Unknown "Loop Iterations Exhausted" () + +data StepRes = CounterexampleFound + | ContinueWith [(StateH, StateH)] [Lemma] + | Proven + +verifyLoopPropLemmas :: S.Solver solver => + solver + -> [Tactic solver] + -> Int + -> HS.HashSet Name + -> Lemmas + -> Bindings + -> Config + -> NebulaConfig + -> Int + -> (W.WriterT [Marker] IO) (Bindings, Int, [ProvenLemma], Lemmas) +verifyLoopPropLemmas solver tactics num_lems ns lemmas b config nc k = do + let prop_lemmas = proposedLemmas lemmas + verify_lemma = verifyLoopPropLemmas' solver tactics num_lems ns lemmas config nc + (prop_lemmas', (b', k')) <- CM.runStateT (mapM verify_lemma prop_lemmas) (b, k) + + let (proven, continued_lemmas, disproven, new_lemmas) = partitionLemmas ([], [], [], []) prop_lemmas' + lemmas' = replaceProposedLemmas continued_lemmas lemmas + lemmas'' <- foldM (insertProvenLemma solver ns) lemmas' proven + lemmas''' <- foldM (insertDisprovenLemma solver ns) lemmas'' disproven + + lemmas'''' <- foldM (flip (insertProposedLemma solver ns)) + lemmas''' + new_lemmas + + return (b', k', proven, lemmas'''') + where + partitionLemmas (p, c, d, n) ((CounterexampleFound, lem):xs) = partitionLemmas (p, c, lem:d, n) xs + partitionLemmas (p, c, d, n) ((ContinueWith _ new_lem, lem):xs) = partitionLemmas (p, lem:c, d, new_lem ++ n) xs + partitionLemmas (p, c, d, n) ((Proven, lem):xs) = partitionLemmas (lem:p, c, d, n) xs + partitionLemmas r [] = r + +verifyLoopPropLemmas' :: S.Solver solver => + solver + -> [Tactic solver] + -> Int + -> HS.HashSet Name + -> Lemmas + -> Config + -> NebulaConfig + -> ProposedLemma + -> CM.StateT (Bindings, Int) (W.WriterT [Marker] IO) (StepRes, Lemma) +verifyLoopPropLemmas' solver tactics num_lems ns lemmas config nc + l@(Lemma { lemma_to_be_proven = states }) = do + (b, k) <- CM.get + --W.liftIO $ putStrLn $ "k = " ++ show k + --W.liftIO $ putStrLn $ lemma_name l + (sr, b', k') <- W.lift (verifyLoopWithSymEx solver tactics num_lems ns lemmas b config nc k states) + CM.put (b', k') + lem <- case sr of + CounterexampleFound -> {-trace "COUNTEREXAMPLE verifyLemma"-} return $ l { lemma_to_be_proven = [] } + ContinueWith states' _ -> return $ l { lemma_to_be_proven = states' } + Proven -> return $ l { lemma_to_be_proven = [] } + return (sr, lem) + +verifyLoopWithSymEx :: S.Solver solver => + solver + -> [Tactic solver] + -> Int + -> HS.HashSet Name + -> Lemmas + -> Bindings + -> Config + -> NebulaConfig + -> Int + -> [(StateH, StateH)] + -> W.WriterT [Marker] IO (StepRes, Bindings, Int) +verifyLoopWithSymEx solver tactics num_lems ns lemmas b config nc k states = do + let current_states = map getLatest states + (paired_states, (b', k')) <- W.liftIO $ CM.runStateT (mapM (uncurry (runSymExec solver config nc ns)) current_states) (b, k) + + --W.liftIO $ putStrLn "verifyLoopWithSymEx" + -- for every internal list, map with its corresponding original state + let app_pair (sh1, sh2) (s1, s2) = (appendH sh1 s1, appendH sh2 s2) + updated_hists = map (\(s, ps) -> map (app_pair s) ps) $ zip states paired_states + --W.liftIO $ putStrLn $ show $ length $ concat updated_hists + + (res, b'') <- verifyLoop' solver tactics num_lems ns lemmas b' (concat updated_hists) + return (res, b'', k') + +verifyWithNewProvenLemmas :: S.Solver solver => + solver + -> [NewLemmaTactic solver] + -> Int + -> HS.HashSet Name + -> [ProvenLemma] + -> Lemmas + -> Bindings + -> [(StateH, StateH)] + -> W.WriterT [Marker] IO (StepRes, Bindings) +verifyWithNewProvenLemmas solver nl_tactics num_lems ns proven lemmas b states = do + let rel_states = map (\pl -> (lemma_lhs_origin pl, lemma_rhs_origin pl)) proven + tactics = concatMap (\t -> map (uncurry t) rel_states) nl_tactics + verifyLoop' solver tactics num_lems ns lemmas b states + +verifyLemmasWithNewProvenLemmas :: S.Solver solver => + solver + -> [NewLemmaTactic solver] + -> Int + -> HS.HashSet Name + -> [ProvenLemma] + -> Lemmas + -> Bindings + -> Config + -> NebulaConfig + -> Int + -> W.WriterT [Marker] IO (Bindings, Int, [ProvenLemma], Lemmas) +verifyLemmasWithNewProvenLemmas solver nl_tactics num_lems ns proven lemmas b config nc k = do + let rel_states = map (\pl -> (lemma_lhs_origin pl, lemma_rhs_origin pl)) proven + tactics = concatMap (\t -> map (uncurry t) rel_states) nl_tactics + + --W.liftIO $ putStrLn "verifyLemmasWithNewProvenLemmas" + (b', k', new_proven, lemmas') <- + verifyLoopPropLemmas solver tactics num_lems ns lemmas b config nc k + case null new_proven of + True -> return (b', k', proven, lemmas') + False -> + let + proven' = new_proven ++ proven + in + verifyLemmasWithNewProvenLemmas solver nl_tactics num_lems ns proven' lemmas' b' config nc k' + +verifyLoop' :: S.Solver solver => + solver + -> [Tactic solver] + -> Int + -> HS.HashSet Name + -> Lemmas + -> Bindings + -> [(StateH, StateH)] + -> W.WriterT [Marker] IO (StepRes, Bindings) +verifyLoop' solver tactics num_lems ns lemmas b states = do + --W.liftIO $ putStrLn "verifyLoop'" + let (fn1, ng') = freshName (name_gen b) + (fn2, ng'') = freshName ng' + b' = b { name_gen = ng'' } + + td (sh1, sh2) = tryDischarge solver tactics num_lems ns lemmas [fn1, fn2] sh1 sh2 + + proof_lemma_list <- mapM td states + + let new_obligations = concatMap fst $ catMaybes proof_lemma_list + new_lemmas = concatMap snd $ catMaybes proof_lemma_list + + let res = if | null proof_lemma_list -> Proven + | all isJust proof_lemma_list -> ContinueWith new_obligations new_lemmas + | otherwise -> CounterexampleFound + return (res, b') + +applyTacticToLabeledStates :: Tactic solver -> String -> String -> Tactic solver +applyTacticToLabeledStates tactic lbl1 lbl2 solver num_lems ns lemmas fresh_names (sh1, sh2) (s1, s2) + | Just sh1' <- digInStateH lbl1 $ appendH sh1 s1 = + tactic solver num_lems ns lemmas fresh_names (sh1', sh2) (latest sh1', latest sh2) + | Just sh2' <- digInStateH lbl2 $ appendH sh2 s2 = + tactic solver num_lems ns lemmas fresh_names (sh1, sh2') (latest sh1, latest sh2') + | otherwise = return . NoProof $ [] + +digInStateH :: String -> StateH -> Maybe StateH +digInStateH lbl sh + | (folder_name . track $ latest sh) == lbl = Just sh + | Just sh' <- backtrackOne sh = digInStateH lbl sh' + | otherwise = Nothing + +updateDC :: EquivTracker -> [BlockInfo] -> EquivTracker +updateDC et ds = et { dc_path = dc_path et ++ ds } + +-- It is not a problem that this function uses the type variable from only +-- the first lambda. If the two StateET inputs come from corresponding +-- points in symbolic execution, the type variables from the two lambdas +-- must align with each other. +stateWrap :: Name -> StateET -> StateET -> Obligation -> (StateET, StateET) +stateWrap fresh_name s1 s2 (Ob ds e1 e2) = + let ds' = map (\(d, i, n) -> BlockDC d i n) ds + in case (e1, e2) of + (Lam _ (Id _ t) _, Lam _ _ _) -> + let fresh_id = Id fresh_name t + fresh_var = Var fresh_id + s1' = s1 { + curr_expr = CurrExpr Evaluate $ App e1 fresh_var + , track = updateDC (track s1) $ ds' ++ [BlockLam fresh_id] + , expr_env = E.insertSymbolic fresh_id $ expr_env s1 + } + s2' = s2 { + curr_expr = CurrExpr Evaluate $ App e2 fresh_var + , track = updateDC (track s2) $ ds' ++ [BlockLam fresh_id] + , expr_env = E.insertSymbolic fresh_id $ expr_env s2 + } + in (s1', s2') + _ -> ( s1 { curr_expr = CurrExpr Evaluate e1, track = updateDC (track s1) ds' } + , s2 { curr_expr = CurrExpr Evaluate e2, track = updateDC (track s2) ds' } ) + +-- the Bool value for EFail is True if a cycle has been found +data TacticEnd = EFail Bool + | EDischarge + | EContinue [Lemma] (StateH, StateH) + +getRemaining :: TacticEnd -> [(StateH, StateH)] -> [(StateH, StateH)] +getRemaining (EContinue _ sh_pair) acc = sh_pair:acc +getRemaining _ acc = acc + +getLemmas :: TacticEnd -> [Lemma] +getLemmas (EContinue lemmas _) = lemmas +getLemmas _ = [] + +hasFail :: [TacticEnd] -> Bool +hasFail [] = False +hasFail ((EFail _):_) = True +hasFail (_:es) = hasFail es + +hasSolverFail :: [TacticEnd] -> Bool +hasSolverFail [] = False +hasSolverFail ((EFail False):_) = True +hasSolverFail (_:es) = hasSolverFail es + +-- covers all of the solver obligations at once +trySolver :: S.Solver s => Tactic s +trySolver solver _ _ _ _ _ (s1, s2) | statePairReadyForSolver (s1, s2) = do + let e1 = getExpr s1 + e2 = getExpr s2 + res <- W.liftIO $ checkObligations solver s1 s2 (HS.fromList [(e1, e2)]) + case res of + S.UNSAT () -> return Success + _ -> return $ Failure False +trySolver _ _ _ _ _ _ _ = return $ NoProof [] + +-- apply all tactics sequentially in a single run +-- make StateH adjustments between each application, if necessary +-- if Success ever appears, it's done +applyTactics :: S.Solver solver => + solver -> + [Tactic solver] -> + Int -> + HS.HashSet Name -> + Lemmas -> + [Lemma] -> + [Name] -> + (StateH, StateH) -> + (StateET, StateET) -> + W.WriterT [Marker] IO TacticEnd +applyTactics solver (tac:tacs) num_lems ns lemmas gen_lemmas fresh_names (sh1, sh2) (s1, s2) = do + tr <- tac solver num_lems ns lemmas fresh_names (sh1, sh2) (s1, s2) + case tr of + Failure b -> return $ EFail b + NoProof new_lemmas -> applyTactics solver tacs num_lems ns lemmas (new_lemmas ++ gen_lemmas) fresh_names (sh1, sh2) (s1, s2) + Success -> return EDischarge +applyTactics _ _ _ _ _ gen_lemmas _ (sh1, sh2) (s1, s2) = + return $ EContinue gen_lemmas (replaceH sh1 s1, replaceH sh2 s2) + +-- Nothing output means failure +-- fresh_names must have at least two elements +-- the first name is for stateWrap, the second is for the tactics +-- the only tactic left that uses fresh names is generalizeFull +-- still, there may be new tactics in the future that use fresh names +tryDischarge :: S.Solver solver => + solver -> + [Tactic solver] -> + Int -> + HS.HashSet Name -> + Lemmas -> + [Name] -> + StateH -> + StateH -> + W.WriterT [Marker] IO (Maybe ([(StateH, StateH)], [Lemma])) +tryDischarge solver tactics num_lems ns lemmas (fn:fresh_names) sh1 sh2 = + let s1 = latest sh1 + s2 = latest sh2 + in case getObligations ns s1 s2 of + Nothing -> do + W.tell [Marker (sh1, sh2) $ NotEquivalent (s1, s2)] + return Nothing + Just obs -> do + case obs of + [] -> W.tell [Marker (sh1, sh2) $ NoObligations (s1, s2)] + _ -> return () + -- just like with tactics, we only need one fresh name here + let states = map (stateWrap fn s1 s2) obs + res <- mapM (applyTactics solver tactics num_lems ns lemmas [] fresh_names (sh1, sh2)) states + -- list of remaining obligations in StateH form + let res' = foldr getRemaining [] res + new_lemmas = concatMap getLemmas res + if hasFail res then do + if hasSolverFail res + then W.tell [Marker (sh1, sh2) $ SolverFail (s1, s2)] + else return () + return Nothing + else do + return $ Just (res', new_lemmas) +tryDischarge _ _ _ _ _ _ _ _ = error "Need more fresh names" + +getObligations :: HS.HashSet Name -> + State t -> + State t -> + Maybe [Obligation] +getObligations ns s1 s2 = + case proofObligations ns s1 s2 (getExpr s1) (getExpr s2) of + Nothing -> Nothing + Just obs -> Just $ HS.toList obs + +addStackTickIfNeeded :: HS.HashSet Name -> ExprEnv -> Expr -> Expr +addStackTickIfNeeded ns h e' = + let has_tick = getAny . evalASTs (\e -> case e of + Tick (NamedLoc l) _ + | l == loc_name -> Any True + _ -> Any False) $ e' + in if has_tick then e' else tickWrap ns h e' + +tickWrap :: HS.HashSet Name -> ExprEnv -> Expr -> Expr +tickWrap ns h (Var (Id n _)) + | not (n `HS.member` ns) + , Just (E.Conc e) <- E.lookupConcOrSym n h = tickWrap ns h e +tickWrap ns h (Case e i t a) = Case (tickWrap ns h e) i t a +tickWrap ns h (App e1 e2) = App (tickWrap ns h e1) e2 +tickWrap ns h te@(Tick nl e) | not (isLabeledError te) = Tick nl (tickWrap ns h e) +tickWrap _ _ e = Tick (NamedLoc loc_name) e + +includedName :: [DT.Text] -> Name -> Bool +includedName texts (Name t _ _ _) = t `elem` texts + +-- stack tick should appear inside rec tick +startingState :: EquivTracker -> HS.HashSet Name -> State t -> StateH +startingState et ns s = + let h = expr_env s + -- Tick wrapping for recursive and corecursive functions + wrap_cg = wrapAllRecursion (G.getCallGraph h) h + h' = E.map (wrapLetRec h) $ E.mapWithKey wrap_cg h + all_names = E.keys h + s' = s { + track = et + , curr_expr = CurrExpr Evaluate $ tickWrap ns h $ foldr wrap_cg (getExpr s) all_names + , expr_env = h' + } + in newStateH s' + +cleanState :: State t -> Bindings -> (State t, Bindings) +cleanState state bindings = + let sym_config = addSearchNames (input_names bindings) + $ addSearchNames (M.keys $ deepseq_walkers bindings) emptyMemConfig + in markAndSweepPreserving sym_config state bindings + +-- If the Marker list is reversed from how it was when it was fetched, then +-- we're guaranteed to get something that came from the main proof rather than +-- a lemma. Lemma examination happens first within iterations. +writeCX :: [Marker] -> + PrettyGuide -> + HS.HashSet Name -> + [Id] -> + (State t, State t) -> + String +writeCX [] _ _ _ _ = error "No Counterexample" +writeCX ((Marker hist m):ms) pg ns sym_ids init_pair = case m of + NotEquivalent s_pair -> showCX pg ns sym_ids hist init_pair s_pair + SolverFail s_pair -> showCX pg ns sym_ids hist init_pair s_pair + CycleFound cm -> showCycle pg ns sym_ids hist init_pair cm + _ -> writeCX ms pg ns sym_ids init_pair +writeCX (_:ms) pg ns sym_ids init_pair = + writeCX ms pg ns sym_ids init_pair + +-- This function relies on the assumption that, if symbolic execution for +-- the main expression pair hits a counterexample, that counterexample +-- will be the final counterexample in the Marker list (alternatively, the +-- first counterexample in the reversed list that this takes as input). +-- Lemma counterexamples appear in the same list and are not distinguished +-- in any special way, but, in each loop iteration, lemma execution happens +-- before execution on the main expression pair. If the main execution +-- hits a counterexample, the iteration when it happens will be the final +-- loop iteration, so we have an indirect guarantee that the counterexample +-- covered here will not be one from a lemma. +reducedGuide :: [Marker] -> PrettyGuide +reducedGuide [] = error "No Counterexample" +reducedGuide ((Marker _ m):ms) = case m of + NotEquivalent _ -> mkPrettyGuide m + SolverFail _ -> mkPrettyGuide m + CycleFound _ -> mkPrettyGuide m + _ -> reducedGuide ms +reducedGuide (_:ms) = reducedGuide ms + +checkRule :: (ASTContainer t Type, ASTContainer t Expr) => Config + -> NebulaConfig + -> State t + -> Bindings + -> [DT.Text] -- ^ names of forall'd variables required to be total + -> RewriteRule + -> IO (S.Result () () ()) +checkRule config nc init_state bindings total rule = do + let (rule' ,mod_state@(State { expr_env = ee }), te_ng) = addFreeTypes rule init_state (name_gen bindings) + (mod_state', ng') = if symbolic_unmapped nc + then + ( mod_state { expr_env = addFreeVarsAsSymbolic ee } + , te_ng) + else (init_state, name_gen bindings) + (rewrite_state_l, bindings') = initWithLHS mod_state' (bindings { name_gen = ng' }) $ rule' + (rewrite_state_r, bindings'') = initWithRHS mod_state' bindings' $ rule' + sym_ids = ru_bndrs rule' + total_names = filter (includedName total) (map idName sym_ids) + total_hs = foldr HS.insert HS.empty total_names + EquivTracker et m _ _ _ _ = emptyEquivTracker + start_equiv_tracker = EquivTracker et m total_hs [] E.empty "" + -- the keys are the same between the old and new environments + ns_l = HS.fromList $ E.keys $ expr_env rewrite_state_l + ns_r = HS.fromList $ E.keys $ expr_env rewrite_state_r + -- no need for two separate name sets + ns = HS.filter (\n -> not (E.isSymbolic n $ expr_env rewrite_state_l)) $ HS.union ns_l ns_r + e_l = getExpr rewrite_state_l + (rewrite_state_l',_) = cleanState (rewrite_state_l { curr_expr = CurrExpr Evaluate e_l }) bindings + e_r = getExpr rewrite_state_r + (rewrite_state_r',_) = cleanState (rewrite_state_r { curr_expr = CurrExpr Evaluate e_r }) bindings + + rewrite_state_l'' = startingState start_equiv_tracker ns rewrite_state_l' + rewrite_state_r'' = startingState start_equiv_tracker ns rewrite_state_r' + + S.SomeSolver solver <- initSolver config + putStrLn $ "***\n" ++ (show $ ru_name rule) ++ "\n***" + (res, w) <- W.runWriterT $ verifyLoop solver (num_lemmas nc) ns + emptyLemmas + [(rewrite_state_l'', rewrite_state_r'')] + bindings'' config nc sym_ids 0 (limit nc) + let pg = if have_summary $ print_summary nc + then mkPrettyGuide w + else reducedGuide (reverse w) + if have_summary $ print_summary nc then do + putStrLn "--- SUMMARY ---" + _ <- mapM (putStrLn . (summarize (print_summary nc) pg ns sym_ids)) w + putStrLn "--- END OF SUMMARY ---" + else return () + case res of + S.SAT () -> do + putStrLn "--------------------" + putStrLn "COUNTEREXAMPLE FOUND" + putStrLn "--------------------" + putStrLn $ writeCX (reverse w) pg ns sym_ids (rewrite_state_l, rewrite_state_r) + _ -> return () + S.close solver + return res diff --git a/src/G2/Execution/HPC.hs b/src/G2/Execution/HPC.hs new file mode 100644 --- /dev/null +++ b/src/G2/Execution/HPC.hs @@ -0,0 +1,148 @@ +{-# Language FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, + MultiParamTypeClasses, StandaloneDeriving #-} + +-- | Provides infrastructure to track which HPC ticks have been encountered during symbolic execution. +module G2.Execution.HPC ( HpcT + , HpcM + , HpcTracker + , LengthNTrack + + , hpcTracker + , hpcReducer + + , lnt + , lengthNSubpathOrderer) where + +import G2.Execution.Reducer +import G2.Language + +import Control.Monad.Identity +import Control.Monad.IO.Class +import qualified Control.Monad.State.Lazy as SM +import qualified Data.HashSet as HS +import qualified Data.HashMap.Lazy as HM +import Data.Maybe +import Data.Monoid +import qualified Data.Text as T +import System.IO +import System.Clock + +newtype HpcT m a = HpcT (SM.StateT (HS.HashSet (Int, T.Text)) m a) deriving (Functor, Applicative, Monad) + +deriving instance Monad m => (SM.MonadState (HS.HashSet (Int, T.Text)) (HpcT m)) + +type HpcM a = HpcT Identity a + +data HpcTracker = HPC { + hpc_ticks :: HS.HashSet (Int, T.Text) -- ^ The HPC ticks that execution has reached + + , tick_count :: Maybe Int -- ^ Total number of HPC ticks that we could reach. See [HPC Total Tick Count] + , num_reached :: Int -- ^ Total number of HPC ticks currently reached by execution + + , initial_time :: TimeSpec -- ^ The initial creation time of the HpcTracker + , times_reached :: [TimeSpec] -- ^ A list of times, where each time corresponds to a new tick being reached, in reverse order + } + +-- [HPC Total Tick Count] +-- We want to know (as good an approximation as possible of) how many HPC ticks our execution +-- could potentially reach. Knowing this requires the state, after memory cleaning has occurred. +-- +-- Memory cleaning happens after the Reducer has been created, so we want to delay computing the +-- total tick count until execution has begun. But we don't want to repeatedly recompute +-- the total tick count, because this requires scanning the entire state. So instead, +-- we track the total tick count as a `Maybe Int`, which is `Nothing` (if we have not yet computed +-- the total tick count) or `Just i`, where `i` is the total tick count. + +-- | State used by `hpcReducer`. +hpcTracker :: MonadIO m => m HpcTracker +hpcTracker = do + ts <- liftIO $ getTime Monotonic + return $ HPC { hpc_ticks = HS.empty, tick_count = Nothing, num_reached = 0, initial_time = ts, times_reached = [] } + +hpcInsert :: MonadIO m => Int -> T.Text -> HpcTracker -> m HpcTracker +hpcInsert i t hpc@(HPC { hpc_ticks = tr, num_reached = nr, times_reached = reached, initial_time = init_ts }) = + case HS.member (i, t) tr of + True -> return hpc + False -> do + ts <- liftIO $ getTime Monotonic + return $ hpc { hpc_ticks = HS.insert (i, t) tr, num_reached = nr + 1, times_reached = ts:reached } + +totalTickCount :: SM.MonadState HpcTracker m => Maybe T.Text -> State t -> m Int +totalTickCount m s = do + hpc@(HPC { tick_count = ttc }) <- SM.get + case ttc of + Just i -> return i + Nothing -> do + let i = getSum $ evalASTs (countHPCTicks m) (expr_env s) + SM.put $ hpc { tick_count = Just i } + return i + +-- | A reducer that tracks and prints the number of HPC ticks encountered during execution. +hpcReducer :: (MonadIO m, SM.MonadState HpcTracker m) => + Maybe T.Text -- ^ A module to track tick count in + -> Reducer m () t +hpcReducer md = (mkSimpleReducer (const ()) logTick) { afterRed = after } + where + logTick _ s@(State {curr_expr = CurrExpr _ (Tick (HpcTick i tm) _)}) b + | Just tm == md = do + hpc <- SM.get + hpc'@(HPC { num_reached = nr }) <- hpcInsert i tm hpc + SM.put hpc' + hpc_tick_num <- totalTickCount md s + liftIO $ putStr ("\r" ++ show nr ++ " / " ++ show hpc_tick_num) + liftIO $ hFlush stdout + return (NoProgress, [(s, ())], b) + logTick _ s b = return (NoProgress, [(s, ())], b) + + after = do + hpc <- SM.get + let init_ts = initial_time hpc + ts = times_reached hpc + liftIO $ putStrLn $ "\nTicks reached: " ++ show (num_reached hpc) + case ts of + [] -> liftIO $ putStrLn $ "Last tick reached: N/A" + (t:_) -> liftIO $ putStrLn $ "Last tick reached: " ++ showTS (t - init_ts) + +showTS :: TimeSpec -> String +showTS (TimeSpec { sec = s, nsec = n }) = let str_n = show n in show s ++ "." ++ replicate (9 - length str_n) '0' ++ show n + +countHPCTicks :: Maybe T.Text -> Expr -> Sum Int +countHPCTicks m (Tick (HpcTick _ m2) _) | m == Just m2 = Sum 1 +countHPCTicks _ _ = 0 + + +------------------------------------------------------------------------------- +-- Length N Subpaths +------------------------------------------------------------------------------- + +newtype LengthNTrack = LNT { unLNT :: HM.HashMap [(Int, T.Text)] Int } + +-- | State used by `lengthNSubpathOrderer`. +lnt :: LengthNTrack +lnt = LNT HM.empty + +-- | Orders states based on length N subpaths. +-- Each time execution switches states, the state with the least common most +-- recently explored length N subpath is chosen. +-- +-- Based on the paper: +-- Steering Symbolic Execution to Less Traveled Paths +-- You Li, Zhendong Su, Linzhang Wang, Xuandong Li +lengthNSubpathOrderer :: SM.MonadState LengthNTrack m => + Int -- ^ N, the length of the subpaths to track + -> Orderer m [(Int, T.Text)] Int t +lengthNSubpathOrderer n = (mkSimpleOrderer initial order update) { stepOrderer = step } + where + initial _ = [] + + order p _ _ = do + LNT sp <- SM.get + return $ fromMaybe 0 (HM.lookup p sp) + + update p _ _ = p + + step p _ _ (State { curr_expr = CurrExpr _ (Tick (HpcTick i m) _) }) = do + let p' = take n $ (i, m):p + SM.modify (LNT . HM.insertWith (+) p' 1 . unLNT) + return p' + step p _ _ _ = return p diff --git a/src/G2/Execution/Interface.hs b/src/G2/Execution/Interface.hs --- a/src/G2/Execution/Interface.hs +++ b/src/G2/Execution/Interface.hs @@ -11,11 +11,11 @@ import G2.Language.Support {-# INLINE runExecutionToProcessed #-} -runExecutionToProcessed :: (Reducer r rv t, Halter h hv t, Orderer or sov b t) => r -> h -> or -> State t -> Bindings -> IO (Processed (State t), Bindings) +runExecutionToProcessed :: (Monad m, Ord b) => Reducer m rv t -> Halter m hv t -> Orderer m sov b t -> State t -> Bindings -> m (Processed (State t), Bindings) runExecutionToProcessed = runReducer {-# INLINE runExecution #-} -runExecution :: (Reducer r rv t, Halter h hv t, Orderer or sov b t) => r -> h -> or -> State t -> Bindings -> IO ([State t], Bindings) +runExecution :: (Monad m, Ord b) => Reducer m rv t -> Halter m hv t -> Orderer m sov b t -> State t -> Bindings -> m ([State t], Bindings) runExecution r h ord s b = do (pr, b') <- runReducer r h ord s b return (accepted pr, b') diff --git a/src/G2/Execution/Memory.hs b/src/G2/Execution/Memory.hs --- a/src/G2/Execution/Memory.hs +++ b/src/G2/Execution/Memory.hs @@ -1,5 +1,10 @@ +{-# LANGUAGE RankNTypes #-} + module G2.Execution.Memory - ( markAndSweep + ( MemConfig (..) + , emptyMemConfig + , addSearchNames + , markAndSweep , markAndSweepIgnoringKnownValues , markAndSweepPreserving ) where @@ -10,26 +15,55 @@ import qualified G2.Language.ExprEnv as E import G2.Language.Typing +import Data.Foldable import Data.List -import qualified Data.HashSet as S +import qualified Data.HashSet as HS +import qualified Data.HashMap.Lazy as HM import qualified Data.Map as M +import qualified Data.Sequence as S +import Data.Semigroup +type PreservingFunc = forall t . State t -> Bindings -> HS.HashSet Name -> HS.HashSet Name + +data MemConfig = MemConfig { search_names :: [Name] + , pres_func :: PreservingFunc } + | PreserveAllMC + +instance Semigroup MemConfig where + (MemConfig { search_names = sn1, pres_func = pf1 }) <> (MemConfig { search_names = sn2, pres_func = pf2 }) = + MemConfig { search_names = sn1 ++ sn2 + , pres_func = \s b hs -> pf1 s b hs `HS.union` pf2 s b hs} + _ <> _ = PreserveAllMC + +instance Monoid MemConfig where + mempty = MemConfig { search_names = [], pres_func = \ _ _ -> id } + + mappend = (<>) + +emptyMemConfig :: MemConfig +emptyMemConfig = MemConfig { search_names = [], pres_func = \_ _ a -> a } + markAndSweep :: State t -> Bindings -> (State t, Bindings) -markAndSweep s = markAndSweepPreserving [] s +markAndSweep s = markAndSweepPreserving emptyMemConfig s +addSearchNames :: [Name] -> MemConfig -> MemConfig +addSearchNames ns mc@(MemConfig { search_names = ns' }) = mc { search_names = ns ++ ns' } +addSearchNames _ PreserveAllMC = PreserveAllMC + markAndSweepIgnoringKnownValues :: State t -> Bindings -> (State t, Bindings) -markAndSweepIgnoringKnownValues = markAndSweepPreserving' [] +markAndSweepIgnoringKnownValues = markAndSweepPreserving' emptyMemConfig -markAndSweepPreserving :: [Name] -> State t -> Bindings -> (State t, Bindings) -markAndSweepPreserving ns s = markAndSweepPreserving' (ns ++ names (known_values s)) s +markAndSweepPreserving :: MemConfig -> State t -> Bindings -> (State t, Bindings) +markAndSweepPreserving mc s = + markAndSweepPreserving' (toList (names (known_values s)) `addSearchNames` mc) s -markAndSweepPreserving' :: [Name] -> State t -> Bindings -> (State t, Bindings) -markAndSweepPreserving' ns (state@State { expr_env = eenv +markAndSweepPreserving' :: MemConfig -> State t -> Bindings -> (State t, Bindings) +markAndSweepPreserving' PreserveAllMC s b = (s, b) +markAndSweepPreserving' mc (state@State { expr_env = eenv , type_env = tenv , curr_expr = cexpr , path_conds = pc - , symbolic_ids = iids , exec_stack = es }) (bindings@Bindings { deepseq_walkers = dsw , higher_order_inst = inst }) = -- error $ show $ length $ take 20 $ PC.toList path_conds @@ -40,38 +74,41 @@ } bindings' = bindings { deepseq_walkers = dsw'} - active = activeNames tenv eenv S.empty $ names cexpr ++ - names es ++ - names pc ++ - names iids ++ - higher_ord_rel ++ - ns + active = activeNames tenv (E.redirsToExprs eenv) HS.empty $ names cexpr <> + names es <> + names pc <> + names (E.symbolicIds eenv) <> + S.fromList higher_ord_rel <> + S.fromList (search_names mc) + active' = HS.union (pres_func mc state bindings active) active + isActive :: Name -> Bool - isActive = (flip S.member) active + isActive = (flip HS.member) active' eenv' = E.filterWithKey (\n _ -> isActive n) eenv - tenv' = M.filterWithKey (\n _ -> isActive n) tenv + tenv' = HM.filterWithKey (\n _ -> isActive n) tenv dsw' = M.filterWithKey (\n _ -> isActive n) dsw - higher_ord_eenv = E.filterWithKey (\n _ -> n `elem` inst) eenv - higher_ord = map PresType $ nubBy (.::.) $ argTypesTEnv tenv ++ E.higherOrderExprs higher_ord_eenv - higher_ord_rel = E.keys $ E.filter (\e -> any (.:: typeOf e) higher_ord) higher_ord_eenv - -activeNames :: TypeEnv -> ExprEnv -> S.HashSet Name -> [Name] -> S.HashSet Name -activeNames _ _ explored [] = explored -activeNames tenv eenv explored (n:ns) = - if S.member n explored - then activeNames tenv eenv explored ns - else activeNames tenv eenv explored' ns' - where - explored' = S.insert n explored - tenv_hits = case M.lookup n tenv of - Nothing -> [] - Just r -> names r - eenv_hits = case E.lookup n eenv of - Nothing -> [] - Just r -> names r - ns' = tenv_hits ++ eenv_hits ++ ns + higher_ord_eenv = E.filterWithKey (\n _ -> n `HS.member` inst) eenv + higher_ord = nubBy (.::.) $ argTypesTEnv tenv ++ E.higherOrderExprs higher_ord_eenv + higher_ord_rel = E.keys $ E.filter (\e -> any (e .::) higher_ord) higher_ord_eenv +activeNames :: TypeEnv -> ExprEnv -> HS.HashSet Name -> S.Seq Name -> HS.HashSet Name +activeNames tenv eenv explored nss + | n S.:< ns <- S.viewl nss = + let + explored' = HS.insert n explored + tenv_hits = case HM.lookup n tenv of + Nothing -> S.empty + Just r -> names r + eenv_hits = case E.lookup n eenv of + Nothing -> S.empty + Just r -> names r + ns' = tenv_hits <> eenv_hits <> ns + in + if HS.member n explored + then activeNames tenv eenv explored ns + else activeNames tenv eenv explored' ns' + | otherwise = explored diff --git a/src/G2/Execution/NewPC.hs b/src/G2/Execution/NewPC.hs new file mode 100644 --- /dev/null +++ b/src/G2/Execution/NewPC.hs @@ -0,0 +1,49 @@ +module G2.Execution.NewPC ( NewPC (..) + , newPCEmpty + , reduceNewPC ) where + +import G2.Language +import qualified G2.Language.PathConds as PC +import G2.Solver + +import qualified Data.List as L + +data NewPC t = NewPC { state :: State t + , new_pcs :: [PathCond] + , concretized :: [Id] } + +newPCEmpty :: State t -> NewPC t +newPCEmpty s = NewPC { state = s, new_pcs = [], concretized = []} + +reduceNewPC :: (Solver solver, Simplifier simplifier) => solver -> simplifier -> NewPC t -> IO (Maybe (State t)) +reduceNewPC solver simplifier + (NewPC { state = s@(State { path_conds = spc }) + , new_pcs = pc + , concretized = concIds }) + | not (null pc) || not (null concIds) = do + let (s', pc') = L.mapAccumL (simplifyPC simplifier) s pc + pc'' = concat pc' + + + -- Optimization + -- We replace the path_conds with only those that are directly + -- affected by the new path constraints + -- This allows for more efficient solving, and in some cases may + -- change an Unknown into a SAT or UNSAT + let new_pc = foldr PC.insert spc $ pc'' + new_pc' = foldr (simplifyPCs simplifier s') new_pc pc'' + + s'' = s' {path_conds = new_pc'} + + let ns = (concatMap PC.varNamesInPC pc) ++ namesList concIds + rel_pc = case ns of + [] -> PC.fromList pc'' + _ -> PC.scc ns new_pc' + + res <- check solver s' rel_pc + + if res == SAT () then + return $ Just s'' + else + return Nothing + | otherwise = return $ Just s diff --git a/src/G2/Execution/NormalForms.hs b/src/G2/Execution/NormalForms.hs --- a/src/G2/Execution/NormalForms.hs +++ b/src/G2/Execution/NormalForms.hs @@ -3,7 +3,34 @@ import G2.Language import qualified G2.Language.Stack as S import qualified G2.Language.ExprEnv as E +import G2.Language.Typing +import qualified Data.HashSet as HS + +-- A Var counts as being in EVF if it's symbolic or if it's unmapped. +isSWHNF :: State t -> Bool +isSWHNF (State { expr_env = h, curr_expr = CurrExpr _ e }) = + let e' = modifyASTs stripTicks e + t = typeOf e' + in case e' of + Var _ -> (isPrimType t || not (concretizable t)) && isExprValueForm h e' + _ -> isExprValueForm h e' + +stripTicks :: Expr -> Expr +stripTicks (Tick _ e) = e +stripTicks e = e + +-- used by EquivADT and Tactics +concretizable :: Type -> Bool +concretizable (TyVar _) = False +concretizable (TyForAll _ _) = False +concretizable (TyFun _ _) = False +concretizable t@(TyApp _ _) = + concretizable $ last $ unTyApp t +concretizable TYPE = False +concretizable TyUnknown = False +concretizable _ = True + -- | If something is in "value form", then it is essentially ready to be -- returned and popped off the heap. This will be the SSTG equivalent of having -- Return vs Evaluate for the ExecCode of the `State`. @@ -22,11 +49,11 @@ ((Var _):_) -> False _ -> False isExprValueForm _ (Let _ _) = False -isExprValueForm _ (Case _ _ _) = False +isExprValueForm _ (Case _ _ _ _) = False isExprValueForm eenv (Cast e (t :~ _)) = not (hasFuncType t) && isExprValueForm eenv e isExprValueForm _ (Tick _ _) = False isExprValueForm _ (NonDet _) = False -isExprValueForm _ (SymGen _) = False +isExprValueForm _ (SymGen _ _) = False isExprValueForm _ (Assume _ _ _) = False isExprValueForm _ (Assert _ _ _) = False isExprValueForm _ _ = True @@ -44,3 +71,26 @@ isExecValueFormDisNonRedPC :: State t -> Bool isExecValueFormDisNonRedPC s = isExecValueForm $ s {non_red_path_conds = []} + +normalForm :: E.ExprEnv -> Expr -> Bool +normalForm = normalForm' HS.empty + +normalForm' :: HS.HashSet Name -> E.ExprEnv -> Expr -> Bool +normalForm' looked eenv (Var (Id n _)) + | n `HS.member` looked = True + | Just e <- E.lookup n eenv = normalForm' (HS.insert n looked) eenv e + | otherwise = E.isSymbolic n eenv +normalForm' looked eenv (App f a) = case unApp (App f a) of + (Prim _ _:xs) -> all (normalForm' looked eenv) xs + (Data _:xs) -> all (normalForm' looked eenv) xs + ((Var _):_) -> False + _ -> False +normalForm' _ _ (Let _ _) = False +normalForm' _ _ (Case _ _ _ _) = False +normalForm' looked eenv (Cast e (t :~ _)) = not (hasFuncType t) && normalForm' looked eenv e +normalForm' _ _ (Tick _ _) = False +normalForm' _ _ (NonDet _) = False +normalForm' _ _ (SymGen _ _) = False +normalForm' _ _ (Assume _ _ _) = False +normalForm' _ _ (Assert _ _ _) = False +normalForm' _ _ _ = True diff --git a/src/G2/Execution/PrimitiveEval.hs b/src/G2/Execution/PrimitiveEval.hs --- a/src/G2/Execution/PrimitiveEval.hs +++ b/src/G2/Execution/PrimitiveEval.hs @@ -1,88 +1,138 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleContexts #-} -module G2.Execution.PrimitiveEval (evalPrims, evalPrim) where +module G2.Execution.PrimitiveEval (evalPrims, maybeEvalPrim, evalPrimSymbolic) where import G2.Language.AST import G2.Language.Expr +import G2.Language.Naming +import G2.Language.Primitives import G2.Language.Support import G2.Language.Syntax +import G2.Language.Typing -evalPrims :: ASTContainer m Expr => KnownValues -> m -> m -evalPrims kv = modifyContainedASTs (evalPrims' kv . simplifyCasts) +import Control.Exception +import Data.Char +import qualified Data.HashMap.Lazy as M +import qualified Data.List as L +import Data.Maybe +import qualified G2.Language.ExprEnv as E -evalPrim :: KnownValues -> Expr -> Expr -evalPrim kv a@(App _ _) = +evalPrims :: ASTContainer m Expr => TypeEnv -> KnownValues -> m -> m +evalPrims tenv kv = modifyContainedASTs (evalPrims' tenv kv . simplifyCasts) + +evalPrims' :: TypeEnv -> KnownValues -> Expr -> Expr +evalPrims' tenv kv a@(App x y) = case unApp a of - [p@(Prim _ _), l@(Lit _)] -> evalPrim' kv [p, l] - [p@(Prim _ _), l1@(Lit _), l2@(Lit _)] -> evalPrim' kv [p, l1, l2] - _ -> a -evalPrim _ e = e + [p@(Prim _ _), l] -> evalPrim' tenv kv [p, evalPrims' tenv kv l] + [p@(Prim _ _), l1, l2] -> + evalPrim' tenv kv [p, evalPrims' tenv kv l1, evalPrims' tenv kv l2] + _ -> App (evalPrims' tenv kv x) (evalPrims' tenv kv y) +evalPrims' tenv kv e = modifyChildren (evalPrims' tenv kv) e +evalPrim' :: TypeEnv -> KnownValues -> [Expr] -> Expr +evalPrim' tenv kv xs = fromMaybe (mkApp xs) (maybeEvalPrim' tenv kv xs) -evalPrims' :: KnownValues -> Expr -> Expr -evalPrims' kv a@(App x y) = - case unApp a of - [p@(Prim _ _), l] -> evalPrim' kv [p, evalPrims' kv l] - [p@(Prim _ _), l1, l2] -> evalPrim' kv [p, evalPrims' kv l1, evalPrims' kv l2] - _ -> App (evalPrims' kv x) (evalPrims' kv y) -evalPrims' kv e = modifyChildren (evalPrims' kv) e +maybeEvalPrim :: TypeEnv -> KnownValues -> Expr -> Maybe Expr +maybeEvalPrim tenv kv = maybeEvalPrim' tenv kv . unApp -evalPrim' :: KnownValues -> [Expr] -> Expr -evalPrim' kv xs +maybeEvalPrim' :: TypeEnv -> KnownValues -> [Expr] -> Maybe Expr +maybeEvalPrim' tenv kv xs | [Prim p _, x] <- xs - , Lit x' <- getLit x = - case evalPrim1 p x' of - Just e -> e - Nothing -> mkApp xs + , Lit x' <- x + , Just e <- evalPrim1 p x' = Just e + | [Prim p _, x] <- xs + , Lit x' <- x = evalPrim1' tenv kv p x' | [Prim p _, x, y] <- xs - , Lit x' <- getLit x - , Lit y' <- getLit y = - case evalPrim2 kv p x' y' of - Just e -> e - Nothing -> mkApp xs + , Lit x' <- x + , Lit y' <- y = evalPrim2 kv p x' y' - | otherwise = mkApp xs + | [Prim p _, Type t, dc_e] <- xs, Data dc:_ <- unApp dc_e = + evalTypeDCPrim2 tenv p t dc -getLit :: Expr -> Expr -getLit l@(Lit _) = l -getLit x = x + | [Prim p _, Type t, Lit (LitInt l)] <- xs = + evalTypeLitPrim2 tenv p t l + | otherwise = Nothing + evalPrim1 :: Primitive -> Lit -> Maybe Expr evalPrim1 Negate (LitInt x) = Just . Lit $ LitInt (-x) evalPrim1 Negate (LitFloat x) = Just . Lit $ LitFloat (-x) evalPrim1 Negate (LitDouble x) = Just . Lit $ LitDouble (-x) +evalPrim1 Abs (LitInt x) = Just . Lit $ LitInt (abs x) +evalPrim1 Abs (LitFloat x) = Just . Lit $ LitFloat (abs x) +evalPrim1 Abs (LitDouble x) = Just . Lit $ LitDouble (abs x) evalPrim1 SqRt x = evalPrim1Floating (sqrt) x evalPrim1 IntToFloat (LitInt x) = Just . Lit $ LitFloat (fromIntegral x) evalPrim1 IntToDouble (LitInt x) = Just . Lit $ LitDouble (fromIntegral x) +evalPrim1 Chr (LitInt x) = Just . Lit $ LitChar (chr $ fromInteger x) +evalPrim1 OrdChar (LitChar x) = Just . Lit $ LitInt (toInteger $ ord x) +evalPrim1 WGenCat (LitInt x) = Just . Lit $ LitInt (toInteger . fromEnum . generalCategory . toEnum $ fromInteger x) evalPrim1 _ _ = Nothing +evalPrim1' :: TypeEnv -> KnownValues -> Primitive -> Lit -> Maybe Expr +evalPrim1' tenv kv IntToString (LitInt x) = + let + char_dc = mkDCChar kv tenv + in + Just . mkG2List kv tenv TyLitChar . map (App char_dc . Lit . LitChar) $ show x +evalPrim1' _ _ _ _ = Nothing + evalPrim2 :: KnownValues -> Primitive -> Lit -> Lit -> Maybe Expr -evalPrim2 kv Ge x y = evalPrim2NumBool (>=) kv x y -evalPrim2 kv Gt x y = evalPrim2NumBool (>) kv x y -evalPrim2 kv Eq x y = evalPrim2NumBool (==) kv x y -evalPrim2 kv Lt x y = evalPrim2NumBool (<) kv x y -evalPrim2 kv Le x y = evalPrim2NumBool (<=) kv x y +evalPrim2 kv Ge x y = evalPrim2NumCharBool (>=) kv x y +evalPrim2 kv Gt x y = evalPrim2NumCharBool (>) kv x y +evalPrim2 kv Eq x y = evalPrim2NumCharBool (==) kv x y +evalPrim2 kv Lt x y = evalPrim2NumCharBool (<) kv x y +evalPrim2 kv Le x y = evalPrim2NumCharBool (<=) kv x y evalPrim2 _ Plus x y = evalPrim2Num (+) x y evalPrim2 _ Minus x y = evalPrim2Num (-) x y evalPrim2 _ Mult x y = evalPrim2Num (*) x y -evalPrim2 _ Div x y = if isZero y then error "Have Div _ 0" else evalPrim2Fractional (/) x y +evalPrim2 _ Div x y = if isZero y then error "Have Div _ 0" else evalPrim2Fractional (/) x y evalPrim2 _ Quot x y = if isZero y then error "Have Quot _ 0" else evalPrim2Integral quot x y -evalPrim2 _ Mod x y = evalPrim2Integral (mod) x y +evalPrim2 _ Mod x y = evalPrim2Integral mod x y evalPrim2 _ _ _ _ = Nothing +evalTypeDCPrim2 :: TypeEnv -> Primitive -> Type -> DataCon -> Maybe Expr +evalTypeDCPrim2 tenv DataToTag t dc = + case unTyApp t of + TyCon n _:_ | Just adt <- M.lookup n tenv -> + let + dcs = dataCon adt + in + fmap (Lit . LitInt . fst) . L.find ((==) dc . snd) $ zip [1..] dcs + _ -> error "evalTypeDCPrim2: Unsupported Primitive Op" +evalTypeDCPrim2 _ _ _ _ = Nothing + +evalTypeLitPrim2 :: TypeEnv -> Primitive -> Type -> Integer -> Maybe Expr +evalTypeLitPrim2 tenv TagToEnum t i = + case unTyApp t of + TyCon n _:_ | Just adt <- M.lookup n tenv -> + let + dcs = dataCon adt + in + maybe (Just $ Prim Error TyBottom) (Just . Data) + $ ith dcs (fromInteger i) + _ -> error "evalTypeLitPrim2: Unsupported Primitive Op" +evalTypeLitPrim2 _ _ _ _ = Nothing + +ith :: [a] -> Integer -> Maybe a +ith (x:_) 0 = Just x +ith (_:xs) n = assert (n > 0) ith xs (n - 1) +ith _ _ = Nothing + isZero :: Lit -> Bool isZero (LitInt 0) = True isZero (LitFloat 0) = True isZero (LitDouble 0) = True isZero _ = False -evalPrim2NumBool :: (forall a . Ord a => a -> a -> Bool) -> KnownValues -> Lit -> Lit -> Maybe Expr -evalPrim2NumBool f kv (LitInt x) (LitInt y) = Just . mkBool kv $ f x y -evalPrim2NumBool f kv (LitFloat x) (LitFloat y) = Just . mkBool kv $ f x y -evalPrim2NumBool f kv (LitDouble x) (LitDouble y) = Just . mkBool kv $ f x y -evalPrim2NumBool _ _ _ _ = Nothing +evalPrim2NumCharBool :: (forall a . Ord a => a -> a -> Bool) -> KnownValues -> Lit -> Lit -> Maybe Expr +evalPrim2NumCharBool f kv (LitInt x) (LitInt y) = Just . mkBool kv $ f x y +evalPrim2NumCharBool f kv (LitFloat x) (LitFloat y) = Just . mkBool kv $ f x y +evalPrim2NumCharBool f kv (LitDouble x) (LitDouble y) = Just . mkBool kv $ f x y +evalPrim2NumCharBool f kv (LitChar x) (LitChar y) = Just . mkBool kv $ f x y +evalPrim2NumCharBool _ _ _ _ = Nothing evalPrim2Num :: (forall a . Num a => a -> a -> a) -> Lit -> Lit -> Maybe Expr evalPrim2Num f (LitInt x) (LitInt y) = Just . Lit . LitInt $ f x y @@ -103,3 +153,55 @@ evalPrim1Floating f (LitFloat x) = Just . Lit . LitFloat . toRational $ f (fromRational x :: Double) evalPrim1Floating f (LitDouble x) = Just . Lit . LitDouble . toRational $ f (fromRational x :: Double) evalPrim1Floating _ _ = Nothing + +-- | Evaluate certain primitives applied to symbolic expressions, when possible +evalPrimSymbolic :: ExprEnv -> TypeEnv -> NameGen -> KnownValues -> Expr -> Maybe (Expr, ExprEnv, [PathCond], NameGen) +evalPrimSymbolic eenv tenv ng kv e + | [Prim DataToTag _, type_t, cse] <- unApp e + , Type t <- dig eenv type_t + , Case v@(Var (Id n _)) _ _ alts <- cse + , TyCon tn _:_ <- unTyApp t + , Just adt <- M.lookup tn tenv = + let + alt_p = map (\(Alt (LitAlt l) e) -> + let + Data dc = head $ unApp e + in + (l, dc)) alts + + dcs = dataCon adt + num_dcs = zip (map (Lit . LitInt) [0..]) dcs + + (ret, ng') = freshId TyLitInt ng + + new_pc = map (`ExtCond` True) + $ mapMaybe (\(alt_l, alt_dc) -> + fmap (\(nn, n_dc) -> eq v (Lit alt_l) `eq` eq (Var ret) nn) + $ L.find ((==) alt_dc . snd) num_dcs) alt_p + in + Just (Var ret, E.insertSymbolic ret eenv, new_pc, ng') + -- G2 uses actual Bools in primitive comparisons, whereas GHC uses 0# and 1#. + -- We thus need special handling so that, in G2, we don't try to convert to Bool via a TagToEnum + -- (which has type Int# -> a). Instead, we simply return the Bool directly. + | tBool <- tyBool kv + , [Prim TagToEnum _, _, pe] <- unApp e + , typeOf (dig eenv pe) == tBool = Just (pe, eenv, [], ng) + | [Prim TagToEnum _, type_t, pe] <- unApp e + , Type t <- dig eenv type_t = + case unTyApp t of + TyCon n _:_ | Just adt <- M.lookup n tenv -> + let + (b, ng') = freshId TyLitInt ng + dcs = dataCon adt + alts = zipWith (\l dc -> Alt (LitAlt (LitInt l)) (Data dc)) [0..] dcs + alt_d = Alt Default (Prim Error t) + in + Just (Case pe b t (alt_d:alts), E.insertSymbolic b eenv, [], ng') + _ -> error "evalTypeLitPrim2: Unsupported Primitive Op" + | otherwise = Nothing + where + eq e1 = App (App (mkEqPrimType (typeOf e1) kv) e1) + +dig :: ExprEnv -> Expr -> Expr +dig eenv (Var (Id n _)) | Just (E.Conc e) <- E.lookupConcOrSym n eenv = dig eenv e +dig _ e = e diff --git a/src/G2/Execution/Reducer.hs b/src/G2/Execution/Reducer.hs --- a/src/G2/Execution/Reducer.hs +++ b/src/G2/Execution/Reducer.hs @@ -1,933 +1,1341 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE UndecidableInstances #-} - -module G2.Execution.Reducer ( Reducer (..) - , Halter (..) - , Orderer (..) - - , Processed (..) - , mapProcessed - - , ReducerRes (..) - , HaltC (..) - - , SomeReducer (..) - , SomeHalter (..) - , SomeOrderer (..) - - -- Reducers - , RCombiner (..) - , StdRed (..) - , NonRedPCRed (..) - , TaggerRed (..) - , Logger (..) - - , (<~) - , (<~?) - , (<~|) - - -- Halters - , AcceptHalter (..) - , HCombiner (..) - , ZeroHalter (..) - , DiscardIfAcceptedTag (..) - , MaxOutputsHalter (..) - , SwitchEveryNHalter (..) - , BranchAdjSwitchEveryNHalter (..) - , RecursiveCutOff (..) - , VarLookupLimit (..) - , BranchAdjVarLookupLimit (..) - - -- Orderers - , OCombiner (..) - , NextOrderer (..) - , PickLeastUsedOrderer (..) - , BucketSizeOrderer (..) - , CaseCountOrderer (..) - , SymbolicADTOrderer (..) - , ADTHeightOrderer (..) - , IncrAfterN (..) - - , runReducer ) where - -import qualified G2.Language.ExprEnv as E -import G2.Execution.Rules -import G2.Language -import qualified G2.Language.Stack as Stck -import G2.Solver -import G2.Lib.Printers - -import Data.Foldable -import qualified Data.HashSet as S -import qualified Data.HashMap.Strict as HM -import qualified Data.Map as M -import Data.Maybe -import qualified Data.List as L -import System.Directory - --- | Used when applying execution rules --- Allows tracking extra information to control halting of rule application, --- and to reorder states --- see also, the Reducer, Halter, Orderer typeclasses --- cases is used for logging states -data ExState rv hv sov t = ExState { state :: State t - , reducer_val :: rv - , halter_val :: hv - , order_val :: sov - } - --- | Keeps track of type a's that have either been accepted or dropped -data Processed a = Processed { accepted :: [a] - , discarded :: [a] } - -mapProcessed :: (a -> b) -> Processed a -> Processed b -mapProcessed f pr = Processed { accepted = map f (accepted pr) - , discarded = map f (discarded pr)} - --- | Used by Reducers to indicate their progress reducing. -data ReducerRes = NoProgress | InProgress | Finished deriving (Eq, Ord, Show, Read) - -progPrioritizer :: ReducerRes -> ReducerRes -> ReducerRes -progPrioritizer InProgress _ = InProgress -progPrioritizer _ InProgress = InProgress -progPrioritizer Finished _ = Finished -progPrioritizer _ Finished = Finished -progPrioritizer _ _ = NoProgress - --- | Used by members of the Halter typeclass to control whether to continue --- evaluating the current State, or switch to evaluating a new state. -data HaltC = Discard -- ^ Switch to evaluating a new state, and reject the current state - | Accept -- ^ Switch to evaluating a new state, and accept the current state - | Switch -- ^ Switch to evaluating a new state, but continue evaluating the current state later - | Continue -- ^ Continue evaluating the current State - deriving (Eq, Ord, Show, Read) - --- | A Reducer is used to describe a set of Reduction Rules. --- Reduction Rules take a State, and output new states. --- The type parameter r is used to disambiguate between different producers. --- To create a new reducer, define some new type, and use it as r. --- The reducer value, rv, can be used to track special, per Reducer, information. -class Reducer r rv t | r -> rv where - -- | Initialized the reducer value - initReducer :: r -> State t -> rv - - -- | Takes a State, and performs the appropriate Reduction Rule - redRules :: r -> rv -> State t -> Bindings -> IO (ReducerRes, [(State t, rv)], Bindings, r) - - -- | Gives an opportunity to update with all States and Reducer Val's, - -- output by all Reducer's, visible - -- Errors if the returned list is too short. - {-# INLINE updateWithAll #-} - updateWithAll :: r -> [(State t, rv)] -> [rv] - updateWithAll _ = map snd - - --- | Determines when to stop evaluating a state --- The type parameter h is used to disambiguate between different producers. --- To create a new Halter, define some new type, and use it as h. -class Halter h hv t | h -> hv where - -- | Initializes each state halter value - initHalt :: h -> State t -> hv - - -- | Runs whenever we switch to evaluating a different state, - -- to update the halter value of that new state - updatePerStateHalt :: h -> hv -> Processed (State t) -> State t -> hv - - -- | Runs when we start execution on a state, immediately after - -- `updatePerStateHalt`. Allows a State to be discarded right - -- before execution is about to (re-)begin. - -- Return True if execution should proceed, False to discard - discardOnStart :: h -> hv -> Processed (State t) -> State t -> Bool - discardOnStart _ _ _ _ = False - - -- | Determines whether to continue reduction on the current state - stopRed :: h -> hv -> Processed (State t) -> State t -> HaltC - - -- | Takes a state, and updates it's halter record field - stepHalter :: h -> hv -> Processed (State t) -> [State t] -> State t -> hv - --- | Picks an order to evaluate the states, to allow prioritizing some over others --- The type parameter or is used to disambiguate between different producers. --- To create a new reducer, define some new type, and use it as or. -class Ord b => Orderer or sov b t | or -> sov, or -> b where - -- | Initializing the per state ordering value - initPerStateOrder :: or -> State t -> sov - - -- | Assigns each state some value of an ordered type, and then proceeds with execution on the - -- state assigned the minimal value - orderStates :: or -> sov -> State t -> b - - -- | Run on the selected state, to update it's sov field - updateSelected :: or -> sov -> Processed (State t) -> State t -> sov - - -- | Run on the state at each step, to update it's sov field - stepOrderer :: or -> sov -> Processed (State t) -> [State t] -> State t -> sov - stepOrderer _ sov _ _ _ = sov - -data SomeReducer t where - SomeReducer :: forall r rv t . Reducer r rv t => r -> SomeReducer t - -data SomeHalter t where - SomeHalter :: forall h hv t . Halter h hv t => h -> SomeHalter t - -data SomeOrderer t where - SomeOrderer :: forall or sov b t . Orderer or sov b t => or -> SomeOrderer t - --- | Combines reducers in various ways --- updateWithAll is called by all Reducers, regardless of which combinator is used -data RCombiner r1 r2 = r1 :<~ r2 -- ^ Apply r2, followed by r1. Takes the leftmost update to r1 - | r1 :<~? r2 -- ^ Apply r2, apply r1 only if r2 returns NoProgress - | r1 :<~| r2 -- ^ Apply r2, apply r1 only if r2 returns Finished - deriving (Eq, Show, Read) - --- We use RC to combine the reducer values for RCombiner --- We should never define any other instance of Reducer with RC, or export it --- because this could lead to undecidable instances -data RC a b = RC a b - -instance (Reducer r1 rv1 t, Reducer r2 rv2 t) => Reducer (RCombiner r1 r2) (RC rv1 rv2) t where - initReducer (r1 :<~ r2) s = - let - rv1 = initReducer r1 s - rv2 = initReducer r2 s - in - RC rv1 rv2 - initReducer (r1 :<~? r2) s = - let - rv1 = initReducer r1 s - rv2 = initReducer r2 s - in - RC rv1 rv2 - initReducer (r1 :<~| r2) s = - let - rv1 = initReducer r1 s - rv2 = initReducer r2 s - in - RC rv1 rv2 - - redRules (r1 :<~ r2) (RC rv1 rv2) s b = do - (rr2, srv2, b', r2') <- redRules r2 rv2 s b - (rr1, srv1, b'', r1') <- redRulesToStates r1 rv1 srv2 b' - - return (progPrioritizer rr1 rr2, srv1, b'', r1' :<~ r2') - - redRules (r1 :<~? r2) (RC rv1 rv2) s b = do - (rr2, srv2, b', r2') <- redRules r2 rv2 s b - let (s', rv2') = unzip srv2 - - case rr2 of - NoProgress -> do - (rr1, ss, b'', r1') <- redRulesToStates r1 rv1 srv2 b' - return (rr1, ss, b'', r1' :<~? r2') - _ -> return (rr2, zip s' (map (uncurry RC) (zip (repeat rv1) rv2')), b', r1 :<~? r2') - - redRules (r1 :<~| r2) (RC rv1 rv2) s b = do - (rr2, srv2, b', r2') <- redRules r2 rv2 s b - let (s', rv2') = unzip srv2 - - case rr2 of - Finished -> do - (rr1, ss, b'', r1') <- redRulesToStates r1 rv1 srv2 b' - return (rr1, ss, b'', r1' :<~| r2') - _ -> return (rr2, zip s' (map (uncurry RC) (zip (repeat rv1) rv2')), b', r1 :<~| r2') - - updateWithAll (r1 :<~ r2) = updateWithAllRC r1 r2 - updateWithAll (r1 :<~? r2) = updateWithAllRC r1 r2 - updateWithAll (r1 :<~| r2) = updateWithAllRC r1 r2 - -{-# INLINE updateWithAllRC #-} -updateWithAllRC :: (Reducer r1 rv1 t, Reducer r2 rv2 t) => r1 -> r2 -> [(State t, RC rv1 rv2)] -> [RC rv1 rv2] -updateWithAllRC r1 r2 srv = - let - srv1 = map (\(s, RC rv1 _) -> (s, rv1)) srv - srv2 = map (\(s, RC _ rv2) -> (s, rv2)) srv - - rv1' = updateWithAll r1 srv1 - rv2' = updateWithAll r2 srv2 - in - map (uncurry RC) $ zip rv1' rv2' - --- Applies function to first (State t, rv2), gets new Bindings and recursively applies function to rest of array using new Bindings -mapMAccumB :: (Bindings -> (State t, rv2) -> IO (Bindings, (ReducerRes, [(State t, RC rv rv2)], r))) -> Bindings -> [(State t, rv2)] - -> IO (Bindings, [(ReducerRes, [(State t, RC rv rv2)], r)]) -mapMAccumB _ b [] = do - return (b, []) -mapMAccumB f b (x:xs) = do - (b', res) <- f b x - (b'', res2) <- mapMAccumB f b' xs - return $ (b'', res:res2) - -redRulesToStatesAux :: Reducer r rv t => r -> rv -> Bindings -> (State t, rv2) -> IO (Bindings, (ReducerRes, [(State t, RC rv rv2)], r)) -redRulesToStatesAux r rv1 b (is, rv2) = do - (rr_, is', b', r') <- redRules r rv1 is b - return (b', (rr_, map (\(is'', rv1') -> (is'', RC rv1' rv2) ) is', r')) - -redRulesToStates :: Reducer r rv t => r -> rv -> [(State t, rv2)] -> Bindings -> IO (ReducerRes, [(State t, RC rv rv2)], Bindings, r) -redRulesToStates r rv1 s b = do - let redRulesToStatesAux' = redRulesToStatesAux r rv1 - (b', rs) <- mapMAccumB redRulesToStatesAux' b s - - let (rr, s', r') = L.unzip3 rs - - let rf = foldr progPrioritizer NoProgress rr - - return $ (rf, concat s', b', head r') - -{-# INLINE (<~) #-} --- | Combines two @`SomeReducer`@s with a @`:<~`@ -(<~) :: SomeReducer t -> SomeReducer t -> SomeReducer t -SomeReducer r1 <~ SomeReducer r2 = SomeReducer (r1 :<~ r2) - -{-# INLINE (<~?) #-} --- | Combines two @`SomeReducer`@s with a @`:<~?`@ -(<~?) :: SomeReducer t -> SomeReducer t -> SomeReducer t -SomeReducer r1 <~? SomeReducer r2 = SomeReducer (r1 :<~? r2) - -{-# INLINE (<~|) #-} --- | Combines two @`SomeReducer`@s with a @`:<~|`@ -(<~|) :: SomeReducer t -> SomeReducer t -> SomeReducer t -SomeReducer r1 <~| SomeReducer r2 = SomeReducer (r1 :<~| r2) - -data StdRed con = StdRed con - -instance Solver con => Reducer (StdRed con) () t where - initReducer _ _ = () - - redRules stdr@(StdRed solver) _ s b = do - (r, s', b') <- stdReduce solver s b - - return (if r == RuleIdentity then Finished else InProgress, s', b', stdr) - --- | Removes and reduces the values in a State's non_red_path_conds field. -data NonRedPCRed = NonRedPCRed - -instance Reducer NonRedPCRed () t where - initReducer _ _ = () - - redRules nrpr _ s@(State { expr_env = eenv - , curr_expr = cexpr - , exec_stack = stck - , non_red_path_conds = nr:nrs - , symbolic_ids = si - , model = m }) - b@(Bindings { higher_order_inst = inst }) = do - let stck' = Stck.push (CurrExprFrame cexpr) stck - - let cexpr' = CurrExpr Evaluate nr - - let eenv_si_ces = substHigherOrder eenv m si inst cexpr' - - let s' = s { exec_stack = stck' - , non_red_path_conds = nrs - } - xs = map (\(eenv', m', si', ce) -> (s' { expr_env = eenv' - , model = m' - , curr_expr = ce - , symbolic_ids = si' }, ())) eenv_si_ces - - return (InProgress, xs, b, nrpr) - redRules nrpr _ s b = return (Finished, [(s, ())], b, nrpr) - --- [Higher-Order Model] --- Substitutes all possible higher order functions for symbolic higher order functions. --- We insert the substituted higher order function directly into the model, because, due --- to the VAR-RED rule, the function name will (if the function is called) be lost during execution. -substHigherOrder :: ExprEnv -> Model -> SymbolicIds -> [Name] -> CurrExpr -> [(ExprEnv, Model, SymbolicIds, CurrExpr)] -substHigherOrder eenv m si ns ce = - let - is = mapMaybe (\n -> case E.lookup n eenv of - Just e -> Just $ Id n (typeOf e) - Nothing -> Nothing) ns - - higherOrd = filter (isTyFun . typeOf) . mapMaybe varId . symbVars eenv $ ce - higherOrdSub = map (\v -> (v, mapMaybe (genSubstitutable v) is)) higherOrd - in - substHigherOrder' [(eenv, m, si, ce)] higherOrdSub - where - genSubstitutable v i - | (True, bm) <- specializes M.empty (typeOf v )(typeOf i) = - let - bnds = map idName $ leadingTyForAllBindings i - tys = mapMaybe (\b -> fmap Type $ M.lookup b bm) bnds - in - Just . mkApp $ Var i:tys - | otherwise = Nothing - -substHigherOrder' :: [(ExprEnv, Model, SymbolicIds, CurrExpr)] -> [(Id, [Expr])] -> [(ExprEnv, Model, SymbolicIds, CurrExpr)] -substHigherOrder' eenvsice [] = eenvsice -substHigherOrder' eenvsice ((i, es):iss) = - substHigherOrder' - (concatMap (\e_rep -> - map (\(eenv, m, si, ce) -> ( E.insert (idName i) e_rep eenv - , M.insert (idName i) e_rep m - , filter (/= i) si - , replaceASTs (Var i) e_rep ce) - ) eenvsice) - es) iss - -data TaggerRed = TaggerRed Name NameGen - -instance Reducer TaggerRed () t where - initReducer _ _ = () - - redRules tr@(TaggerRed n ng) _ s@(State {tags = ts}) b = - let - (n'@(Name n_ m_ _ _), ng') = freshSeededName n ng - in - if null $ S.filter (\(Name n__ m__ _ _) -> n_ == n__ && m_ == m__) ts then - return (Finished, [(s {tags = S.insert n' ts}, ())], b, TaggerRed n ng') - else - return (Finished, [(s, ())], b, tr) - --- | A Reducer to producer logging output -data Logger = Logger String - -instance Reducer Logger [Int] t where - initReducer _ _ = [] - - redRules l@(Logger fn) li s b = do - outputState fn li s b - return (NoProgress, [(s, li)], b, l) - - updateWithAll _ [(_, l)] = [l] - updateWithAll _ ss = map (\(l, i) -> l ++ [i]) $ zip (map snd ss) [1..] - -outputState :: String -> [Int] -> State t -> Bindings -> IO () -outputState fdn is s b = do - let dir = fdn ++ "/" ++ foldl' (\str i -> str ++ show i ++ "/") "" is - createDirectoryIfMissing True dir - - let fn = dir ++ "state" ++ show (length $ rules s) ++ ".txt" - let write = pprExecStateStr s b - writeFile fn write - - putStrLn fn - - --- | Allows executing multiple halters. --- If the halters disagree, prioritizes the order: --- Discard, Accept, Switch, Continue -data HCombiner h1 h2 = h1 :<~> h2 deriving (Eq, Show, Read) - --- We use C to combine the halter values for HCombiner --- We should never define any other instance of Halter with C, or export it --- because this could lead to undecidable instances -data C a b = C a b - -instance (ASTContainer a Expr, ASTContainer b Expr) => ASTContainer (C a b) Expr where - containedASTs (C a b) = containedASTs a ++ containedASTs b - modifyContainedASTs f (C a b) = C (modifyContainedASTs f a) (modifyContainedASTs f b) - -instance (ASTContainer a Type, ASTContainer b Type) => ASTContainer (C a b) Type where - containedASTs (C a b) = containedASTs a ++ containedASTs b - modifyContainedASTs f (C a b) = C (modifyContainedASTs f a) (modifyContainedASTs f b) - -instance (Named a, Named b) => Named (C a b) where - names (C a b) = names a ++ names b - rename old new (C a b) = C (rename old new a) (rename old new b) - renames hm (C a b) = C (renames hm a) (renames hm b) - -instance (Halter h1 hv1 t, Halter h2 hv2 t) => Halter (HCombiner h1 h2) (C hv1 hv2) t where - initHalt (h1 :<~> h2) s = - let - hv1 = initHalt h1 s - hv2 = initHalt h2 s - in - C hv1 hv2 - - updatePerStateHalt (h1 :<~> h2) (C hv1 hv2) proc s = - let - hv1' = updatePerStateHalt h1 hv1 proc s - hv2' = updatePerStateHalt h2 hv2 proc s - in - C hv1' hv2' - - discardOnStart (h1 :<~> h2) (C hv1 hv2) proc s = - let - b1 = discardOnStart h1 hv1 proc s - b2 = discardOnStart h2 hv2 proc s - in - b1 || b2 - - stopRed (h1 :<~> h2) (C hv1 hv2) proc s = - let - hc1 = stopRed h1 hv1 proc s - hc2 = stopRed h2 hv2 proc s - in - min hc1 hc2 - - stepHalter (h1 :<~> h2) (C hv1 hv2) proc xs s = - let - hv1' = stepHalter h1 hv1 proc xs s - hv2' = stepHalter h2 hv2 proc xs s - in - C hv1' hv2' - --- | Accepts a state when it is in ExecNormalForm -data AcceptHalter = AcceptHalter - -instance Halter AcceptHalter () t where - initHalt _ _ = () - updatePerStateHalt _ _ _ _ = () - stopRed _ _ _ s = - case isExecValueForm s && true_assert s of - True -> Accept - False -> Continue - stepHalter _ _ _ _ _ = () - --- | Allows execution to continue until the step counter hits 0, then discards the state -data ZeroHalter = ZeroHalter Int - -instance Halter ZeroHalter Int t where - initHalt (ZeroHalter n) _ = n - updatePerStateHalt _ hv _ _ = hv - stopRed = halterIsZero - stepHalter = halterSub1 - -halterSub1 :: Halter h Int t => h -> Int -> Processed (State t) -> [State t] -> State t -> Int -halterSub1 _ h _ _ _ = h - 1 - -halterIsZero :: Halter h Int t => h -> Int -> Processed (State t) -> State t -> HaltC -halterIsZero _ 0 _ _ = Discard -halterIsZero _ _ _ _ = Continue - -data MaxOutputsHalter = MaxOutputsHalter (Maybe Int) - -instance Halter MaxOutputsHalter (Maybe Int) t where - initHalt (MaxOutputsHalter m) _ = m - updatePerStateHalt _ hv _ _ = hv - stopRed _ m (Processed {accepted = acc}) _ = - case m of - Just m' -> if length acc >= m' then Discard else Continue - _ -> Continue - stepHalter _ hv _ _ _ = hv - --- | Switch execution every n steps -data SwitchEveryNHalter = SwitchEveryNHalter Int - -instance Halter SwitchEveryNHalter Int t where - initHalt (SwitchEveryNHalter sw) _ = sw - updatePerStateHalt (SwitchEveryNHalter sw) _ _ _ = sw - stopRed _ i _ _ = if i <= 0 then Switch else Continue - stepHalter _ i _ _ _ = i - 1 - --- | Switches execution every n steps, where n is divided every time --- a case split happens, by the number of states. --- That is, if n is 2100, and the case splits into 3 states, each new state will --- will then get only 700 steps -data BranchAdjSwitchEveryNHalter = BranchAdjSwitchEveryNHalter { switch_def :: Int - , switch_min :: Int } - -data SwitchingPerState = SwitchingPerState { switch_at :: Int -- ^ Max number of steps - , counter :: Int -- ^ Current step counter - } - -instance Halter BranchAdjSwitchEveryNHalter SwitchingPerState t where - initHalt (BranchAdjSwitchEveryNHalter { switch_def = sw }) _ = - SwitchingPerState { switch_at = sw, counter = sw } - updatePerStateHalt _ sps@(SwitchingPerState { switch_at = sw }) _ _ = - sps { counter = sw } - stopRed _ (SwitchingPerState { counter = i }) _ _ = - if i <= 0 then Switch else Continue - stepHalter (BranchAdjSwitchEveryNHalter { switch_min = mi }) - sps@(SwitchingPerState { switch_at = sa, counter = i }) _ xs _ = - let - new_sa = max mi (sa `div` length xs) - new_i = min (i - 1) new_sa - in - sps { switch_at = new_sa, counter = new_i} - -data BranchAdjVarLookupLimit = BranchAdjVarLookupLimit { var_switch_def :: Int - , var_switch_min :: Int } - -instance Halter BranchAdjVarLookupLimit SwitchingPerState t where - initHalt (BranchAdjVarLookupLimit { var_switch_def = sw }) _ = - SwitchingPerState { switch_at = sw, counter = sw } - updatePerStateHalt _ sps@(SwitchingPerState { switch_at = sw }) _ _ = - sps { counter = sw } - stopRed _ (SwitchingPerState { counter = i }) _ _ = - if i <= 0 then Switch else Continue - - stepHalter (BranchAdjVarLookupLimit { var_switch_min = mi }) - sps@(SwitchingPerState { switch_at = sa, counter = i }) _ xs - (State { curr_expr = CurrExpr Evaluate (Var _) }) = - let - new_sa = max mi (sa `div` length xs) - new_i = min (i - 1) new_sa - in - sps { switch_at = new_sa, counter = new_i} - stepHalter _ sps _ _ _ = sps - - --- Cutoff recursion after n recursive calls -data RecursiveCutOff = RecursiveCutOff Int - -instance Halter RecursiveCutOff (HM.HashMap SpannedName Int) t where - initHalt _ _ = HM.empty - updatePerStateHalt _ hv _ _ = hv - - stopRed (RecursiveCutOff co) hv _ (State { curr_expr = CurrExpr _ (Var (Id n _)) }) = - case HM.lookup (SpannedName n) hv of - Just i - | i > co -> Discard - | otherwise -> Continue - Nothing -> Continue - stopRed _ _ _ _ = Continue - - stepHalter _ hv _ _ s@(State { curr_expr = CurrExpr _ (Var (Id n _)) }) - | not $ E.isSymbolic n (expr_env s) = - case HM.lookup sn hv of - Just i -> HM.insert sn (i + 1) hv - Nothing -> HM.insert sn 1 hv - | otherwise = hv - where - sn = SpannedName n - stepHalter _ hv _ _ _ = hv - --- | If the Name, disregarding the Unique, in the DiscardIfAcceptedTag --- matches a Tag in the Accepted State list, --- and in the State being evaluated, discard the State -data DiscardIfAcceptedTag = DiscardIfAcceptedTag Name - -instance Halter DiscardIfAcceptedTag (S.HashSet Name) t where - initHalt _ _ = S.empty - - -- updatePerStateHalt gets the intersection of the accepted States Tags, - -- and the Tags of the State being evaluated. - -- Then, it filters further by the name in the Halter - updatePerStateHalt (DiscardIfAcceptedTag (Name n m _ _)) - _ - (Processed {accepted = acc}) - (State {tags = ts}) = - let - allAccTags = S.unions $ map tags acc - matchCurrState = S.intersection ts allAccTags - in - S.filter (\(Name n' m' _ _) -> n == n' && m == m') matchCurrState - - stopRed _ ns _ _ = - if not (S.null ns) then Discard else Continue - - stepHalter _ hv _ _ _ = hv - --- | Counts the number of variable lookups are made, and switches the state --- whenever we've hit a threshold - -data VarLookupLimit = VarLookupLimit Int - -instance Halter VarLookupLimit Int t where - initHalt (VarLookupLimit lim) _ = lim - updatePerStateHalt (VarLookupLimit lim) _ _ _ = lim - stopRed _ lim _ _ = if lim <= 0 then Switch else Continue - - stepHalter _ lim _ _ (State { curr_expr = CurrExpr Evaluate (Var _) }) = lim - 1 - stepHalter _ lim _ _ _ = lim - - --- Orderer things -data OCombiner o1 o2 = o1 :<-> o2 deriving (Eq, Show, Read) - -instance (Orderer or1 sov1 b1 t, Orderer or2 sov2 b2 t) - => Orderer (OCombiner or1 or2) (C sov1 sov2) (b1, b2) t where - - -- | Initializing the per state ordering value - -- initPerStateOrder :: or -> State t -> sov - initPerStateOrder (or1 :<-> or2) s = - let - sov1 = initPerStateOrder or1 s - sov2 = initPerStateOrder or2 s - in - C sov1 sov2 - - -- | Assigns each state some value of an ordered type, and then proceeds with execution on the - -- state assigned the minimal value - -- orderStates :: or -> sov -> State t -> b - orderStates (or1 :<-> or2) (C sov1 sov2) s = - let - sov1' = orderStates or1 sov1 s - sov2' = orderStates or2 sov2 s - in - (sov1', sov2') - - -- | Run on the selected state, to update it's sov field - -- updateSelected :: or -> sov -> Processed (State t) -> State t -> sov - updateSelected (or1 :<-> or2) (C sov1 sov2) proc s = - let - sov1' = updateSelected or1 sov1 proc s - sov2' = updateSelected or2 sov2 proc s - in - C sov1' sov2' - - stepOrderer (or1 :<-> or2) (C sov1 sov2) proc xs s = - let - sov1' = stepOrderer or1 sov1 proc xs s - sov2' = stepOrderer or2 sov2 proc xs s - in - C sov1' sov2' - - -data NextOrderer = NextOrderer - -instance Orderer NextOrderer () Int t where - initPerStateOrder _ _ = () - orderStates _ _ _ = 0 - updateSelected _ v _ _ = v - --- | Continue execution on the state that has been picked the least in the past. -data PickLeastUsedOrderer = PickLeastUsedOrderer - -instance Orderer PickLeastUsedOrderer Int Int t where - initPerStateOrder _ _ = 0 - orderStates _ v _ = v - updateSelected _ v _ _ = v + 1 - --- | Floors and does bucket size -data BucketSizeOrderer = BucketSizeOrderer Int - -instance Orderer BucketSizeOrderer Int Int t where - initPerStateOrder _ _ = 0 - - orderStates (BucketSizeOrderer b) v _ = floor (fromIntegral v / fromIntegral b :: Float) - - updateSelected _ v _ _ = v + 1 - --- | Order by the number of PCs -data CaseCountOrderer = CaseCountOrderer - -instance Orderer CaseCountOrderer Int Int t where - initPerStateOrder _ _ = 0 - - orderStates _ v _ = v - - updateSelected _ v _ _ = v - - stepOrderer _ v _ _ (State { curr_expr = CurrExpr _ (Case _ _ _) }) = v + 1 - stepOrderer _ v _ _ _ = v - - --- Orders by the smallest symbolic ADTs -data SymbolicADTOrderer = SymbolicADTOrderer - -instance Orderer SymbolicADTOrderer (S.HashSet Name) Int t where - initPerStateOrder _ = S.fromList . map idName . symbolic_ids - orderStates _ v _ = S.size v - - updateSelected _ v _ _ = v - - stepOrderer _ v _ _ s = - v `S.union` (S.fromList . map idName . symbolic_ids $ s) - --- Orders by the largest (in terms of height) (previously) symbolic ADT -data ADTHeightOrderer = ADTHeightOrderer - -instance Orderer ADTHeightOrderer (S.HashSet Name) Int t where - initPerStateOrder _ = S.fromList . map idName . symbolic_ids - orderStates _ v s = maximum . S.toList $ S.map (flip adtHeight s) v - - updateSelected _ v _ _ = v - - -- stepOrderer _ v _ _ s = - -- v `S.union` (S.fromList . map idName . symbolic_ids $ s) - -adtHeight :: Name -> State t -> Int -adtHeight n s@(State { expr_env = eenv }) - | Just (E.Sym _) <- v = 0 - | Just (E.Conc e) <- v = - 1 + adtHeight' e s - | otherwise = 0 - where - v = E.lookupConcOrSym n eenv - -adtHeight' :: Expr -> State t -> Int -adtHeight' e s = - let - _:es = unApp e - in - maximum $ map (\e' -> case e' of - Var (Id n _) -> adtHeight n s - _ -> 0) es - --- Wraps an existing Orderer, and increases it's value by 1, every time --- it doesn't change after N steps -data IncrAfterN ord = IncrAfterN Int ord - -data IncrAfterNTr sov = IncrAfterNTr { steps_since_change :: Int - , incr_by :: Int - , underlying :: sov } - -instance (Eq sov, Enum b, Orderer ord sov b t) => Orderer (IncrAfterN ord) (IncrAfterNTr sov) b t where - initPerStateOrder (IncrAfterN _ ord) s = - IncrAfterNTr { steps_since_change = 0 - , incr_by = 0 - , underlying = initPerStateOrder ord s } - orderStates (IncrAfterN _ ord) sov s = - let - b = orderStates ord (underlying sov) s - in - succNTimes (incr_by sov) b - updateSelected (IncrAfterN _ ord) sov pr s = - sov { underlying = updateSelected ord (underlying sov) pr s } - stepOrderer (IncrAfterN ma ord) sov pr xs s - | steps_since_change sov >= ma = - sov' { incr_by = incr_by sov' + 1 - , steps_since_change = 0 } - | under /= under' = - sov' { steps_since_change = 0 } - | otherwise = - sov' { steps_since_change = steps_since_change sov' + 1} - where - under = underlying sov - under' = stepOrderer ord under pr xs s - sov' = sov { underlying = under' } - - -succNTimes :: Enum b => Int -> b -> b -succNTimes x b - | x <= 0 = b - | otherwise = succNTimes (x - 1) (succ b) - --------- --------- - --- | Uses a passed Reducer, Halter and Orderer to execute the reduce on the State, and generated States -runReducer :: (Reducer r rv t, Halter h hv t, Orderer or sov b t) => r -> h -> or -> State t -> Bindings -> IO (Processed (State t), Bindings) -runReducer red hal ord s b = do - let pr = Processed {accepted = [], discarded = []} - let s' = ExState { state = s - , reducer_val = initReducer red s - , halter_val = initHalt hal s - , order_val = initPerStateOrder ord s } - - (states, b') <- runReducer' red hal ord pr s' b M.empty - let states' = mapProcessed state states - return (states', b') - -runReducer' :: (Reducer r rv t, Halter h hv t, Orderer or sov b t) - => r - -> h - -> or - -> Processed (ExState rv hv sov t) - -> ExState rv hv sov t - -> Bindings - -> M.Map b [ExState rv hv sov t] - -> IO (Processed (ExState rv hv sov t), Bindings) -runReducer' red hal ord pr rs@(ExState { state = s, reducer_val = r_val, halter_val = h_val, order_val = o_val }) b xs - | hc == Accept = - let - pr' = pr {accepted = rs:accepted pr} - jrs = minState xs - in - case jrs of - Just (rs', xs') -> do - switchState red hal ord pr' rs' b xs' - -- runReducer' red hal ord pr' (updateExStateHalter hal pr' rs') b xs' - Nothing -> return (pr', b) - | hc == Discard = - let - pr' = pr {discarded = rs:discarded pr} - jrs = minState xs - in - case jrs of - Just (rs', xs') -> - switchState red hal ord pr' rs' b xs' - -- runReducer' red hal ord pr' (updateExStateHalter hal pr' rs') b xs' - Nothing -> return (pr', b) - | hc == Switch = - let - k = orderStates ord (order_val rs') (state rs) - rs' = rs { order_val = updateSelected ord (order_val rs) ps (state rs) } - - Just (rs'', xs') = minState (M.insertWith (++) k [rs'] xs) - in - switchState red hal ord pr rs'' b xs' - -- if not $ discardOnStart hal (halter_val rs''') ps (state rs''') - -- then runReducer' red hal ord pr rs''' b xs' - -- else runReducerList red hal ord (pr {discarded = rs''':discarded pr}) xs' b - | otherwise = do - (_, reduceds, b', red') <- redRules red r_val s b - let reduceds' = map (\(r, rv) -> (r {num_steps = num_steps r + 1}, rv)) reduceds - - let r_vals = updateWithAll red reduceds' ++ error "List returned by updateWithAll is too short." - new_states = map fst reduceds' - - mod_info = map (\(s', r_val') -> - rs { state = s' - , reducer_val = r_val' - , halter_val = stepHalter hal h_val ps new_states s' - , order_val = stepOrderer ord o_val ps new_states s'}) $ zip new_states r_vals - - case mod_info of - (s_h:ss_tail) -> do - let xs' = foldr (\s' -> M.insertWith (++) (orderStates ord (order_val s') (state s')) [s']) xs ss_tail - runReducer' red' hal ord pr s_h b' xs' - [] -> runReducerList red' hal ord pr xs b' - where - hc = stopRed hal h_val ps s - ps = processedToState pr - -switchState :: (Reducer r rv t, Halter h hv t, Orderer or sov b t) - => r - -> h - -> or - -> Processed (ExState rv hv sov t) - -> ExState rv hv sov t - -> Bindings - -> M.Map b [ExState rv hv sov t] - -> IO (Processed (ExState rv hv sov t), Bindings) -switchState red hal ord pr rs b xs - | not $ discardOnStart hal (halter_val rs') ps (state rs') = - runReducer' red hal ord pr rs' b xs - | otherwise = - runReducerListSwitching red hal ord (pr {discarded = rs':discarded pr}) xs b - where - ps = processedToState pr - rs' = rs { halter_val = updatePerStateHalt hal (halter_val rs) ps (state rs) } - --- To be used when we we need to select a state without switching -runReducerList :: (Reducer r rv t, Halter h hv t, Orderer or sov b t) - => r - -> h - -> or - -> Processed (ExState rv hv sov t) - -> M.Map b [ExState rv hv sov t] - -> Bindings - -> IO (Processed (ExState rv hv sov t), Bindings) -runReducerList red hal ord pr m binds = - case minState m of - Just (x, m') -> runReducer' red hal ord pr x binds m' - Nothing -> return (pr, binds) - --- To be used when we are possibly switching states -runReducerListSwitching :: (Reducer r rv t, Halter h hv t, Orderer or sov b t) - => r - -> h - -> or - -> Processed (ExState rv hv sov t) - -> M.Map b [ExState rv hv sov t] - -> Bindings - -> IO (Processed (ExState rv hv sov t), Bindings) -runReducerListSwitching red hal ord pr m binds = - case minState m of - Just (x, m') -> switchState red hal ord pr x binds m' - Nothing -> return (pr, binds) - -processedToState :: Processed (ExState rv hv sov t) -> Processed (State t) -processedToState (Processed {accepted = app, discarded = dis}) = - Processed {accepted = map state app, discarded = map state dis} - --- Uses the Orderer to determine which state to continue execution on. --- Returns that State, and a list of the rest of the states -minState :: Ord b => M.Map b [ExState rv hv sov t] -> Maybe ((ExState rv hv sov t), M.Map b [ExState rv hv sov t]) -minState m = - case M.minViewWithKey m of - Just ((k, x:xs), _) -> Just (x, M.insert k xs m) - Just ((_, []), m') -> minState m' - Nothing -> Nothing - -numStates :: M.Map b [ExState rv hv sov t] -> Int -numStates = sum . map length . M.elems +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| Module: G2.Execution.Reducer + +Controls reduction of `State`s. + +The `runReducer` function reduces States, guided by a `Reducer`, `Halter`, and `Orderer`. +The `Reducer` defines the reduction rules used to map a State to one or more further States. +The `Halter` determines when to accept (return) or completely discard a state, +and allows /temporarily/ stopping reduction of a particular state, to allow reduction of other states. +The `Orderer` determines which state should be executed next when the Halter chooses to accept, reject, +or switch to executing a different state. +-} +module G2.Execution.Reducer ( Reducer (..) + + , Halter (..) + , InitHalter + , UpdatePerStateHalt + , StopRed + , StepHalter + + , Orderer (..) + , InitOrderer + , OrderStates + , UpdateSelected + + , Processed (..) + , mapProcessed + + , ReducerRes (..) + , HaltC (..) + + , SomeReducer (..) + , SomeHalter (..) + , SomeOrderer (..) + + -- * Reducers + , InitReducer + , RedRules + , mkSimpleReducer + , liftReducer + , liftSomeReducer + + , stdRed + , nonRedPCTemplates + , nonRedPCRed + , nonRedPCRedConst + , taggerRed + , getLogger + , simpleLogger + , prettyLogger + , limLogger + , LimLogger (..) + + , ReducerEq (..) + , (.==) + , (~>) + , (.~>) + , (-->) + , (.-->) + + , (.|.) + + -- * Halters + , mkSimpleHalter + , liftHalter + , liftSomeHalter + + , swhnfHalter + , acceptIfViolatedHalter + , (<~>) + , zeroHalter + , discardIfAcceptedTagHalter + , maxOutputsHalter + , switchEveryNHalter + , varLookupLimitHalter + , stdTimerHalter + , timerHalter + + -- * Orderers + , mkSimpleOrderer + , (<->) + , ordComb + , nextOrderer + , pickLeastUsedOrderer + , bucketSizeOrderer + , adtHeightOrderer + , adtSizeOrderer + , pcSizeOrderer + , incrAfterN + , quotTrueAssert + + -- * Execution + , runReducer ) where + +import G2.Config +import qualified G2.Language.ExprEnv as E +import G2.Execution.Rules +import G2.Language +import qualified G2.Language.Monad as MD +import qualified G2.Language.PathConds as PC +import qualified G2.Language.Stack as Stck +import G2.Solver +import G2.Lib.Printers + +import Control.Monad.IO.Class +import qualified Control.Monad.State as SM +import Data.Foldable +import qualified Data.HashSet as HS +import qualified Data.HashMap.Strict as HM +import qualified Data.Map as M +import Data.Maybe +import Data.Monoid ((<>)) +import qualified Data.List as L +import qualified Data.Text as T +import Data.Tuple +import Data.Time.Clock +import System.Directory + +-- | Used when applying execution rules +-- Allows tracking extra information to control halting of rule application, +-- and to reorder states +-- see also, the Reducer, Halter, Orderer typeclasses +-- cases is used for logging states +data ExState rv hv sov t = ExState { state :: State t + , reducer_val :: rv + , halter_val :: hv + , order_val :: sov + } + +-- | Keeps track of type a's that have either been accepted or dropped +data Processed a = Processed { accepted :: [a] + , discarded :: [a] } + +mapProcessed :: (a -> b) -> Processed a -> Processed b +mapProcessed f pr = Processed { accepted = map f (accepted pr) + , discarded = map f (discarded pr)} + +-- | Used by Reducers to indicate their progress reducing. +data ReducerRes = NoProgress | InProgress | Finished deriving (Eq, Ord, Show, Read) + +progPrioritizer :: ReducerRes -> ReducerRes -> ReducerRes +progPrioritizer InProgress _ = InProgress +progPrioritizer _ InProgress = InProgress +progPrioritizer Finished _ = Finished +progPrioritizer _ Finished = Finished +progPrioritizer _ _ = NoProgress + +-- | Used by members of the Halter typeclass to control whether to continue +-- evaluating the current State, or switch to evaluating a new state. +data HaltC = Discard -- ^ Switch to evaluating a new state, and reject the current state + | Accept -- ^ Switch to evaluating a new state, and accept the current state + | Switch -- ^ Switch to evaluating a new state, but continue evaluating the current state later + | Continue -- ^ Continue evaluating the current State + deriving (Eq, Ord, Show, Read) + +type InitReducer rv t = State t -> rv +type RedRules m rv t = rv -> State t -> Bindings -> m (ReducerRes, [(State t, rv)], Bindings) + + +-- | A Reducer is used to define a set of Reduction Rules. +-- Reduction Rules take a `State`, and output new `State`s. +-- The reducer value, rv, can be used to track extra information, on a per `State` basis. +data Reducer m rv t = Reducer { + -- | Initialized the reducer value + initReducer :: InitReducer rv t + + -- | Takes a State, and performs the appropriate Reduction Rule + , redRules :: RedRules m rv t + + -- | After a reducer returns multiple states, + -- gives an opportunity to update with all States and Reducer values's, + -- visible. + -- Errors if the returned list is too short. + -- If only one state is returned by all reducers, updateWithAll does not run. + , updateWithAll :: [(State t, rv)] -> [rv] + + -- Action to run after a State is accepted. + , onAccept :: State t -> rv -> m () + + -- | Action to run after execution of all states has terminated. + , afterRed :: m () + } + +-- | A simple, default reducer. +-- `updateWithAll` does not change or adjust the reducer values. +-- `onAccept` immediately returns the empty tuple. +mkSimpleReducer :: Monad m => InitReducer rv t -> RedRules m rv t -> Reducer m rv t +mkSimpleReducer init_red red_rules = + Reducer { + initReducer = init_red + , redRules = red_rules + , updateWithAll = map snd + , onAccept = \_ _ -> return () + , afterRed = return () + } +{-# INLINE mkSimpleReducer #-} + +-- | Lift a reducer from a component monad to a constructed monad. +liftReducer :: (Monad m1, SM.MonadTrans m2) => Reducer m1 rv t -> Reducer (m2 m1) rv t +liftReducer r = Reducer { initReducer = initReducer r + , redRules = \rv s b -> SM.lift ((redRules r) rv s b) + , updateWithAll = updateWithAll r + , onAccept = \s rv -> SM.lift ((onAccept r) s rv) + , afterRed = SM.lift (afterRed r)} + +-- | Lift a SomeReducer from a component monad to a constructed monad. +liftSomeReducer :: (Monad m1, SM.MonadTrans m2) => SomeReducer m1 t -> SomeReducer (m2 m1) t +liftSomeReducer (SomeReducer r) = SomeReducer (liftReducer r) + +type InitHalter hv t = State t -> hv +type UpdatePerStateHalt hv t = hv -> Processed (State t) -> State t -> hv +type StopRed m hv t = hv -> Processed (State t) -> State t -> m HaltC +type StepHalter hv t = hv -> Processed (State t) -> [State t] -> State t -> hv + +-- | Determines when to stop evaluating a state +-- The halter value, hv, can be used to track extra information, on a per `State` basis. +data Halter m hv t = Halter { + -- | Initializes each state halter value + initHalt :: InitHalter hv t + + -- | Runs whenever we switch to evaluating a different state, + -- to update the halter value of that new state + , updatePerStateHalt :: UpdatePerStateHalt hv t + + -- | Runs when we start execution on a state, immediately after + -- `updatePerStateHalt`. Allows a State to be discarded right + -- before execution is about to (re-)begin. + -- Return True if execution should proceed, False to discard + , discardOnStart :: hv -> Processed (State t) -> State t -> Bool + + -- | Determines whether to continue reduction on the current state + , stopRed :: StopRed m hv t + + -- | Takes a state, and updates its halter record field + , stepHalter :: StepHalter hv t + + -- | After multiple states, are returned + -- gives an opportunity to update halters with all States and halter values visible. + -- Errors if the returned list is too short. + -- If only one state is returned, updateHalterWithAll does not run. + , updateHalterWithAll :: [(State t, hv)] -> [hv] + } + +-- | A simple, default halter. +mkSimpleHalter :: Monad m => InitHalter hv t -> UpdatePerStateHalt hv t -> StopRed m hv t -> StepHalter hv t -> Halter m hv t +mkSimpleHalter initial update stop step = Halter { initHalt = initial + , updatePerStateHalt = update + , discardOnStart = \_ _ _ -> False + , stopRed = stop + , stepHalter = step + , updateHalterWithAll = map snd } +{-# INLINE mkSimpleHalter #-} + +-- | Lift a halter from a component monad to a constructed monad. +liftHalter :: (Monad m1, SM.MonadTrans m2) => Halter m1 rv t -> Halter (m2 m1) rv t +liftHalter h = Halter { initHalt = initHalt h + , updatePerStateHalt = updatePerStateHalt h + , discardOnStart = discardOnStart h + , stopRed = \hv pr s -> SM.lift ((stopRed h) hv pr s) + , stepHalter = stepHalter h + , updateHalterWithAll = updateHalterWithAll h } + +-- | Lift a SomeHalter from a component monad to a constructed monad. +liftSomeHalter :: (Monad m1, SM.MonadTrans m2) => SomeHalter m1 t -> SomeHalter (m2 m1) t +liftSomeHalter (SomeHalter r) = SomeHalter (liftHalter r) + +{-# INLINE mkStoppingHalter #-} +mkStoppingHalter :: Monad m => StopRed m () t -> Halter m () t +mkStoppingHalter stop = + mkSimpleHalter + (const ()) + (\_ _ _ -> ()) + stop + (\_ _ _ _ -> ()) + +type InitOrderer sov t = State t -> sov +type OrderStates m sov b t = sov -> Processed (State t) -> State t -> m b +type UpdateSelected sov t = sov -> Processed (State t) -> State t -> sov + +-- | Picks an order to evaluate the states, to allow prioritizing some over others. +-- The orderer value, sov, can be used to track extra information, on a per `State` basis. +-- The ordering type b, is used to determine what order to execute the states in. +-- In practice, `b` must be an instance of `Ord`. When the orderer is called, the `State` corresponding +-- to the minimal `b` is executed. +data Orderer m sov b t = Orderer { + -- | Initializing the per state ordering value + initPerStateOrder :: InitOrderer sov t + + -- | Assigns each state some value of an ordered type, and then proceeds with execution on the + -- state assigned the minimal value + , orderStates :: OrderStates m sov b t + + -- | Run on the selected state, to update it's sov field + , updateSelected :: UpdateSelected sov t + + -- | Run on the state at each step, to update it's sov field + , stepOrderer :: sov -> Processed (State t) -> [State t] -> State t -> m sov + } + +-- | A simple, default orderer. +mkSimpleOrderer :: Monad m => InitOrderer sov t -> OrderStates m sov b t -> UpdateSelected sov t -> Orderer m sov b t +mkSimpleOrderer initial order update = Orderer { initPerStateOrder = initial + , orderStates = order + , updateSelected = update + , stepOrderer = \sov _ _ _ -> return sov} + +getState :: M.Map b [s] -> Maybe (b, [s]) +getState = M.lookupMin + +-- | Hide the details of a Reducer's reducer value. +data SomeReducer m t where + SomeReducer :: forall m rv t . Reducer m rv t -> SomeReducer m t + +-- | Hide the details of a Halter's halter value. +data SomeHalter m t where + SomeHalter :: forall m hv t . Halter m hv t -> SomeHalter m t + +-- | Hide the details of an Orderer's orderer value and ordering type. +data SomeOrderer m t where + SomeOrderer :: forall m sov b t . Ord b => Orderer m sov b t -> SomeOrderer m t + + +-- Combines multiple reducers together into a single reducer. + +-- We use RC to combine the reducer values for RCombiner +-- We should never define any other instance of Reducer with RC, or export it +-- because this could lead to undecidable instances +data RC a b = RC a b + +-- | Check if a `Reducer` returns some specific `ReducerRes` +data ReducerEq m t where + (:==) :: forall m rv t . Reducer m rv t -> ReducerRes -> ReducerEq m t + +(.==) :: SomeReducer m t -> ReducerRes -> ReducerEq m t +SomeReducer r .== res = r :== res + +infixr 8 .== + +infixr 7 ~>, .~> + +infixr 5 -->, .--> + +-- | @r1 ~> r2@ applies `Reducer` `r1`, followed by reducer `r2`. +(~>) :: Monad m => Reducer m rv1 t -> Reducer m rv2 t -> Reducer m (RC rv1 rv2) t +r1 ~> r2 = + Reducer { initReducer = \s -> RC (initReducer r1 s) (initReducer r2 s) + + , redRules = \(RC rv1 rv2) s b -> do + (rr1, srv1, b') <- redRules r1 rv1 s b + (rr2, srv2, b'') <- redRulesToStates r2 rv2 srv1 b' + + return (progPrioritizer rr1 rr2, srv2, b'') + + , updateWithAll = updateWithAllPair (updateWithAll r1) (updateWithAll r2) + + , onAccept = \s (RC rv1 rv2) -> do + onAccept r1 s rv1 + onAccept r2 s rv2 + + , afterRed = do + afterRed r1 + afterRed r2 + + } +{-# INLINE (~>) #-} + +-- | `~>` adjusted to work on `SomeReducer`s, rather than `Reducer`s. +(.~>) :: Monad m => SomeReducer m t -> SomeReducer m t -> SomeReducer m t +SomeReducer r1 .~> SomeReducer r2 = SomeReducer (r1 ~> r2) +{-# INLINE (.~>) #-} + +-- | @r1 := res --> r2@ applies `Reducer` `r1`. If `r1` returns the `ReducerRes` `res`, +-- then `Reducer` `r2` is applied. Otherwise, reduction halts. +(-->) :: Monad m => ReducerEq m t -> Reducer m rv2 t -> SomeReducer m t +(r1 :== res) --> r2 = + SomeReducer $ + Reducer { initReducer = \s -> RC (initReducer r1 s) (initReducer r2 s) + + , redRules = \(RC rv1 rv2) s b -> do + (rr1, srv1, b') <- redRules r1 rv1 s b + let (s', rv1') = unzip srv1 + + case rr1 == res of + True -> do + (rr2, ss, b'') <- redRulesToStates r2 rv2 srv1 b' + return (rr2, ss, b'') + False -> return (rr1, zip s' (map (flip RC rv2) rv1'), b') + + , updateWithAll = updateWithAllPair (updateWithAll r1) (updateWithAll r2) + + , onAccept = \s (RC rv1 rv2) -> do + onAccept r1 s rv1 + onAccept r2 s rv2 + + , afterRed = do + afterRed r1 + afterRed r2 + } +{-# INLINE (-->) #-} + +-- | `.-->` adjusted to take a `SomeReducer`, rather than a `Reducer`s. +(.-->) :: Monad m => ReducerEq m t -> SomeReducer m t -> SomeReducer m t +req .--> SomeReducer r = req --> r + +redRulesToStatesAux :: Monad m => Reducer m rv2 t -> rv2 -> Bindings -> (State t, rv1) -> m (Bindings, (ReducerRes, [(State t, RC rv1 rv2)])) +redRulesToStatesAux r rv2 b (is, rv1) = do + (rr_, is', b') <- redRules r rv2 is b + return (b', (rr_, map (\(is'', rv2') -> (is'', RC rv1 rv2') ) is')) + +redRulesToStates :: Monad m => Reducer m rv2 t -> rv2 -> [(State t, rv1)] -> Bindings -> m (ReducerRes, [(State t, RC rv1 rv2)], Bindings) +redRulesToStates r rv1 s b = do + let redRulesToStatesAux' = redRulesToStatesAux r rv1 + (b', rs) <- MD.mapMAccumB redRulesToStatesAux' b s + + let (rr, s') = L.unzip rs + + let rf = foldr progPrioritizer NoProgress rr + + return $ (rf, concat s', b') + +-- | @r1 .|. r2@ applies both Reducer r1 and Reducer r2 to the \inital\ state passed to the reducer, +-- and returns the list of states returned from both reducers combined. +-- Care should be taken to avoid unwanted duplication of states if, for example, neither of the reducers +-- makes progress. +(.|.) :: Monad m => Reducer m rv1 t -> Reducer m rv2 t -> Reducer m (RC rv1 rv2) t +r1 .|. r2 = + Reducer { initReducer = \s -> RC (initReducer r1 s) (initReducer r2 s) + + , redRules = \(RC rv1 rv2) s b -> do + (rr2, srv2, b') <- redRules r2 rv2 s b + (rr1, srv1, b'') <- redRules r1 rv1 s b' + + let srv2' = map (\(s_, rv2_) -> (s_, RC rv1 rv2_) ) srv2 + srv1' = map (\(s_, rv1_) -> (s_, RC rv1_ rv2) ) srv1 + + return (progPrioritizer rr1 rr2, srv2' ++ srv1', b'') + + , updateWithAll = updateWithAllPair (updateWithAll r1) (updateWithAll r2) + + , onAccept = \s (RC rv1 rv2) -> do + onAccept r1 s rv1 + onAccept r2 s rv2 + + , afterRed = do + afterRed r1 + afterRed r2 + + } +{-# INLINE (.|.) #-} + +updateWithAllPair :: ([(State t, rv1)] -> [rv1]) -> ([(State t, rv2)] -> [rv2]) -> [(State t, RC rv1 rv2)] -> [RC rv1 rv2] +updateWithAllPair update1 update2 srv = + let + srv1 = map (\(s, RC rv1 _) -> (s, rv1)) srv + srv2 = map (\(s, RC _ rv2) -> (s, rv2)) srv + + rv1' = update1 srv1 + rv2' = update2 srv2 + in + map (uncurry RC) $ zip rv1' rv2' + +{-#INLINE stdRed #-} +{-# SPECIALIZE stdRed :: (Solver solver, Simplifier simplifier) => Sharing -> SymbolicFuncEval t -> solver -> simplifier -> Reducer IO () t #-} +stdRed :: (MonadIO m, Solver solver, Simplifier simplifier) => Sharing -> SymbolicFuncEval t -> solver -> simplifier -> Reducer m () t +stdRed share symb_func_eval solver simplifier = + mkSimpleReducer (\_ -> ()) + (\_ s b -> do + (r, s', b') <- liftIO $ stdReduce share symb_func_eval solver simplifier s b + + return (if r == RuleIdentity then Finished else InProgress, s', b') + ) + +-- | Pushes non_red_path_conds onto the exec_stack for solving higher order symbolic function +nonRedPCTemplates :: Monad m => Reducer m () t +nonRedPCTemplates = mkSimpleReducer (\_ -> ()) + nonRedPCTemplatesFunc + +nonRedPCTemplatesFunc :: Monad m => RedRules m () t +nonRedPCTemplatesFunc _ + s@(State { expr_env = eenv + , curr_expr = cexpr + , exec_stack = stck + , non_red_path_conds = (nre1, nre2):nrs + , model = m }) + b@(Bindings { name_gen = ng }) = + + let + stck' = Stck.push (CurrExprFrame (EnsureEq nre2) cexpr) stck + s' = s { exec_stack = stck', non_red_path_conds = nrs } + in + case retReplaceSymbFuncTemplate s' ng nre1 of + Just (r, s'', ng') -> return (InProgress, zip s'' (repeat ()), b {name_gen = ng'}) + Nothing -> + let + s'' = s' {curr_expr = CurrExpr Evaluate nre1} + in return (InProgress, [(s'', ())], b) +nonRedPCTemplatesFunc _ s b = return (Finished, [(s, ())], b) + +-- | Removes and reduces the values in a State's non_red_path_conds field. +{-#INLINE nonRedPCRed #-} +nonRedPCRed :: Monad m => Reducer m () t +nonRedPCRed = mkSimpleReducer (\_ -> ()) + nonRedPCRedFunc + +nonRedPCRedFunc :: Monad m => RedRules m () t +nonRedPCRedFunc _ + s@(State { expr_env = eenv + , curr_expr = cexpr + , exec_stack = stck + , non_red_path_conds = (nre1, nre2):nrs + , model = m }) + b@(Bindings { higher_order_inst = inst }) + | Var (Id n t) <- nre2 + , E.isSymbolic n eenv + , hasFuncType (PresType t) = + let + s' = s { expr_env = E.insert n nre1 eenv + , non_red_path_conds = nrs } + in + return (InProgress, [(s', ())], b) + | Var (Id n t) <- nre1 + , E.isSymbolic n eenv + , hasFuncType (PresType t) = + let + s' = s { expr_env = E.insert n nre2 eenv + , non_red_path_conds = nrs } + in + return (InProgress, [(s', ())], b) + | otherwise = do + let stck' = Stck.push (CurrExprFrame (EnsureEq nre2) cexpr) stck + + let cexpr' = CurrExpr Evaluate nre1 + + let eenv_si_ces = substHigherOrder eenv m inst cexpr' + + let s' = s { exec_stack = stck' + , non_red_path_conds = nrs + } + xs = map (\(eenv', m', ce) -> (s' { expr_env = eenv' + , model = m' + , curr_expr = ce }, ())) eenv_si_ces + + return (InProgress, xs, b) +nonRedPCRedFunc _ s b = return (Finished, [(s, ())], b) + +-- [Higher-Order Model] +-- Substitutes all possible higher order functions for symbolic higher order functions. +-- We insert the substituted higher order function directly into the model, because, due +-- to the VAR-RED rule, the function name will (if the function is called) be lost during execution. +substHigherOrder :: ExprEnv -> Model -> HS.HashSet Name -> CurrExpr -> [(ExprEnv, Model, CurrExpr)] +substHigherOrder eenv m ns ce = + let + is = mapMaybe (\n -> case E.lookup n eenv of + Just e -> Just $ Id n (typeOf e) + Nothing -> Nothing) $ HS.toList ns + + higherOrd = filter (isTyFun . typeOf) . symbVars eenv $ ce + higherOrdSub = map (\v -> (v, mapMaybe (genSubstitutable v) is)) higherOrd + in + substHigherOrder' [(eenv, m, ce)] higherOrdSub + where + genSubstitutable v i + | Just bm <- specializes (typeOf v) (typeOf i) = + let + bnds = map idName $ leadingTyForAllBindings i + tys = mapMaybe (\b -> fmap Type $ M.lookup b bm) bnds + in + Just . mkApp $ Var i:tys + | otherwise = Nothing + +substHigherOrder' :: [(ExprEnv, Model, CurrExpr)] -> [(Id, [Expr])] -> [(ExprEnv, Model, CurrExpr)] +substHigherOrder' eenvsice [] = eenvsice +substHigherOrder' eenvsice ((i, es):iss) = + substHigherOrder' + (concatMap (\e_rep -> + map (\(eenv, m, ce) -> ( E.insert (idName i) e_rep eenv + , HM.insert (idName i) e_rep m + , replaceASTs (Var i) e_rep ce) + ) eenvsice) + es) iss + +-- | Removes and reduces the values in a State's non_red_path_conds field +-- by instantiating higher order functions to be constant. +-- Does not return any states if the state does not contain at least one +-- higher order symbolic variable. +nonRedPCRedConst :: Monad m => Reducer m () t +nonRedPCRedConst = mkSimpleReducer (\_ -> ()) + nonRedPCRedConstFunc + +nonRedPCRedConstFunc :: Monad m => RedRules m () t +nonRedPCRedConstFunc _ + s@(State { expr_env = eenv + , curr_expr = cexpr + , exec_stack = stck + , non_red_path_conds = (nre1, nre2):nrs + , model = m }) + b@(Bindings { name_gen = ng }) + | higher_ord <- L.filter (isTyFun . typeOf) $ E.symbolicIds eenv + , not (null higher_ord) = do + let stck' = Stck.push (CurrExprFrame (EnsureEq nre2) cexpr) stck + + let cexpr' = CurrExpr Evaluate nre1 + + let (ng', new_lam_is) = L.mapAccumL (\ng_ ts -> swap $ freshIds ts ng_) ng (map anonArgumentTypes higher_ord) + (new_sym_gen, ng'') = freshIds (map returnType higher_ord) ng' + + es = map (\(f_id, lam_i, sg_i) -> (f_id, mkLams (zip (repeat TermL) lam_i) (Var sg_i)) ) + $ zip3 higher_ord new_lam_is new_sym_gen + + eenv' = foldr (uncurry E.insert) eenv (map (\(i, e) -> (idName i, e)) es) + eenv'' = foldr E.insertSymbolic eenv' new_sym_gen + m' = foldr (\(i, e) -> HM.insert (idName i) e) m es + + let s' = s { expr_env = eenv'' + , curr_expr = cexpr' + , model = m' + , exec_stack = stck' + , non_red_path_conds = nrs + } + + return (InProgress, [(s', ())], b { name_gen = ng'' }) +nonRedPCRedConstFunc _ s b = return (Finished, [], b) + +{-# INLINE taggerRed #-} +taggerRed :: Monad m => Name -> Reducer m () t +taggerRed n = mkSimpleReducer (const ()) (taggerRedStep n) + +taggerRedStep :: Monad m => Name -> RedRules m () t +taggerRedStep n _ s@(State {tags = ts}) b@(Bindings { name_gen = ng }) = + let + (n'@(Name n_ m_ _ _), ng') = freshSeededName n ng + in + if null $ HS.filter (\(Name n__ m__ _ _) -> n_ == n__ && m_ == m__) ts then + return (Finished, [(s {tags = HS.insert n' ts}, ())], b { name_gen = ng' }) + else + return (Finished, [(s, ())], b) + + +getLogger :: (MonadIO m, SM.MonadState PrettyGuide m, Show t) => Config -> Maybe (Reducer m [Int] t) +getLogger config = case logStates config of + Log Raw fp -> Just (simpleLogger fp) + Log Pretty fp -> Just (prettyLogger fp) + NoLog -> Nothing + +-- | A Reducer to producer logging output +simpleLogger :: (MonadIO m, Show t) => FilePath -> Reducer m [Int] t +simpleLogger fn = + (mkSimpleReducer (const []) + (\li s b -> do + liftIO $ outputState fn li s b pprExecStateStr + return (NoProgress, [(s, li)], b) )) + { updateWithAll = \s -> map (\(l, i) -> l ++ [i]) $ zip (map snd s) [1..] } + +-- | A Reducer to producer logging output +prettyLogger :: (MonadIO m, SM.MonadState PrettyGuide m, Show t) => FilePath -> Reducer m [Int] t +prettyLogger fp = + (mkSimpleReducer + (const []) + (\li s b -> do + pg <- SM.get + let pg' = updatePrettyGuide (s { track = () }) pg + SM.put pg' + liftIO $ outputState fp li s b (\s_ _ -> T.unpack $ prettyState pg' s_) + return (NoProgress, [(s, li)], b) + ) + ) { updateWithAll = \s -> map (\(l, i) -> l ++ [i]) $ zip (map snd s) [1..] + , onAccept = \_ ll -> liftIO . putStrLn $ "Accepted on path " ++ show ll } + +-- | A Reducer to producer limited logging output. +data LimLogger = + LimLogger { every_n :: Int -- Output a state every n steps + , after_n :: Int -- Only begin outputting after passing a certain n + , before_n :: Maybe Int -- Only output before a certain n + , down_path :: [Int] -- Output states that have gone down or are going down the given path prefix + , lim_output_path :: String + } + +data LLTracker = LLTracker { ll_count :: Int, ll_offset :: [Int]} + +limLogger :: (MonadIO m, Show t) => LimLogger -> Reducer m LLTracker t +limLogger ll@(LimLogger { after_n = aft, before_n = bfr, down_path = down }) = + (mkSimpleReducer (const $ LLTracker { ll_count = every_n ll, ll_offset = []}) rr) + { updateWithAll = updateWithAllLL + , onAccept = \_ llt -> liftIO . putStrLn $ "Accepted on path " ++ show (ll_offset llt)} + where + rr llt@(LLTracker { ll_count = 0, ll_offset = off }) s b + | down `L.isPrefixOf` off || off `L.isPrefixOf` down + , aft <= length_rules && maybe True (length_rules <=) bfr = do + liftIO $ outputState (lim_output_path ll) off s b pprExecStateStr + return (NoProgress, [(s, llt { ll_count = every_n ll })], b) + | otherwise = + return (NoProgress, [(s, llt { ll_count = every_n ll })], b) + where + length_rules = length (rules s) + rr llt@(LLTracker {ll_count = n}) s b = + return (NoProgress, [(s, llt { ll_count = n - 1 })], b) + + updateWithAllLL [(_, l)] = [l] + updateWithAllLL ss = + map (\(llt, i) -> llt { ll_offset = ll_offset llt ++ [i] }) $ zip (map snd ss) [1..] + +outputState :: FilePath -> [Int] -> State t -> Bindings -> (State t -> Bindings -> String) -> IO () +outputState dn is s b printer = do + fn <- getFile dn is "state" s + + -- Don't re-output states that already exist + exists <- doesPathExist fn + + if not exists + then do + let write = printer s b + writeFile fn write + + putStrLn fn + else return () + +getFile :: String -> [Int] -> String -> State t -> IO String +getFile dn is n s = do + let dir = dn ++ "/" ++ foldl' (\str i -> str ++ show i ++ "/") "" is + createDirectoryIfMissing True dir + let fn = dir ++ n ++ show (length $ rules s) ++ ".txt" + return fn + +-- We use C to combine the halter values for HCombiner +-- We should never define any other instance of Halter with C, or export it +-- because this could lead to undecidable instances +data C a b = C a b deriving Eq + +instance (ASTContainer a Expr, ASTContainer b Expr) => ASTContainer (C a b) Expr where + containedASTs (C a b) = containedASTs a ++ containedASTs b + modifyContainedASTs f (C a b) = C (modifyContainedASTs f a) (modifyContainedASTs f b) + +instance (ASTContainer a Type, ASTContainer b Type) => ASTContainer (C a b) Type where + containedASTs (C a b) = containedASTs a ++ containedASTs b + modifyContainedASTs f (C a b) = C (modifyContainedASTs f a) (modifyContainedASTs f b) + +instance (Named a, Named b) => Named (C a b) where + names (C a b) = names a <> names b + rename old new (C a b) = C (rename old new a) (rename old new b) + renames hm (C a b) = C (renames hm a) (renames hm b) + +-- | Allows executing multiple halters. +-- If the halters disagree, prioritizes the order: +-- Discard, Accept, Switch, Continue +(<~>) :: Monad m => Halter m hv1 t -> Halter m hv2 t -> Halter m (C hv1 hv2) t +h1 <~> h2 = + Halter { + initHalt = \s -> + let + hv1 = initHalt h1 s + hv2 = initHalt h2 s + in + C hv1 hv2 + + , updatePerStateHalt = \(C hv1 hv2) proc s -> + let + hv1' = updatePerStateHalt h1 hv1 proc s + hv2' = updatePerStateHalt h2 hv2 proc s + in + C hv1' hv2' + + , discardOnStart = \(C hv1 hv2) proc s -> + let + b1 = discardOnStart h1 hv1 proc s + b2 = discardOnStart h2 hv2 proc s + in + b1 || b2 + + , stopRed = \(C hv1 hv2) proc s -> do + hc1 <- stopRed h1 hv1 proc s + hc2 <- stopRed h2 hv2 proc s + + return $ min hc1 hc2 + + , stepHalter = \(C hv1 hv2) proc xs s -> + let + hv1' = stepHalter h1 hv1 proc xs s + hv2' = stepHalter h2 hv2 proc xs s + in + C hv1' hv2' + + , updateHalterWithAll = \shv -> + let + shv1 = map (\(s, C hv1 _) -> (s, hv1)) shv + shv2 = map (\(s, C _ hv2) -> (s, hv2)) shv + + shv1' = updateHalterWithAll h1 shv1 + shv2' = updateHalterWithAll h2 shv2 + in + map (uncurry C) $ zip shv1' shv2' + } +{-# INLINE (<~>) #-} + +{-# INLINE swhnfHalter #-} +swhnfHalter :: Monad m => Halter m () t +swhnfHalter = mkStoppingHalter stop + where + stop _ _ s = + case isExecValueForm s of + True -> return Accept + False -> return Continue + +-- | Accepts a state when it is in SWHNF and true_assert is true +-- Discards it if in SWHNF and true_assert is false +acceptIfViolatedHalter :: Monad m => Halter m () t +acceptIfViolatedHalter = mkStoppingHalter stop + where + stop _ _ s = + case isExecValueForm s of + True + | true_assert s -> return Accept + | otherwise -> return Discard + False -> return Continue + +-- | Allows execution to continue until the step counter hits 0, then discards the state +zeroHalter :: Monad m => Int -> Halter m Int t +zeroHalter n = mkSimpleHalter + (const n) + (\h _ _ -> h) + (\h _ _ -> if h == 0 then return Discard else return Continue) + (\h _ _ _ -> h - 1) + +maxOutputsHalter :: Monad m => Maybe Int -> Halter m (Maybe Int) t +maxOutputsHalter m = mkSimpleHalter + (const m) + (\hv _ _ -> hv) + (\_ (Processed {accepted = acc}) _ -> + case m of + Just m' -> return $ if length acc >= m' then Discard else Continue + _ -> return Continue) + (\hv _ _ _ -> hv) + +-- | Switch execution every n steps +{-# INLINE switchEveryNHalter #-} +switchEveryNHalter :: Monad m => Int -> Halter m Int t +switchEveryNHalter sw = (mkSimpleHalter + (const sw) + (\_ _ _ -> sw) + (\i _ _ -> return $ if i <= 0 then Switch else Continue) + (\i _ _ _ -> i - 1)) + { updateHalterWithAll = updateAll } + where + updateAll [] = [] + updateAll xs@((_, c):_) = + let + len = length xs + c' = c `quot` len + in + replicate len c' + +-- | If the Name, disregarding the Unique, in the DiscardIfAcceptedTag +-- matches a Tag in the Accepted State list, +-- and in the State being evaluated, discard the State +discardIfAcceptedTagHalter :: Monad m => Name -> Halter m (HS.HashSet Name) t +discardIfAcceptedTagHalter (Name n m _ _) = + mkSimpleHalter + (const HS.empty) + ups + (\ns _ _ -> return $ if not (HS.null ns) then Discard else Continue) + (\hv _ _ _ -> hv) + where + ups _ + (Processed {accepted = acc}) + (State {tags = ts}) = + let + allAccTags = HS.unions $ map tags acc + matchCurrState = HS.intersection ts allAccTags + in + HS.filter (\(Name n' m' _ _) -> n == n' && m == m') matchCurrState + +-- | Counts the number of variable lookups are made, and switches the state +-- whenever we've hit a threshold +varLookupLimitHalter :: Monad m => Int -> Halter m Int t +varLookupLimitHalter lim = mkSimpleHalter + (const lim) + (\_ _ _ -> lim) + (\l _ _ -> return $ if l <= 0 then Switch else Continue) + step + where + step l _ _ (State { curr_expr = CurrExpr Evaluate (Var _) }) = l - 1 + step l _ _ _ = l + +{-# INLINE stdTimerHalter #-} +stdTimerHalter :: (MonadIO m, MonadIO m_run) => NominalDiffTime -> m (Halter m_run Int t) +stdTimerHalter ms = timerHalter ms Discard 10 + +{-# INLINE timerHalter #-} +timerHalter :: (MonadIO m, MonadIO m_run) => NominalDiffTime -> HaltC -> Int -> m (Halter m_run Int t) +timerHalter ms def ce = do + curr <- liftIO $ getCurrentTime + return $ mkSimpleHalter + (const 0) + (\_ _ _ -> 0) + (stop curr) + step + where + stop it v (Processed { accepted = acc }) _ + | v == 0 + , not (null acc) = do + curr <- liftIO $ getCurrentTime + let diff = diffUTCTime curr it + + if diff > ms + then return def + else return Continue + | otherwise = return Continue + + step v _ _ _ + | v >= ce = 0 + | otherwise = v + 1 + +-- Orderer things +(<->) :: Monad m => Orderer m sov1 b1 t -> Orderer m sov2 b2 t -> Orderer m (C sov1 sov2) (b1, b2) t +or1 <-> or2 = Orderer { + initPerStateOrder = \s -> + let + sov1 = initPerStateOrder or1 s + sov2 = initPerStateOrder or2 s + in + C sov1 sov2 + + , orderStates = \(C sov1 sov2) pr s -> do + sov1' <- orderStates or1 sov1 pr s + sov2' <- orderStates or2 sov2 pr s + return (sov1', sov2') + + , updateSelected = \(C sov1 sov2) proc s -> + let + sov1' = updateSelected or1 sov1 proc s + sov2' = updateSelected or2 sov2 proc s + in + C sov1' sov2' + + , stepOrderer = \(C sov1 sov2) proc xs s -> do + sov1' <- stepOrderer or1 sov1 proc xs s + sov2' <- stepOrderer or2 sov2 proc xs s + + return (C sov1' sov2') + } + +ordComb :: Monad m => (v1 -> v2 -> v3) -> Orderer m sov1 v1 t -> Orderer m sov2 v2 t -> Orderer m (C sov1 sov2) v3 t +ordComb f or1 or2 = Orderer { + initPerStateOrder = \s -> + let + sov1 = initPerStateOrder or1 s + sov2 = initPerStateOrder or2 s + in + C sov1 sov2 + + , orderStates = \(C sov1 sov2) pr s -> do + sov1' <- orderStates or1 sov1 pr s + sov2' <- orderStates or2 sov2 pr s + return (f sov1' sov2') + + , updateSelected = \(C sov1 sov2) proc s -> + let + sov1' = updateSelected or1 sov1 proc s + sov2' = updateSelected or2 sov2 proc s + in + C sov1' sov2' + + , stepOrderer = \(C sov1 sov2) proc xs s -> do + sov1' <- stepOrderer or1 sov1 proc xs s + sov2' <- stepOrderer or2 sov2 proc xs s + return (C sov1' sov2') + } + +nextOrderer :: Monad m => Orderer m () Int t +nextOrderer = mkSimpleOrderer (const ()) (\_ _ _ -> return 0) (\v _ _ -> v) + +-- | Continue execution on the state that has been picked the least in the past. +pickLeastUsedOrderer :: Monad m => Orderer m Int Int t +pickLeastUsedOrderer = mkSimpleOrderer (const 0) (\v _ _ -> return v) (\v _ _ -> v + 1) + +-- | Floors and does bucket size +bucketSizeOrderer :: Monad m => Int -> Orderer m Int Int t +bucketSizeOrderer b = + mkSimpleOrderer (const 0) + (\v _ _ -> return $ floor (fromIntegral v / fromIntegral b :: Float)) + (\v _ _ -> v + 1) + +-- | Orders by the size (in terms of height) of (previously) symbolic ADT. +-- In particular, aims to first execute those states with a height closest to +-- the specified height. +adtHeightOrderer :: Monad m => Int -> Maybe Name -> Orderer m (HS.HashSet Name, Bool) Int t +adtHeightOrderer pref_height mn = + (mkSimpleOrderer initial + order + (\v _ _ -> v)) + { stepOrderer = \sov pr st s -> return $ step sov pr st s } + where + -- Normally, each state tracks the names of currently symbolic variables, + -- but here we want all variables that were ever symbolic. + -- To track this, we use a HashSet. + -- The tracked bool is to speed up adjusting this hashset- if it is set to false, + -- we do not update the hashset. If it is set to true, + -- after the next step the hashset will be updated, and the bool will be set + -- back to false. + -- This avoids repeated operations on the hashset after rules that we know + -- will not add symbolic variables. + initial s = (HS.fromList . map idName . E.symbolicIds . expr_env $ s, False) + order (v, _) _ s = + let + m = maximum $ (-1):(HS.toList $ HS.map (flip adtHeight s) v) + h = abs (pref_height - m) + in + return h + + step (v, _) _ _ + (State { curr_expr = CurrExpr _ (SymGen _ _) }) = (v, True) + step(v, True) _ _ s = + (v `HS.union` (HS.fromList . map idName . E.symbolicIds . expr_env $ s), False) + step (v, _) _ _ + (State { curr_expr = CurrExpr _ (Tick (NamedLoc n') (Var (Id vn _))) }) + | Just n <- mn, n == n' = + (HS.insert vn v, False) + step v _ _ _ = v + +adtHeight :: Name -> State t -> Int +adtHeight n s@(State { expr_env = eenv }) + | Just (E.Sym _) <- v = 0 + | Just (E.Conc e) <- v = + 1 + adtHeight' e s + | otherwise = 0 + where + v = E.lookupConcOrSym n eenv + +adtHeight' :: Expr -> State t -> Int +adtHeight' e s = + let + _:es = unApp e + in + maximum $ 0:map (\e' -> case e' of + Var (Id n _) -> adtHeight n s + _ -> 0) es + +-- | Orders by the combined size of (previously) symbolic ADT. +-- In particular, aims to first execute those states with a combined ADT size closest to +-- the specified zize. +adtSizeOrderer :: Monad m => Int -> Maybe Name -> Orderer m (HS.HashSet Name, Bool) Int t +adtSizeOrderer pref_height mn = + (mkSimpleOrderer initial + order + (\v _ _ -> v)) + { stepOrderer = \sov pr st s -> return $ step sov pr st s } + where + -- Normally, each state tracks the names of currently symbolic variables, + -- but here we want all variables that were ever symbolic. + -- To track this, we use a HashSet. + -- The tracked bool is to speed up adjusting this hashset- if it is set to false, + -- we do not update the hashset. If it is set to true, + -- after the next step the hashset will be updated, and the bool will be set + -- back to false. + -- This avoids repeated operations on the hashset after rules that we know + -- will not add symbolic variables. + initial s = (HS.fromList . map idName . E.symbolicIds . expr_env $ s, False) + order (v, _) _ s = + let + m = sum (HS.toList $ HS.map (flip adtSize s) v) + h = abs (pref_height - m) + in + return h + + step (v, _) _ _ + (State { curr_expr = CurrExpr _ (SymGen _ _) }) = (v, True) + step (v, True) _ _ s = + (v `HS.union` (HS.fromList . map idName . E.symbolicIds . expr_env $ s), False) + step (v, _) _ _ + (State { curr_expr = CurrExpr _ (Tick (NamedLoc n') (Var (Id vn _))) }) + | Just n <- mn, n == n' = (HS.insert vn v, False) + step v _ _ _ = v + +adtSize :: Name -> State t -> Int +adtSize n s@(State { expr_env = eenv }) + | Just (E.Sym _) <- v = 0 + | Just (E.Conc e) <- v = + 1 + adtSize' e s + | otherwise = 0 + where + v = E.lookupConcOrSym n eenv + +adtSize' :: Expr -> State t -> Int +adtSize' e s = + let + _:es = unApp e + in + sum $ 0:map (\e' -> case e' of + Var (Id n _) -> adtSize n s + _ -> 0) es + +-- | Orders by the number of Path Constraints +pcSizeOrderer :: Monad m => + Int -- ^ What size should we prioritize? + -> Orderer m () Int t +pcSizeOrderer pref_height = mkSimpleOrderer (const ()) + order + (\v _ _ -> v) + where + order _ _ s = + let + m = PC.number (path_conds s) + h = abs (pref_height - m) + in + return h + +data IncrAfterNTr sov = IncrAfterNTr { steps_since_change :: Int + , incr_by :: Int + , underlying :: sov } + +-- | Wraps an existing Orderer, and increases it's value by 1, every time +-- it doesn't change after N steps +incrAfterN :: (Eq sov, Enum b, Monad m) => Int -> Orderer m sov b t -> Orderer m (IncrAfterNTr sov) b t +incrAfterN n ord = (mkSimpleOrderer initial order update) { stepOrderer = step } + where + initial s = + IncrAfterNTr { steps_since_change = 0 + , incr_by = 0 + , underlying = initPerStateOrder ord s } + + order sov pr s = do + b <- orderStates ord (underlying sov) pr s + return $ succNTimes (incr_by sov) b + + update sov pr s = + sov { underlying = updateSelected ord (underlying sov) pr s } + + step sov pr xs s = do + let under = underlying sov + under' <- stepOrderer ord under pr xs s + let sov' = sov { underlying = under' } + + if | steps_since_change sov >= n -> + return $ sov' { incr_by = incr_by sov' + 1 + , steps_since_change = 0 } + | under /= under' -> + return $ sov' { steps_since_change = 0 } + | otherwise -> + return $ sov' { steps_since_change = steps_since_change sov' + 1} + +succNTimes :: Enum b => Int -> b -> b +succNTimes x b + | x <= 0 = b + | otherwise = succNTimes (x - 1) (succ b) + +-- | Wraps an existing orderer, and divides its value by 2 if true_assert is true +quotTrueAssert :: (Monad m, Integral b) => Orderer m sov b t -> Orderer m sov b t +quotTrueAssert ord = (mkSimpleOrderer (initPerStateOrder ord) + order + (updateSelected ord)) + { stepOrderer = stepOrderer ord} + where + order sov pr s = do + b <- orderStates ord sov pr s + return (if true_assert s then b `quot` 2 else b) + +-------- +-------- + +{-# INLINABLE runReducer #-} +{-# SPECIALIZE runReducer :: Ord b => + Reducer IO rv t + -> Halter IO hv t + -> Orderer IO sov b t + -> State t + -> Bindings + -> IO (Processed (State t), Bindings) + #-} +{-# SPECIALIZE runReducer :: Ord b => + Reducer (SM.StateT PrettyGuide IO) rv t + -> Halter (SM.StateT PrettyGuide IO) hv t + -> Orderer (SM.StateT PrettyGuide IO) sov b t + -> State t + -> Bindings + -> SM.StateT PrettyGuide IO (Processed (State t), Bindings) + #-} +-- | Uses a passed Reducer, Halter and Orderer to execute the reduce on the State, and generated States +runReducer :: (Monad m, Ord b) => + Reducer m rv t + -> Halter m hv t + -> Orderer m sov b t + -> State t + -> Bindings + -> m (Processed (State t), Bindings) +runReducer red hal ord s b = do + let pr = Processed {accepted = [], discarded = []} + let s' = ExState { state = s + , reducer_val = initReducer red s + , halter_val = initHalt hal s + , order_val = initPerStateOrder ord s } + + (states, b') <- runReducer' red hal ord pr s' b M.empty + afterRed red + return (states, b') + +{-# INLINABLE runReducer' #-} +runReducer' :: (Monad m, Ord b) + => Reducer m rv t + -> Halter m hv t + -> Orderer m sov b t + -> Processed (State t) + -> ExState rv hv sov t + -> Bindings + -> M.Map b [ExState rv hv sov t] + -> m (Processed (State t), Bindings) +runReducer' red hal ord pr rs@(ExState { state = s, reducer_val = r_val, halter_val = h_val, order_val = o_val }) b xs = do + hc <- stopRed hal h_val pr s + case () of + () + | hc == Accept -> do + onAccept red s r_val + let pr' = pr {accepted = state rs:accepted pr} + jrs = minState ord pr' xs + case jrs of + Just (rs', xs') -> switchState red hal ord pr' rs' b xs' + Nothing -> return (pr', b) + | hc == Discard -> + let + pr' = pr {discarded = state rs:discarded pr} + jrs = minState ord pr' xs + in + case jrs of + Just (rs', xs') -> + switchState red hal ord pr' rs' b xs' + Nothing -> return (pr', b) + | hc == Switch -> do + let rs' = rs { order_val = updateSelected ord (order_val rs) pr (state rs) } + k <- orderStates ord (order_val rs') pr (state rs) + let Just (rs'', xs') = minState ord pr (M.insertWith (++) k [rs'] xs) + switchState red hal ord pr rs'' b xs' + | otherwise -> do + (_, reduceds, b') <- redRules red r_val s b + let reduceds' = map (\(r, rv) -> (r {num_steps = num_steps r + 1}, rv)) reduceds + + r_vals = if length reduceds' > 1 + then updateWithAll red reduceds' ++ error "List returned by updateWithAll is too short." + else map snd reduceds + + reduceds_h_vals = map (\(r, _) -> (r, h_val)) reduceds' + h_vals = if length reduceds' > 1 + then updateHalterWithAll hal reduceds_h_vals ++ error "List returned by updateWithAll is too short." + else repeat h_val + + new_states = map fst reduceds' + + mod_info <- mapM (\(s', r_val', h_val') -> do + or_v <- stepOrderer ord o_val pr new_states s' + return $ rs { state = s' + , reducer_val = r_val' + , halter_val = stepHalter hal h_val' pr new_states s' + , order_val = or_v}) $ zip3 new_states r_vals h_vals + + + + + case mod_info of + (s_h:ss_tail) -> do + b_ss_tail <- mapM (\s' -> do + n_b <- orderStates ord (order_val s') pr (state s') + return (n_b, s')) ss_tail + + let xs' = foldr (\(or_b, s') -> M.insertWith (++) or_b [s']) xs b_ss_tail + + runReducer' red hal ord pr s_h b' xs' + [] -> runReducerList red hal ord pr xs b' + +{-# INLINABLE switchState #-} +switchState :: (Monad m, Ord b) + => Reducer m rv t + -> Halter m hv t + -> Orderer m sov b t + -> Processed (State t) + -> ExState rv hv sov t + -> Bindings + -> M.Map b [ExState rv hv sov t] + -> m (Processed (State t), Bindings) +switchState red hal ord pr rs b xs + | not $ discardOnStart hal (halter_val rs') pr (state rs') = + runReducer' red hal ord pr rs' b xs + | otherwise = + runReducerListSwitching red hal ord (pr {discarded = state rs':discarded pr}) xs b + where + rs' = rs { halter_val = updatePerStateHalt hal (halter_val rs) pr (state rs) } + +{-# INLINABLE runReducerList #-} +-- To be used when we we need to select a state without switching +runReducerList :: (Monad m, Ord b) + => Reducer m rv t + -> Halter m hv t + -> Orderer m sov b t + -> Processed (State t) + -> M.Map b [ExState rv hv sov t] + -> Bindings + -> m (Processed (State t), Bindings) +runReducerList red hal ord pr m binds = + case minState ord pr m of + Just (rs, m') -> + let + rs' = rs { halter_val = updatePerStateHalt hal (halter_val rs) pr (state rs) } + in + runReducer' red hal ord pr rs' binds m' + Nothing -> return (pr, binds) + +{-# INLINABLE runReducerListSwitching #-} +-- To be used when we are possibly switching states +runReducerListSwitching :: (Monad m, Ord b) + => Reducer m rv t + -> Halter m hv t + -> Orderer m sov b t + -> Processed (State t) + -> M.Map b [ExState rv hv sov t] + -> Bindings + -> m (Processed (State t), Bindings) +runReducerListSwitching red hal ord pr m binds = + case minState ord pr m of + Just (x, m') -> switchState red hal ord pr x binds m' + Nothing -> return (pr, binds) + +{-# INLINABLE minState #-} +-- Uses the Orderer to determine which state to continue execution on. +-- Returns that State, and a list of the rest of the states +minState :: Ord b + => Orderer m sov b t + -> Processed (State t) + -> M.Map b [ExState rv hv sov t] + -> Maybe ((ExState rv hv sov t), M.Map b [ExState rv hv sov t]) +minState ord pr m = + case getState m of + Just (k, x:[]) -> Just (x, M.delete k m) + Just (k, x:xs) -> Just (x, M.insert k xs m) + Just (k, []) -> minState ord pr $ M.delete k m + Nothing -> Nothing + diff --git a/src/G2/Execution/RuleTypes.hs b/src/G2/Execution/RuleTypes.hs --- a/src/G2/Execution/RuleTypes.hs +++ b/src/G2/Execution/RuleTypes.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} @@ -10,6 +11,11 @@ import G2.Language.Naming import G2.Language.Syntax +import Data.Hashable +import qualified Data.Sequence as S + +import GHC.Generics (Generic) + data Rule = RuleEvalVal | RuleEvalVarNonVal Name | RuleEvalVarVal Name @@ -73,12 +79,14 @@ | RuleTick | RuleOther - deriving (Show, Eq, Read, Typeable, Data) + deriving (Show, Eq, Read, Typeable, Data, Generic) +instance Hashable Rule + instance AST e => ASTContainer Rule e where containedASTs _ = [] modifyContainedASTs _ r = r instance Named Rule where - names _ = [] + names _ = S.empty rename _ _ = id diff --git a/src/G2/Execution/Rules.hs b/src/G2/Execution/Rules.hs --- a/src/G2/Execution/Rules.hs +++ b/src/G2/Execution/Rules.hs @@ -1,8 +1,9 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings, FlexibleContexts #-} module G2.Execution.Rules ( module G2.Execution.RuleTypes + , Sharing (..) , stdReduce - , evalVar + , evalVarSharing , evalApp , evalLam , retLam @@ -15,132 +16,130 @@ , evalAssume , evalAssert - , isExecValueForm ) where + , isExecValueForm + + , SymbolicFuncEval + , retReplaceSymbFuncVar + , retReplaceSymbFuncTemplate) where +import G2.Config.Config +import G2.Execution.NewPC import G2.Execution.NormalForms import G2.Execution.PrimitiveEval import G2.Execution.RuleTypes import G2.Language import qualified G2.Language.ExprEnv as E +import qualified G2.Language.TypeEnv as TE +import qualified G2.Language.Typing as T import qualified G2.Language.KnownValues as KV -import qualified G2.Language.PathConds as PC import qualified G2.Language.Stack as S +import G2.Preprocessing.NameCleaner import G2.Solver hiding (Assert) import Control.Monad.Extra import Data.Maybe +import qualified Data.HashMap.Lazy as HM +import qualified Data.List as L +import qualified Data.Sequence as S -stdReduce :: Solver solver => solver -> State t -> Bindings -> IO (Rule, [(State t, ())], Bindings) -stdReduce solver s b@(Bindings {name_gen = ng}) = do - (r, s', ng') <- stdReduce' solver s ng +import Control.Exception + +stdReduce :: (Solver solver, Simplifier simplifier) => Sharing -> SymbolicFuncEval t -> solver -> simplifier -> State t -> Bindings -> IO (Rule, [(State t, ())], Bindings) +stdReduce share symb_func_eval solver simplifier s b@(Bindings {name_gen = ng}) = do + (r, s', ng') <- stdReduce' share symb_func_eval solver simplifier s ng let s'' = map (\ss -> ss { rules = r:rules ss }) s' return (r, zip s'' (repeat ()), b { name_gen = ng'}) -stdReduce' :: Solver solver => solver -> State t -> NameGen -> IO (Rule, [State t], NameGen) -stdReduce' solver s@(State { curr_expr = CurrExpr Evaluate ce }) ng - | Var i <- ce = return $ evalVar s ng i - | App e1 e2 <- ce = return $ evalApp s ng e1 e2 +stdReduce' :: (Solver solver, Simplifier simplifier) => Sharing -> SymbolicFuncEval t -> solver -> simplifier -> State t -> NameGen -> IO (Rule, [State t], NameGen) +stdReduce' share _ solver simplifier s@(State { curr_expr = CurrExpr Evaluate ce }) ng + | Var i <- ce + , share == Sharing = return $ evalVarSharing s ng i + | Var i <- ce + , share == NoSharing = return $ evalVarNoSharing s ng i + | App e1 e2 <- ce = do + let (r, xs, ng') = evalApp s ng e1 e2 + xs' <- mapMaybeM (reduceNewPC solver simplifier) xs + return (r, xs', ng') | Let b e <- ce = return $ evalLet s ng b e - | Case e i a <- ce = do - let (r, xs, ng') = evalCase s ng e i a - xs' <- mapMaybeM (reduceNewPC solver) xs + | Case e i t a <- ce = do + let (r, xs, ng') = evalCase s ng e i t a + xs' <- mapMaybeM (reduceNewPC solver simplifier) xs return (r, xs', ng') | Cast e c <- ce = return $ evalCast s ng e c | Tick t e <- ce = return $ evalTick s ng t e | NonDet es <- ce = return $ evalNonDet s ng es - | SymGen t <- ce = return $ evalSymGen s ng t + | SymGen sl t <- ce = return $ evalSymGen s ng sl t | Assume fc e1 e2 <- ce = return $ evalAssume s ng fc e1 e2 | Assert fc e1 e2 <- ce = return $ evalAssert s ng fc e1 e2 | otherwise = return (RuleReturn, [s { curr_expr = CurrExpr Return ce }], ng) -stdReduce' solver s@(State { curr_expr = CurrExpr Return ce - , exec_stack = stck }) ng - | Prim Error _ <- ce +stdReduce' _ symb_func_eval solver simplifier s@(State { curr_expr = CurrExpr Return ce + , exec_stack = stck }) ng + | isError ce , Just (AssertFrame is _, stck') <- S.pop stck = return (RuleError, [s { exec_stack = stck' , true_assert = True - , assert_ids = is }], ng) - | Prim Error _ <- ce - , Just (_, stck') <- S.pop stck = return (RuleError, [s { exec_stack = stck' }], ng) + , assert_ids = fmap (\fc -> fc { returns = Prim Error TyBottom }) is }], ng) | Just (UpdateFrame n, stck') <- frstck = return $ retUpdateFrame s ng n stck' - | Lam u i e <- ce = return $ retLam s ng u i e - | Just (ApplyFrame e, stck') <- S.pop stck = return $ retApplyFrame s ng ce e stck' - | Just rs <- retReplaceSymbFunc s ng ce = return rs - | Just (CaseFrame i a, stck') <- frstck = return $ retCaseFrame s ng ce i a stck' + | isError ce + , Just (_, stck') <- S.pop stck = return (RuleError, [s { exec_stack = stck' }], ng) + | Just rs <- symb_func_eval s ng ce = return rs + | Just (CaseFrame i t a, stck') <- frstck = return $ retCaseFrame s ng ce i t a stck' | Just (CastFrame c, stck') <- frstck = return $ retCastFrame s ng ce c stck' + | Lam u i e <- ce + , Just (ApplyFrame ae, stck') <- S.pop stck = return $ retLam s ng u i e ae stck' + | Just (ApplyFrame e, stck') <- S.pop stck = return $ retApplyFrame s ng ce e stck' | Just (AssumeFrame e, stck') <- frstck = do let (r, xs, ng') = retAssumeFrame s ng ce e stck' - xs' <- mapMaybeM (reduceNewPC solver) xs + xs' <- mapMaybeM (reduceNewPC solver simplifier) xs return (r, xs', ng') | Just (AssertFrame ais e, stck') <- frstck = do let (r, xs, ng') = retAssertFrame s ng ce ais e stck' - xs' <- mapMaybeM (reduceNewPC solver) xs + xs' <- mapMaybeM (reduceNewPC solver simplifier) xs return (r, xs', ng') - | Just (CurrExprFrame e, stck') <- frstck = do - let (r, xs) = retCurrExpr s ce e stck' - xs' <- mapMaybeM (reduceNewPC solver) xs + | Just (CurrExprFrame act e, stck') <- frstck = do + let (r, xs) = retCurrExpr s ce act e stck' + xs' <- mapMaybeM (reduceNewPC solver simplifier) xs return (r, xs', ng) | Nothing <- frstck = return (RuleIdentity, [s], ng) | otherwise = error $ "stdReduce': Unknown Expr" ++ show ce ++ show (S.pop stck) where frstck = S.pop stck -data NewPC t = NewPC { state :: State t - , new_pcs :: [PathCond] } - -newPCEmpty :: State t -> NewPC t -newPCEmpty s = NewPC { state = s, new_pcs = []} - -reduceNewPC :: Solver solver => solver -> NewPC t -> IO (Maybe (State t)) -reduceNewPC solver - (NewPC { state = s@(State { known_values = kv - , path_conds = spc }) - , new_pcs = pc }) - | not (null pc) = do - -- In the case of newtypes, the PC exists we get may have the correct name - -- but incorrect type. - -- We do not want to add these to the State - -- This is a bit ugly, but not a huge deal, since the State already has PCExists - let pc' = filter (not . PC.isPCExists) pc - - -- Optimization - -- We replace the path_conds with only those that are directly - -- affected by the new path constraints - -- This allows for more efficient solving, and in some cases may - -- change an Unknown into a SAT or UNSAT - let new_pc = foldr (PC.insert kv) spc $ pc' - s' = s { path_conds = new_pc} - - let rel_pc = PC.filter (not . PC.isPCExists) $ PC.relevant kv pc new_pc - - res <- check solver s rel_pc + isError (Prim Error _) = True + isError (Prim Undefined _) = True + isError _ = False - if res == SAT then - return $ Just s' - else - return Nothing - | otherwise = return $ Just s +evalVarSharing :: State t -> NameGen -> Id -> (Rule, [State t], NameGen) +evalVarSharing s@(State { expr_env = eenv + , exec_stack = stck }) + ng i + | E.isSymbolic (idName i) eenv = + (RuleEvalVal, [s { curr_expr = CurrExpr Return (Var i)}], ng) + -- If the target in our environment is already a value form, we do not + -- need to push additional redirects for updating later on. + -- If our variable is not in value form, we first push the + -- current name of the variable onto the stack and evaluate the + -- expression that it points to. After the evaluation, + -- we pop the stack to add a redirection pointer into the heap. + | Just e' <- e + , isExprValueForm eenv e' = + ( RuleEvalVarVal (idName i), [s { curr_expr = CurrExpr Evaluate e' }], ng) + | Just e' <- e = -- e' is NOT in SWHNF + ( RuleEvalVarNonVal (idName i) + , [s { curr_expr = CurrExpr Evaluate e' + , exec_stack = S.push (UpdateFrame (idName i)) stck }] + , ng) + | otherwise = error $ "evalVar: bad input." ++ show i + where + e = E.lookup (idName i) eenv -evalVar :: State t -> NameGen -> Id -> (Rule, [State t], NameGen) -evalVar s@(State { expr_env = eenv - , exec_stack = stck }) - ng i +evalVarNoSharing :: State t -> NameGen -> Id -> (Rule, [State t], NameGen) +evalVarNoSharing s@(State { expr_env = eenv }) + ng i | E.isSymbolic (idName i) eenv = (RuleEvalVal, [s { curr_expr = CurrExpr Return (Var i)}], ng) | Just e <- E.lookup (idName i) eenv = - -- If the target in our environment is already a value form, we do not - -- need to push additional redirects for updating later on. - -- If our variable is not in value form, we first push the - -- current name of the variable onto the stack and evaluate the - -- expression that it points to. After the evaluation, - -- we pop the stack to add a redirection pointer into the heap. - let - (r, stck') = if isExprValueForm eenv e - then ( RuleEvalVarVal (idName i), stck) - else ( RuleEvalVarNonVal (idName i) - , S.push (UpdateFrame (idName i)) stck) - in - (r, [s { curr_expr = CurrExpr Evaluate e - , exec_stack = stck' }], ng) + (RuleEvalVarNonVal (idName i), [s { curr_expr = CurrExpr Evaluate e }], ng) | otherwise = error $ "evalVar: bad input." ++ show i -- | If we have a primitive operator, we are at a point where either: @@ -148,39 +147,40 @@ -- (2) We have a symbolic value, and no evaluation is possible, so we return -- If we do not have a primitive operator, we go into the center of the apps, -- to evaluate the function call -evalApp :: State t -> NameGen -> Expr -> Expr -> (Rule, [State t], NameGen) +evalApp :: State t -> NameGen -> Expr -> Expr -> (Rule, [NewPC t], NameGen) evalApp s@(State { expr_env = eenv + , type_env = tenv , known_values = kv , exec_stack = stck }) ng e1 e2 - | (App (Prim BindFunc _) v) <- e1 - , Var i1 <- findSym v - , v2 <- e2 = - ( RuleBind - , [s { expr_env = E.insert (idName i1) v2 eenv - , curr_expr = CurrExpr Return (mkTrue kv) }] - , ng) - | isExprValueForm eenv (App e1 e2) = - ( RuleReturnAppSWHNF - , [s { curr_expr = CurrExpr Return (App e1 e2) }] - , ng) + | ac@(Prim Error _) <- appCenter e1 = + (RuleError, [newPCEmpty $ s { curr_expr = CurrExpr Return ac }], ng) + | Just (e, eenv', pc, ng') <- evalPrimSymbolic eenv tenv ng kv (App e1 e2) = + ( RuleEvalPrimToNorm + , [ (newPCEmpty $ s { expr_env = eenv' + , curr_expr = CurrExpr Return e }) { new_pcs = pc} ] + , ng') | (Prim prim ty):ar <- unApp (App e1 e2) = let ar' = map (lookupForPrim eenv) ar appP = mkApp (Prim prim ty : ar') - exP = evalPrims kv appP + exP = evalPrims tenv kv appP in ( RuleEvalPrimToNorm - , [s { curr_expr = CurrExpr Return exP }] + , [newPCEmpty $ s { curr_expr = CurrExpr Return exP }] , ng) + | isExprValueForm eenv (App e1 e2) = + ( RuleReturnAppSWHNF + , [newPCEmpty $ s { curr_expr = CurrExpr Return (App e1 e2) }] + , ng) | otherwise = let frame = ApplyFrame e2 stck' = S.push frame stck in ( RuleEvalApp e2 - , [s { curr_expr = CurrExpr Evaluate e1 - , exec_stack = stck' }] + , [newPCEmpty $ s { curr_expr = CurrExpr Evaluate e1 + , exec_stack = stck' }] , ng) where findSym v@(Var (Id n _)) @@ -206,38 +206,32 @@ evalLam :: State t -> LamUse -> Id -> Expr -> (Rule, [State t]) evalLam = undefined -retLam :: State t -> NameGen -> LamUse -> Id -> Expr -> (Rule, [State t], NameGen) -retLam s@(State { expr_env = eenv - , exec_stack = stck }) - ng u i e - | TypeL <- u - , Just (ApplyFrame tf, stck') <- S.pop stck = - case traceType eenv tf of +retLam :: State t -> NameGen -> LamUse -> Id -> Expr -> Expr -> S.Stack Frame -> (Rule, [State t], NameGen) +retLam s@(State { expr_env = eenv }) + ng u i e ae stck' + | TypeL <- u = + case traceType eenv ae of Just t -> let - e' = retype i t e + e' = retypeRespectingTyForAll i t e - binds = [(i, Type t)] - (eenv', e'', ng', news) = liftBinds binds eenv e' ng + (eenv', e'', ng', news) = liftBind i (Type t) eenv e' ng in - ( RuleReturnEApplyLamType news + ( RuleReturnEApplyLamType [news] , [s { expr_env = eenv' , curr_expr = CurrExpr Evaluate e'' , exec_stack = stck' }] , ng') - Nothing -> error "retLam: Bad type" - | TermL <- u - , Just (ApplyFrame ae, stck') <- S.pop stck = + Nothing -> error $ "retLam: Bad type\ni = " ++ show i + | otherwise = let - binds = [(i, ae)] - (eenv', e', ng', news) = liftBinds binds eenv e ng + (eenv', e', ng', news) = liftBind i ae eenv e ng in - ( RuleReturnEApplyLamExpr news + ( RuleReturnEApplyLamExpr [news] , [s { expr_env = eenv' , curr_expr = CurrExpr Evaluate e' , exec_stack = stck' }] ,ng') - | otherwise = error "retLam: Bad type" traceType :: E.ExprEnv -> Expr -> Maybe Type traceType _ (Type t) = Just t @@ -263,10 +257,10 @@ , ng') -- | Handle the Case forms of Evaluate. -evalCase :: State t -> NameGen -> Expr -> Id -> [Alt] -> (Rule, [NewPC t], NameGen) +evalCase :: State t -> NameGen -> Expr -> Id -> Type -> [Alt] -> (Rule, [NewPC t], NameGen) evalCase s@(State { expr_env = eenv , exec_stack = stck }) - ng mexpr bind alts + ng mexpr bind t alts -- Is the current expression able to match with a literal based `Alt`? If -- so, we do the cvar binding, and proceed with evaluation of the body. | (Lit lit) <- unsafeElimOuterCast mexpr @@ -306,7 +300,11 @@ -- We hit a DEFAULT instead. -- We perform the cvar binding and proceed with the alt -- expression. - | (Data _):_ <- unApp $ unsafeElimOuterCast mexpr + | e:_ <- unApp $ unsafeElimOuterCast mexpr + , isData e + || isLit e + || isLam e + || (case e of Var i@(Id n _) -> E.isSymbolic n eenv && hasFuncType i; _ -> False) , (Alt _ expr):_ <- matchDefaultAlts alts = let binds = [(bind, mexpr)] @@ -336,9 +334,12 @@ _ -> error $ "unmatched expr" ++ show (unApp $ unsafeElimOuterCast mexpr) lsts_cs = liftSymLitAlt s mexpr bind lalts - def_sts = liftSymDefAlt s mexpr bind alts + (def_sts, ng'') = liftSymDefAlt s ng' mexpr bind alts + + alt_res = dsts_cs ++ lsts_cs ++ def_sts in - (RuleEvalCaseSym, dsts_cs ++ lsts_cs ++ def_sts, ng') + assert (length alt_res == length dalts + length lalts + length defs) + (RuleEvalCaseSym, alt_res, ng'') -- Case evaluation also uses the stack in graph reduction based evaluation -- semantics. The case's binding variable and alts are pushed onto the stack @@ -346,7 +347,7 @@ -- is only done when the matching expression is NOT in value form. Value -- forms should be handled by other RuleEvalCase* rules. | not (isExprValueForm eenv mexpr) = - let frame = CaseFrame bind alts + let frame = CaseFrame bind t alts in ( RuleEvalCaseNonVal , [newPCEmpty $ s { expr_env = eenv , curr_expr = CurrExpr Evaluate mexpr @@ -357,28 +358,29 @@ -- | Remove everything from an [Expr] that are actually Types. removeTypes :: [Expr] -> E.ExprEnv -> [Expr] removeTypes ((Type _):es) eenv = removeTypes es eenv -removeTypes ((Var (Id n ty)):es) eenv = case E.lookup n eenv of - Just (Type _) -> removeTypes es eenv - _ -> (Var (Id n ty)) : removeTypes es eenv +removeTypes (v@(Var _):es) eenv = case repeatedLookup eenv v of + (Type _) -> removeTypes es eenv + -- Just v@(Var (Id n' _)) -> removeTypes (v:es) eenv + _ -> v : removeTypes es eenv removeTypes (e:es) eenv = e : removeTypes es eenv removeTypes [] _ = [] -- | DEFAULT `Alt`s. matchDefaultAlts :: [Alt] -> [Alt] -matchDefaultAlts alts = [a | a @ (Alt Default _) <- alts] +matchDefaultAlts alts = [a | a@(Alt Default _) <- alts] -- | Match data constructor based `Alt`s. matchDataAlts :: DataCon -> [Alt] -> [Alt] matchDataAlts (DataCon n _) alts = - [a | a @ (Alt (DataAlt (DataCon n' _) _) _) <- alts, n == n'] + [a | a@(Alt (DataAlt (DataCon n' _) _) _) <- alts, n == n'] -- | Match literal constructor based `Alt`s. matchLitAlts :: Lit -> [Alt] -> [Alt] -matchLitAlts lit alts = [a | a @ (Alt (LitAlt alit) _) <- alts, lit == alit] +matchLitAlts lit alts = [a | a@(Alt (LitAlt alit) _) <- alts, lit == alit] liftCaseBinds :: [(Id, Expr)] -> Expr -> Expr liftCaseBinds [] expr = expr -liftCaseBinds ((b, e):xs) expr = liftCaseBinds xs $ replaceASTs (Var b) e expr +liftCaseBinds ((b, e):xs) expr = liftCaseBinds xs $ replaceVar (idName b) e expr -- | `DataCon` `Alt`s. dataAlts :: [Alt] -> [(DataCon, [Id], Expr)] @@ -390,7 +392,7 @@ -- | DEFAULT `Alt`s. defaultAlts :: [Alt] -> [Alt] -defaultAlts alts = [a | a @ (Alt Default _) <- alts] +defaultAlts alts = [a | a@(Alt Default _) <- alts] -- | Lift positive datacon `State`s from symbolic alt matching. This in -- part involves erasing all of the parameters from the environment by rename @@ -404,40 +406,31 @@ (newPCs, ng'') = concretizeVarExpr s ng' mexpr_id cvar xs maybeC concretizeVarExpr' :: State t -> NameGen -> Id -> Id -> (DataCon, [Id], Expr) -> Maybe Coercion -> (NewPC t, NameGen) -concretizeVarExpr' s@(State {expr_env = eenv, type_env = tenv, symbolic_ids = syms}) - ngen mexpr_id cvar (dcon, params, aexpr) maybeC = +concretizeVarExpr' s@(State {expr_env = eenv, type_env = tenv, known_values = kv}) + ngen mexpr_id cvar (dcon, params, aexpr) maybeC = (NewPC { state = s { expr_env = eenv'' - , symbolic_ids = syms' , curr_expr = CurrExpr Evaluate aexpr''} - -- It is VERY important that we insert a PCExists with the mexpr_id + -- It is VERY important that we insert the mexpr_id in `concretized` -- This forces reduceNewPC to check that the concretized data constructor does -- not violate any path constraints from default cases. - , new_pcs = [PCExists mexpr_id] - }, ngen') + , new_pcs = pcs + , concretized = [mexpr_id] + }, ngen'') where -- Make sure that the parameters do not conflict in their symbolic reps. olds = map idName params - - -- [ChildrenNames] - -- Optimization - -- We use the same names repeatedly for the children of the same ADT - -- Haskell is purely functional, so this is OK! The children can't change - -- Then, in the constraint solver, we can consider fewer constraints at once - -- (see note [AltCond] in Language/PathConds.hs) - mexpr_n = idName mexpr_id - (news, ngen') = childrenNames mexpr_n olds ngen + clean_olds = map cleanName olds - --Update the expr environment - newIds = map (\(Id _ t, n) -> (n, Id n t)) (zip params news) - eenv' = foldr (uncurry E.insertSymbolic) eenv newIds + (news, ngen') = freshSeededNames clean_olds ngen (dcon', aexpr') = renameExprs (zip olds news) (Data dcon, aexpr) newparams = map (uncurry Id) $ zip news (map typeOf params) dConArgs = (map (Var) newparams) -- Get list of Types to concretize polymorphic data constructor and concatenate with other arguments - mexpr_t = (\(Id _ t) -> t) (mexpr_id) - exprs = [dcon'] ++ (mexprTyToExpr mexpr_t tenv) ++ dConArgs + mexpr_t = typeOf mexpr_id + type_ars = mexprTyToExpr mexpr_t tenv + exprs = [dcon'] ++ type_ars ++ dConArgs -- Apply list of types (if present) and DataCon children to DataCon dcon'' = mkApp exprs @@ -447,22 +440,96 @@ (Just (t1 :~ t2)) -> Cast dcon'' (t2 :~ t1) Nothing -> dcon'' - syms' = newparams ++ (filter (/= mexpr_id) syms) - - -- concretizes the mexpr to have same form as the DataCon specified - eenv'' = E.insert mexpr_n dcon''' eenv' - -- Now do a round of rename for binding the cvar. binds = [(cvar, (Var mexpr_id))] aexpr'' = liftCaseBinds binds aexpr' - + (eenv'', pcs, ngen'') = adjustExprEnvAndPathConds kv tenv eenv ngen' dcon dcon''' mexpr_id params news + +-- [String Concretizations and Constraints] +-- Generally speaking, the values of symbolic variable are determined by one of two methods: +-- in the case of primitive values (Int#, Float#, ...), we generate path constraints, which can be solved +-- via an SMT solver. In the case of algebraic data types, we use concretization, in which +-- the symbolic variable is replaced by a (partially) concrete expression. +-- +-- We play a bit of a funny trick for Strings. In Haskell, String is really just a type alias +-- for a list of Chars: +-- type String = [Char] +-- The obvious thing to do, then, is just allow concretization to kick in: and indeed, this is sometimes +-- necessary, if a String is directly pattern matched on, or if a String is passed to a function expecting +-- a generic list [a]. +-- +-- However, SMT solvers also support reasoning about Strings, and concretization can sometimes lead to a blow up +-- in the state space. For instance, when applying +-- show :: Int -> String +-- concretization would result in infinite recursive branching to potentially print different Ints. +-- Thus, it is appealing to allow reasoning about Strings in the SMT solver, when possible, to avoid this blowup. +-- +-- In principle, allowing reasoning about Strings both via concretization and the SMT solver: we simply perform both +-- concretization and path constraint generation. Care must be taken to keep this in sync. That is, we must +-- ensure that the value of a String is equally constrained by both the concretization and the generated path constraints. +-- When a String s is concretized to the empty String, [], we generate a path constraint that `strLen s == 0`. +-- When a String s is concretized to a cons, (C# c:xs), we generate a path constraint that `c ++ xs == s`. +-- Note that in the cons case, we must also concretize the Char in the list to obtain the primitive Char#, +-- as this will be the symbolic variable that may be inserted into other path constraints. + +-- | Determines an ExprEnv and Path Constraints from following a particular branch of symbolic execution. +-- Has special handling for Strings- see [String Concretizations and Constraints] +adjustExprEnvAndPathConds :: KnownValues + -> TypeEnv + -> ExprEnv + -> NameGen + -> DataCon -- ^ The data con in the scrutinee (as in `case scrutinee of ...`) + -> Expr -- ^ The scrutinee + -> Id -- ^ Symbolic Variable Id + -> [Id] -- ^ Constructor Argument Ids + -> [Name] + -> (ExprEnv, [PathCond], NameGen) +adjustExprEnvAndPathConds kv tenv eenv ng dc dc_e mexpr params dc_args + | Just (dcName dc) == fmap dcName (getDataCon tenv (KV.tyList kv) (KV.dcEmpty kv)) + , typeOf mexpr == TyApp (T.tyList kv) (T.tyChar kv) = + assert (length params == 0) + (eenv'' + , [ExtCond (mkEqExpr kv + (App (mkStringLen kv) (Var mexpr)) + (Lit (LitInt 0))) + True] + , ng) + | Just (dcName dc) == fmap dcName (getDataCon tenv (KV.tyList kv) (KV.dcCons kv)) + , typeOf mexpr == TyApp (T.tyList kv) (T.tyChar kv) + , [_, _] <- params + , [arg_h, arg_t] <- newIds = + let + (char_i, ng') = freshId TyLitChar ng + char_dc = App (mkDCChar kv tenv) (Var char_i) + eenv''' = E.insertSymbolic char_i $ E.insert (idName arg_h) char_dc eenv'' + in + assert (length params == 2) + (eenv''' + , [ExtCond (mkEqExpr kv + (App (App (mkStringAppend kv) (Var char_i)) (Var arg_t)) + (Var mexpr)) + True] + , ng') + | otherwise = (eenv'', [], ng) + where + mexpr_n = idName mexpr + + --Update the expr environment + newIds = zipWith (\(Id _ t) n -> Id n t) params dc_args + eenv' = foldr E.insertSymbolic eenv newIds + -- concretizes the mexpr to have same form as the DataCon specified + eenv'' = E.insert mexpr_n dc_e eenv' + -- | Given the Type of the matched Expr, looks for Type in the TypeEnv, and returns Expr level representation of the Type mexprTyToExpr :: Type -> TypeEnv -> [Expr] -mexprTyToExpr mexpr_t tenv +mexprTyToExpr mexpr_t = reverse . mexprTyToExpr' mexpr_t + +mexprTyToExpr' :: Type -> TypeEnv -> [Expr] +mexprTyToExpr' mexpr_t tenv -- special case for NewTyCon, involves looking up tyVars and binding them to concrete types specified by mexpr_t | Just (algDataTy, bindings) <- getAlgDataTy mexpr_t tenv - , (isNewTyCon algDataTy) = dconTyToExpr (data_con algDataTy) bindings + , NewTyCon {} <- algDataTy = dconTyToExpr (data_con algDataTy) bindings | otherwise = typeToExpr mexpr_t -- | Given a DataCon, and an (Id, Type) mapping, returns list of Expression level Type Arguments to DataCon @@ -480,22 +547,76 @@ (x', ng') = createExtCond s ng mexpr cvar x (newPCs, ng'') = createExtConds s ng' mexpr cvar xs +-- | Creating a path constraint. The passed Expr should have type Bool or type [Char]. +-- In the latter case, the note [String Concretizations and Constraints] is relevant. createExtCond :: State t -> NameGen -> Expr -> Id -> (DataCon, [Id], Expr) -> (NewPC t, NameGen) -createExtCond s ngen mexpr cvar (dcon, _, aexpr) = - (NewPC { state = res, new_pcs = [cond] }, ngen) - where - -- Get the Bool value specified by the matching DataCon - -- Throws an error if dcon is not a Bool Data Constructor - boolValue = getBoolFromDataCon s dcon - cond = ExtCond mexpr boolValue +createExtCond s ngen mexpr cvar (dcon, bindees, aexpr) + | typeOf mexpr == tyBool kv = + let + -- Get the Bool value specified by the matching DataCon + -- Throws an error if dcon is not a Bool Data Constructor + boolValue = getBoolFromDataCon (known_values s) dcon + cond = ExtCond mexpr boolValue - -- Now do a round of rename for binding the cvar. - binds = [(cvar, mexpr)] - aexpr' = liftCaseBinds binds aexpr - res = s {curr_expr = CurrExpr Evaluate aexpr'} + -- Now do a round of rename for binding the cvar. + binds = [(cvar, mexpr)] + aexpr' = liftCaseBinds binds aexpr + res = s {curr_expr = CurrExpr Evaluate aexpr'} + in + (NewPC { state = res, new_pcs = [cond] , concretized = []}, ngen) + | Just (dcName dcon) == fmap dcName (getDataCon tenv (KV.tyList kv) (KV.dcEmpty kv)) = + -- Concretize a primitive application which creates a symbolic [Char] into an empty list. + let + eq_str = ExtCond (mkEqExpr kv + (App (mkStringLen kv) mexpr) + (Lit (LitInt 0))) + True + + new_list = App (mkEmpty kv tenv) (Type $ tyChar kv) + binds = [(cvar, new_list)] + aexpr' = liftCaseBinds binds aexpr + res = s { curr_expr = CurrExpr Return aexpr' } + in + (NewPC { state = res, new_pcs = [eq_str] , concretized = []}, ngen) -getBoolFromDataCon :: State t -> DataCon -> Bool -getBoolFromDataCon (State {known_values = kv}) dcon + | Just (dcName dcon) == fmap dcName (getDataCon tenv (KV.tyList kv) (KV.dcCons kv)) + , [h, t] <- bindees = + -- Concretize a primitive application which creates a symbolic [Char] into symbolic head and tail. + let + ty_char_list = TyApp (tyList kv) (tyChar kv) + + (n_char, ng') = freshSeededName (idName cvar) ngen + (n_char_list, ng'') = freshSeededName (idName cvar) ng' + + i_char = Id n_char TyLitChar + v_char = Var i_char + dc_char = App (mkDCChar kv tenv) v_char + + i_char_list = Id n_char_list ty_char_list + v_char_list = Var i_char_list + + eq_str = ExtCond (mkEqExpr kv + (App (App (mkStringAppend kv) v_char) v_char_list) + mexpr) + True + + new_list = App (App (App (mkCons kv tenv) (Type $ tyChar kv)) dc_char) v_char_list + binds = [(cvar, new_list), (h, dc_char), (t, v_char_list)] + aexpr' = liftCaseBinds binds aexpr + res = s { expr_env = E.insertSymbolic i_char $ E.insertSymbolic i_char_list (expr_env s) + , curr_expr = CurrExpr Return aexpr' } + in + (NewPC { state = res, new_pcs = [eq_str] , concretized = [i_char, i_char_list]}, ng'') + | otherwise = error $ "createExtCond: unsupported type" ++ "\n" ++ show (typeOf mexpr) ++ "\n" ++ show dcon + where + kv = known_values s + tenv = type_env s + + + + +getBoolFromDataCon :: KnownValues -> DataCon -> Bool +getBoolFromDataCon kv dcon | (DataCon dconName dconType) <- dcon , dconType == (tyBool kv) , dconName == (KV.dcTrue kv) = True @@ -510,7 +631,7 @@ -- | Lift literal alts found in symbolic case matching. liftSymLitAlt' :: State t -> Expr -> Id -> (Lit, Expr) -> NewPC t liftSymLitAlt' s mexpr cvar (lit, aexpr) = - NewPC { state = res, new_pcs = [cond] } + NewPC { state = res, new_pcs = [cond] , concretized = [] } where -- Condition that was matched. cond = AltCond lit mexpr True @@ -519,40 +640,134 @@ aexpr' = liftCaseBinds binds aexpr res = s { curr_expr = CurrExpr Evaluate aexpr' } -liftSymDefAlt :: State t -> Expr -> Id -> [Alt] -> [NewPC t] -liftSymDefAlt s mexpr cvar as = +---------------------------------------------------- +-- Default Alternatives + +liftSymDefAlt :: State t -> NameGen -> Expr -> Id -> [Alt] -> ([NewPC t], NameGen) +liftSymDefAlt s ng mexpr cvar as = let - aexpr = defAltExpr as + match = defAltExpr as in - case aexpr of - Just aexpr' -> liftSymDefAlt' s mexpr aexpr' cvar as - _ -> [] + case match of + Just aexpr -> liftSymDefAlt' s ng mexpr aexpr cvar as -- (liftSymDefAlt'' s mexpr aexpr cvar as, ng) + _ -> ([], ng) -liftSymDefAlt' :: State t -> Expr -> Expr -> Id -> [Alt] -> [NewPC t] -liftSymDefAlt' s mexpr aexpr cvar as = +-- | Concretize Symbolic variable to Case Expr on its possible Data Constructors +liftSymDefAlt' :: State t -> NameGen -> Expr -> Expr -> Id -> [Alt] -> ([NewPC t], NameGen) +liftSymDefAlt' s@(State {type_env = tenv}) ng mexpr aexpr cvar alts + | (Var i):_ <- unApp $ unsafeElimOuterCast mexpr + , isADTType (typeOf i) + , (Var i'):_ <- unApp $ exprInCasts mexpr = -- Id with original Type + let (adt, bi) = fromJust $ getCastedAlgDataTy (typeOf i) tenv + maybeC = case mexpr of + (Cast _ c) -> Just c + _ -> Nothing + dcs = dataCon adt + badDCs = mapMaybe (\alt -> case alt of + (Alt (DataAlt (DataCon dcn _) _) _) -> Just dcn + _ -> Nothing) alts + dcs' = filter (\(DataCon dcn _) -> dcn `notElem` badDCs) dcs + + (newId, ng') = freshId TyLitInt ng + + ((s', ng''), dcs'') = L.mapAccumL (concretizeSym bi maybeC) (s, ng') dcs' + + mexpr' = createCaseExpr newId (typeOf i) dcs'' + binds = [(cvar, mexpr')] + aexpr' = liftCaseBinds binds aexpr + + -- add PC restricting range of values for newSymId + newSymConstraint = restrictSymVal (known_values s') 1 (toInteger $ length dcs'') newId + + eenv' = E.insert (idName i') mexpr' (expr_env s') + s'' = s' { curr_expr = CurrExpr Evaluate aexpr' + , expr_env = eenv'} + in + ([NewPC { state = s'', new_pcs = [newSymConstraint], concretized = [] }], ng'') + | Prim _ _:_ <- unApp mexpr = (liftSymDefAlt'' s mexpr aexpr cvar alts, ng) + | isPrimType (typeOf mexpr) = (liftSymDefAlt'' s mexpr aexpr cvar alts, ng) + | otherwise = error $ "liftSymDefAlt': unhandled Expr" ++ "\n" ++ show mexpr + +liftSymDefAlt'' :: State t -> Expr -> Expr -> Id -> [Alt] -> [NewPC t] +liftSymDefAlt'' s mexpr aexpr cvar as = let - conds = mapMaybe (liftSymDefAltPCs mexpr) (map altMatch as) + conds = mapMaybe (liftSymDefAltPCs (known_values s) mexpr) (map altMatch as) binds = [(cvar, mexpr)] aexpr' = liftCaseBinds binds aexpr in [NewPC { state = s { curr_expr = CurrExpr Evaluate aexpr' } - , new_pcs = conds }] + , new_pcs = conds + , concretized = [] }] +liftSymDefAltPCs :: KnownValues -> Expr -> AltMatch -> Maybe PathCond +liftSymDefAltPCs kv mexpr (DataAlt dc _) = -- Only DataAlts would be True/False + let boolVal = getBoolFromDataCon kv dc + in case boolVal of + True -> Just $ ExtCond mexpr False + False -> Just $ ExtCond mexpr True +liftSymDefAltPCs _ mexpr (LitAlt lit) = Just $ AltCond lit mexpr False +liftSymDefAltPCs _ _ Default = Nothing + defAltExpr :: [Alt] -> Maybe Expr defAltExpr [] = Nothing defAltExpr (Alt Default e:_) = Just e defAltExpr (_:xs) = defAltExpr xs -liftSymDefAltPCs :: Expr -> AltMatch -> Maybe PathCond -liftSymDefAltPCs mexpr (DataAlt dc _) = Just $ ConsCond dc mexpr False -liftSymDefAltPCs mexpr (LitAlt lit) = Just $ AltCond lit mexpr False -liftSymDefAltPCs _ Default = Nothing +-- | Creates and applies new symbolic variables for arguments of Data Constructor +concretizeSym :: [(Id, Type)] -> Maybe Coercion -> (State t, NameGen) -> DataCon -> ((State t, NameGen), Expr) +concretizeSym bi maybeC (s, ng) dc@(DataCon _ ts) = + let dc' = Data dc + ts' = anonArgumentTypes $ PresType ts + ts'' = foldr (\(i, t) e -> retype i t e) ts' bi + (ns, ng') = freshNames (length ts'') ng + newParams = map (\(n, t) -> Id n t) (zip ns ts'') + ts2 = map snd bi + dc'' = mkApp $ dc' : (map Type ts2) ++ (map Var newParams) + dc''' = case maybeC of + (Just (t1 :~ t2)) -> Cast dc'' (t2 :~ t1) + Nothing -> dc'' + eenv = foldr E.insertSymbolic (expr_env s) newParams + in ((s {expr_env = eenv} , ng'), dc''') +createCaseExpr :: Id -> Type -> [Expr] -> Expr +createCaseExpr _ _ [e] = e +createCaseExpr newId t es@(_:_) = + let + -- We assume that PathCond restricting newId's range is added elsewhere + (_, alts) = bindExprToNum (\num e -> Alt (LitAlt (LitInt num)) e) es + in Case (Var newId) newId t alts +createCaseExpr _ _ [] = error "No exprs" + +bindExprToNum :: (Integer -> a -> b) -> [a] -> (Integer, [b]) +bindExprToNum f es = L.mapAccumL (\num e -> (num + 1, f num e)) 1 es + + +-- | Return PathCond restricting value of `newId` to [lower, upper] +restrictSymVal :: KnownValues -> Integer -> Integer -> Id -> PathCond +restrictSymVal kv lower upper newId = + ExtCond (mkAndExpr kv (mkGeIntExpr kv (Var newId) lower) (mkLeIntExpr kv (Var newId) upper)) True + +---------------------------------------------------- + evalCast :: State t -> NameGen -> Expr -> Coercion -> (Rule, [State t], NameGen) -evalCast s@(State { exec_stack = stck }) - ng e c - | cast /= cast' = +evalCast s@(State { expr_env = eenv + , exec_stack = stck }) + ng e c@(t1 :~ t2) + | Var (Id n _) <- e + , E.isSymbolic n eenv + , hasFuncType (PresType t2) && not (hasFuncType $ PresType t1) = + let + (i, ng') = freshId t2 ng + new_e = Cast (Var i) (t2 :~ t1) + in + ( RuleOther + , [s { expr_env = E.insertSymbolic i $ E.insert n new_e eenv + , curr_expr = CurrExpr Return (Var i) }] + , ng') + | cast <- Cast e c + , (cast', ng') <- splitCast ng cast + , cast /= cast' = ( RuleEvalCastSplit , [ s { curr_expr = CurrExpr Evaluate $ simplifyCasts cast' }] , ng') @@ -562,8 +777,7 @@ , exec_stack = S.push frame stck}] , ng) where - cast = Cast e c - (cast', ng') = splitCast ng cast + frame = CastFrame c evalTick :: State t -> NameGen -> Tickish -> Expr -> (Rule, [State t], NameGen) @@ -576,18 +790,21 @@ in (RuleNonDet, s', ng) -evalSymGen :: State t -> NameGen -> Type -> (Rule, [State t], NameGen) +evalSymGen :: State t -> NameGen -> SymLog -> Type -> (Rule, [State t], NameGen) evalSymGen s@( State { expr_env = eenv }) - ng t = + ng sl t = let (n, ng') = freshSeededString "symG" ng i = Id n t - eenv' = E.insertSymbolic n i eenv + eenv' = E.insertSymbolic i eenv + sg = case sl of + SLog -> sym_gens s S.:|> n + SNoLog -> sym_gens s in (RuleSymGen, [s { expr_env = eenv' , curr_expr = CurrExpr Evaluate (Var i) - , symbolic_ids = i:symbolic_ids s }] + , sym_gens = sg }] , ng') evalAssume :: State t -> NameGen -> Maybe FuncCall -> Expr -> Expr -> (Rule, [State t], NameGen) @@ -639,10 +856,10 @@ , [s { curr_expr = CurrExpr Evaluate (App e1 e2) , exec_stack = stck' }], ng) -retCaseFrame :: State t -> NameGen -> Expr -> Id -> [Alt] -> S.Stack Frame -> (Rule, [State t], NameGen) -retCaseFrame s b e i a stck = +retCaseFrame :: State t -> NameGen -> Expr -> Id -> Type -> [Alt] -> S.Stack Frame -> (Rule, [State t], NameGen) +retCaseFrame s b e i t a stck = ( RuleReturnECase - , [s { curr_expr = CurrExpr Evaluate (Case e i a) + , [s { curr_expr = CurrExpr Evaluate (Case e i t a) , exec_stack = stck }] , b) @@ -653,12 +870,83 @@ , exec_stack = stck}] , ng) -retCurrExpr :: State t -> Expr -> CurrExpr -> S.Stack Frame -> (Rule, [NewPC t]) -retCurrExpr s e1 e2 stck = +retCurrExpr :: State t -> Expr -> CEAction -> CurrExpr -> S.Stack Frame -> (Rule, [NewPC t]) +retCurrExpr s@(State { expr_env = eenv, known_values = kv }) e1 (EnsureEq e2) orig_ce stck + | e1 == e2 = + ( RuleReturnCurrExprFr + , [NewPC { state = s { curr_expr = orig_ce + , exec_stack = stck } + , new_pcs = [] + , concretized = [] }] ) + | Cast e1' c1 <- e1 + , Cast e2' c2 <- e2 + , c1 == c2 = retCurrExpr s e1' (EnsureEq e2') orig_ce stck + + | isExprValueForm eenv e1 + , isExprValueForm eenv e2 + , t1 <- typeOf e1 + , isPrimType t1 || t1 == tyBool kv = + assert (typeOf e2 == t1) + ( RuleReturnCurrExprFr + , [NewPC { state = s { curr_expr = orig_ce + , exec_stack = stck} + , new_pcs = [ExtCond (mkEqPrimExpr kv e1 e2) True] + , concretized = [] }] ) + + -- Symmetric cases for e1/e2 being symbolic variables + | Var (Id n t) <- e1 + , E.isSymbolic n eenv + , not (isPrimType t || t == tyBool kv) = + ( RuleReturnCurrExprFr + , [NewPC { state = s { curr_expr = orig_ce + , expr_env = E.insert n e2 eenv + , exec_stack = stck} + , new_pcs = [] + , concretized = [] }] ) + | Var (Id n t) <- e2 + , E.isSymbolic n eenv + , not (isPrimType t || t == tyBool kv) = + ( RuleReturnCurrExprFr + , [NewPC { state = s { curr_expr = orig_ce + , expr_env = E.insert n e1 eenv + , exec_stack = stck} + , new_pcs = [] + , concretized = [] }] ) + + | Data dc1:es1 <- unApp e1 + , Data dc2:es2 <- unApp e2 = + case dc1 == dc2 of + True -> + let + es = zip es1 es2 + in + ( RuleReturnCurrExprFr + , [NewPC { state = s { curr_expr = orig_ce + , non_red_path_conds = es ++ non_red_path_conds s + , exec_stack = stck} + , new_pcs = [] + , concretized = [] }] ) + False -> + ( RuleReturnCurrExprFr + , [NewPC { state = s { curr_expr = orig_ce + , exec_stack = stck} + , new_pcs = [ExtCond (mkFalse kv) True] + , concretized = [] }] ) + | otherwise = + assert (not (isExprValueForm eenv e2)) + ( RuleReturnCurrExprFr + , [NewPC { state = s { curr_expr = CurrExpr Evaluate e2 + , non_red_path_conds = non_red_path_conds s + , exec_stack = S.push (CurrExprFrame (EnsureEq e1) orig_ce) stck} + , new_pcs = [] + , concretized = [] }] ) + +retCurrExpr s _ NoAction orig_ce stck = ( RuleReturnCurrExprFr - , [NewPC { state = s { curr_expr = e2 + , [NewPC { state = s { curr_expr = orig_ce , exec_stack = stck} - , new_pcs = [ExtCond e1 True]}] ) + , new_pcs = [] + , concretized = []}] ) retAssumeFrame :: State t -> NameGen -> Expr -> Expr -> S.Stack Frame -> (Rule, [NewPC t], NameGen) retAssumeFrame s@(State {known_values = kv @@ -669,10 +957,18 @@ dalt = case (getDataCon tenv (KV.tyBool kv) (KV.dcTrue kv)) of Just dc -> [dc] _ -> [] - -- If Assume is just a Var, concretize the Expr to a True Bool DataCon. Else add an ExtCond + -- Special handling in case we just have a concrete DataCon, or a lone Var (newPCs, ng') = case unApp $ unsafeElimOuterCast e1 of + [Data (DataCon dcn _)] + | dcn == KV.dcFalse kv -> ([], ng) + | dcn == KV.dcTrue kv -> + ( [NewPC { state = s { curr_expr = CurrExpr Evaluate e2 + , exec_stack = stck } + , new_pcs = [] + , concretized = [] }] + , ng) (Var i@(Id _ _)):_ -> concretizeExprToBool s ng i dalt e2 stck - _ -> addExtCond s ng e1 e2 True stck + _ -> addExtCond s ng e1 e2 stck in (RuleReturnCAssume, newPCs, ng') @@ -685,8 +981,23 @@ dalts = case getDataCons (KV.tyBool kv) tenv of Just dcs -> dcs _ -> [] - -- If Assert is just a Var, concretize the Expr to a True or False Bool DataCon, else add an ExtCond + -- Special handling in case we just have a concrete DataCon, or a lone Var (newPCs, ng') = case unApp $ unsafeElimOuterCast e1 of + [Data (DataCon dcn _)] + | dcn == KV.dcFalse kv -> + ( [NewPC { state = s { curr_expr = CurrExpr Evaluate e2 + , exec_stack = stck + , true_assert = True + , assert_ids = ais } + , new_pcs = [] + , concretized = [] }] + , ng) + | dcn == KV.dcTrue kv -> + ( [NewPC { state = s { curr_expr = CurrExpr Evaluate e2 + , exec_stack = stck } + , new_pcs = [] + , concretized = [] }] + , ng) (Var i@(Id _ _)):_ -> concretizeExprToBool s ng i dalts e2 stck _ -> addExtConds s ng e1 ais e2 stck @@ -703,31 +1014,31 @@ concretizeExprToBool' :: State t -> NameGen -> Id -> DataCon -> Expr -> S.Stack Frame -> (NewPC t, NameGen) concretizeExprToBool' s@(State {expr_env = eenv - , symbolic_ids = syms , known_values = kv}) ngen mexpr_id dcon@(DataCon dconName _) e2 stck = - (newPCEmpty $ s { expr_env = eenv' - , symbolic_ids = syms' + (NewPC { state = s { expr_env = eenv' , exec_stack = stck , curr_expr = CurrExpr Evaluate e2 , true_assert = assertVal} - , ngen) + , new_pcs = [] + , concretized = [] } + , ngen) where mexpr_n = idName mexpr_id -- concretize the mexpr to the DataCon specified eenv' = E.insert mexpr_n (Data dcon) eenv - syms' = filter (/= mexpr_id) syms assertVal = if (dconName == (KV.dcTrue kv)) then False else True -addExtCond :: State t -> NameGen -> Expr -> Expr -> Bool -> S.Stack Frame -> ([NewPC t], NameGen) -addExtCond s ng e1 e2 boolVal stck = +addExtCond :: State t -> NameGen -> Expr -> Expr -> S.Stack Frame -> ([NewPC t], NameGen) +addExtCond s ng e1 e2 stck = ([NewPC { state = s { curr_expr = CurrExpr Evaluate e2 , exec_stack = stck} - , new_pcs = [ExtCond e1 boolVal]}], ng) + , new_pcs = [ExtCond e1 True] + , concretized = [] }], ng) addExtConds :: State t -> NameGen -> Expr -> Maybe (FuncCall) -> Expr -> S.Stack Frame -> ([NewPC t], NameGen) addExtConds s ng e1 ais e2 stck = @@ -739,11 +1050,13 @@ condf = [ExtCond e1 False] strue = NewPC { state = s' - , new_pcs = condt } + , new_pcs = condt + , concretized = []} sfalse = NewPC { state = s' { true_assert = True , assert_ids = ais } - , new_pcs = condf } + , new_pcs = condf + , concretized = []} in ([strue, sfalse], ng) @@ -757,49 +1070,155 @@ olds = map (idName) bindsLHS (news, ngen') = freshSeededNames olds ngen - expr' = renameExprs (zip olds news) expr - bindsLHS' = renameExprs (zip olds news) bindsLHS - binds' = zip bindsLHS' bindsRHS + olds_news = HM.fromList $ zip olds news + expr' = renamesExprs olds_news expr - eenv' = E.insertExprs (zip news (map snd binds')) eenv + eenv' = E.insertExprs (zip news bindsRHS) eenv +liftBind :: Id -> Expr -> E.ExprEnv -> Expr -> NameGen -> + (E.ExprEnv, Expr, NameGen, Name) +liftBind bindsLHS bindsRHS eenv expr ngen = (eenv', expr', ngen', new) + where + old = idName bindsLHS + (new, ngen') = freshSeededName old ngen + + expr' = renameExpr old new expr + + eenv' = E.insert new bindsRHS eenv + +type SymbolicFuncEval t = State t -> NameGen -> Expr -> Maybe (Rule, [State t], NameGen) + +-- change literal rule to only match on arguments +retReplaceSymbFuncTemplate :: State t -> NameGen -> Expr -> Maybe (Rule, [State t], NameGen) +retReplaceSymbFuncTemplate s@(State { expr_env = eenv + , type_env = tenv + , known_values = kv }) + ng ce + + -- DC-SPLIT + | Var (Id n (TyFun t1 t2)):es <- unApp ce + , TyCon tname _:ts <- unTyApp t1 + , E.isSymbolic n eenv + , Just alg_data_ty <- HM.lookup tname tenv + = let + ty_map = HM.fromList $ zip (map idName bound) ts + + dcs = applyTypeHashMap ty_map $ dataCon alg_data_ty + bound = applyTypeHashMap ty_map $ bound_ids alg_data_ty + + (x, ng') = freshId t1 ng + (x', ng'') = freshId t1 ng' + (alts, symIds, ng''') = + foldr (\dc@(DataCon _ dcty) (as, sids, ng1) -> + let (argIds, ng1') = genArgIds dc ng1 + data_alt = DataAlt dc argIds + sym_fun_ty = mkTyFun $ fst (argTypes dcty) ++ [t2] + (fi, ng1'') = freshSeededId (Name "symFun" Nothing 0 Nothing) sym_fun_ty ng1' + vargs = map Var argIds + in (Alt data_alt (mkApp (Var fi : vargs)) : as, fi : sids, ng1'') + ) ([], [], ng'') dcs + -- alts = map (\dc -> Alt (Alt)) dcs + e = Lam TermL x $ Case (Var x) x' t2 alts + e' = mkApp (e:es) + eenv' = foldr E.insertSymbolic eenv symIds + eenv'' = E.insert n e eenv' + (constState, ng'''') = mkFuncConst s es n t1 t2 ng''' + in Just (RuleReturnReplaceSymbFunc, [s { + curr_expr = CurrExpr Evaluate e', + expr_env = eenv'' + }, constState], ng'''') + + -- FUNC-APP + | Var (Id n (TyFun t1@(TyFun _ _) t2)):es <- unApp ce + , E.isSymbolic n eenv + = let + (tfs, tr) = argTypes t1 + (xIds, ng') = freshIds tfs ng + xs = map Var xIds + (fId, ng'') = freshId (TyFun tr $ TyFun t1 t2) ng' + f = Var fId + (fa, ng''') = freshId t1 ng'' + e = Lam TermL fa $ mkApp [f, mkApp (Var fa : xs), Var fa] + eenv' = foldr E.insertSymbolic eenv xIds + -- eenv'' = E.insertSymbolic (idName fId) fId eenv' + eenv'' = E.insertSymbolic fId eenv' + eenv''' = E.insert n e eenv'' + (constState, ng'''') = mkFuncConst s es n t1 t2 ng''' + in Just (RuleReturnReplaceSymbFunc, [s { + curr_expr = CurrExpr Evaluate $ mkApp (e:es), + expr_env = eenv''' + }, constState], ng'''') + + -- LIT-SPLIT + | App (Var (Id n (TyFun t1 t2))) ea <- ce + , isPrimType t1 + , E.isSymbolic n eenv + = let + boolTy = (TyCon (KV.tyBool kv) TYPE) + trueDc = DataCon (KV.dcTrue kv) boolTy + falseDc = DataCon (KV.dcFalse kv) boolTy + eqT1 = mkEqPrimType t1 kv + (f1Id:f2Id:xId:discrimId:[], ng') = freshIds [t2, TyFun t1 t2, t1, boolTy] ng + x = Var xId + e = Lam TermL xId $ Case (mkApp [eqT1, x, ea]) discrimId t2 + [ Alt (DataAlt trueDc []) (Var f1Id) + , Alt (DataAlt falseDc []) (App (Var f2Id) x)] + eenv' = foldr E.insertSymbolic eenv [f1Id, f2Id] + eenv'' = E.insert n e eenv' + in Just (RuleReturnReplaceSymbFunc, [s { + -- because we are always going down true branch + curr_expr = CurrExpr Evaluate (Var f1Id), + expr_env = eenv'' + }], ng') + | otherwise = Nothing + +argTypes :: Type -> ([Type], Type) +argTypes t = (anonArgumentTypes $ PresType t, returnType $ PresType t) + +genArgIds :: DataCon -> NameGen -> ([Id], NameGen) +genArgIds (DataCon _ dcty) ng = + let (argTys, _) = argTypes dcty + in foldr (\ty (is, ng') -> let (i, ng'') = freshId ty ng' in ((i:is), ng'')) ([], ng) argTys + +mkFuncConst :: State t -> [Expr] -> Name -> Type -> Type -> NameGen -> (State t, NameGen) +mkFuncConst s@(State { expr_env = eenv } ) es n t1 t2 ng = + let + (fId:xId:[], ng') = freshIds [t2, t1] ng + eenv' = foldr E.insertSymbolic eenv [fId] + e = Lam TermL xId $ Var fId + eenv'' = E.insert n e eenv' + in (s { + curr_expr = CurrExpr Evaluate $ mkApp (e:es), + -- symbolic_ids = fId:symbolic_ids state, + expr_env = eenv'' + }, ng') + -- If the expression is a symbolic higher order function application, replaces -- it with a symbolic variable of the correct type. -- A non reduced path constraint is added, to force solving for the symbolic -- function later. -retReplaceSymbFunc :: State t -> NameGen -> Expr -> Maybe (Rule, [State t], NameGen) -retReplaceSymbFunc s@(State { expr_env = eenv - , known_values = kv - , type_classes = tc - , exec_stack = stck }) - ng ce +retReplaceSymbFuncVar :: State t -> NameGen -> Expr -> Maybe (Rule, [State t], NameGen) +retReplaceSymbFuncVar s@(State { expr_env = eenv + , known_values = kv + , type_classes = tc + , exec_stack = stck }) + ng ce | Just (frm, _) <- S.pop stck , not (isApplyFrame frm) , (Var (Id f idt):_) <- unApp ce , E.isSymbolic f eenv , isTyFun idt , t <- typeOf ce - , not (isTyFun t) - , Just eq_tc <- concreteSatStructEq kv tc t = + , not (isTyFun t) = let (new_sym, ng') = freshSeededString "sym" ng new_sym_id = Id new_sym t - - s_eq_f = KV.structEqFunc kv - - nrpc_e = mkApp $ - [ Var (Id s_eq_f TyUnknown) - , Type t - , eq_tc - , Var new_sym_id - , ce ] in Just (RuleReturnReplaceSymbFunc, - [s { expr_env = E.insertSymbolic new_sym new_sym_id eenv + [s { expr_env = E.insertSymbolic new_sym_id eenv , curr_expr = CurrExpr Return (Var new_sym_id) - , symbolic_ids = new_sym_id:symbolic_ids s - , non_red_path_conds = non_red_path_conds s ++ [nrpc_e] }] + , non_red_path_conds = non_red_path_conds s ++ [(ce, Var new_sym_id)] }] , ng') | otherwise = Nothing diff --git a/src/G2/Initialization/DeepSeqWalks.hs b/src/G2/Initialization/DeepSeqWalks.hs --- a/src/G2/Initialization/DeepSeqWalks.hs +++ b/src/G2/Initialization/DeepSeqWalks.hs @@ -17,7 +17,7 @@ createDeepSeqWalks :: ExprEnv -> TypeEnv -> NameGen -> (ExprEnv, NameGen, Walkers) createDeepSeqWalks eenv tenv ng = let - tenv' = M.toList tenv + tenv' = HM.toList tenv in createFuncs eenv ng tenv' M.empty (createDeepSeqName . fst) createDeepSeqStore (createDeepSeqExpr tenv) @@ -31,10 +31,12 @@ bn = map TyVar $ bound_ids adt bnf = map (\b -> TyFun b b) bn - base = TyFun (TyCon n TYPE) (TyCon n TYPE) + dc_t = foldr (const $ TyFun TYPE) TYPE [1..length bi] + base = TyFun (TyCon n dc_t) (TyCon n dc_t) + t = foldr TyFun base (bn ++ bnf) - t' = foldr TyForAll t $ map NamedTyBndr bi + t' = foldr TyForAll t bi i = Id n' t' in M.insert n i w @@ -70,7 +72,11 @@ (alts, ng''') = createDeepSeqDataConCase1Alts tenv w ti n caseB rm bn ng'' dc - c = Case (Var i) caseB alts + dc_t = case dc of + (d:_) -> typeOf d + _ -> TyBottom + + c = Case (Var i) caseB dc_t alts in (Lam TermL i c, ng''') createDeepSeqCase1 _ w ti n rm bn (NewTyCon {rep_type = t}) ng = @@ -83,14 +89,14 @@ cast = Cast (Var i) (t' :~ t'') - e = deepSeqFuncCall w ti rm (Var caseB) + (e, ng''') = deepSeqFuncCall w ng'' ti rm (Var caseB) e' = Cast e (t'' :~ t') alt = Alt Default e' - c = Case cast caseB [alt] + c = Case cast caseB t' [alt] in - (Lam TermL i c, ng'') + (Lam TermL i c, ng''') createDeepSeqCase1 _ _ _ _ _ _ _ _ = error "createDeepSeqCase1: bad argument passed" createDeepSeqDataConCase1Alts :: TypeEnv -> Walkers -> [(Name, Id)] -> Name -> Id -> RenameMap -> [BoundName] -> NameGen -> [DataCon] -> ([Alt], NameGen) @@ -119,45 +125,45 @@ foldl' App e tb tyForAllIds :: Type -> [Id] -tyForAllIds (TyForAll (NamedTyBndr i) t) = i:tyForAllIds t +tyForAllIds (TyForAll i t) = i:tyForAllIds t tyForAllIds _ = [] createDeepSeqDataConCase2 :: TypeEnv -> Walkers -> [(Name, Id)] -> RenameMap -> [Id] -> NameGen -> Expr -> (Expr, NameGen) createDeepSeqDataConCase2 _ _ _ _ [] ng e = (e, ng) createDeepSeqDataConCase2 tenv w ti rm (i:is) ng e | t@(TyCon n _) <- typeOf i - , Just (NewTyCon {rep_type = rt}) <- M.lookup n tenv = + , Just (NewTyCon {rep_type = rt}) <- HM.lookup n tenv = let (i', ng') = freshId rt ng - b = deepSeqFuncCall w ti rm (Var i) + (b, ng'') = deepSeqFuncCall w ng' ti rm (Var i) bCast = Cast b (t :~ rt) vi = Var i' viCast = Cast vi (rt :~ t) - (ae, ng'') = createDeepSeqDataConCase2 tenv w ti rm is ng' (App e viCast) + (ae, ng''') = createDeepSeqDataConCase2 tenv w ti rm is ng'' (App e viCast) in - (Case bCast i' [Alt Default ae], ng'') + (Case bCast i' (typeOf e) [Alt Default ae], ng''') | otherwise = let (i', ng') = freshId (typeOf i) ng - b = deepSeqFuncCall w ti rm (Var i) + (b, ng'') = deepSeqFuncCall w ng' ti rm (Var i) - (ae, ng'') = createDeepSeqDataConCase2 tenv w ti rm is ng' (App e (Var i')) + (ae, ng''') = createDeepSeqDataConCase2 tenv w ti rm is ng'' (App e (Var i')) in - (Case b i' [Alt Default ae], ng'') + (Case b i' (typeOf ae) [Alt Default ae], ng''') -- Calling a higher order function -deepSeqFuncCall :: Walkers -> [(Name, Id)] -> RenameMap -> Expr -> Expr -deepSeqFuncCall w ti rm e = - case deepSeqFunc w ti rm e of - Just e' -> App e' e - Nothing -> e +deepSeqFuncCall :: Walkers -> NameGen -> [(Name, Id)] -> RenameMap -> Expr -> (Expr, NameGen) +deepSeqFuncCall w ng ti rm e = + case deepSeqFunc w ng ti rm e of + Just (e', ng') -> (App e' e, ng') + Nothing -> (e, ng) -deepSeqFunc :: Typed t => Walkers -> [(Name, Id)] -> RenameMap -> t -> Maybe Expr -deepSeqFunc w ti rm e +deepSeqFunc :: Typed t => Walkers -> NameGen -> [(Name, Id)] -> RenameMap -> t -> Maybe (Expr, NameGen) +deepSeqFunc w ng ti rm e | t <- typeOf e , TyCon n _ <- tyAppCenter t , ts <- tyAppArgs t @@ -166,10 +172,30 @@ as = map Type $ renames rm ts as' = map (walkerFunc w ti rm) ts in - Just $ foldl' App (Var f) (as ++ as') + Just $ (foldl' App (Var f) (as ++ as'), ng) + | t@(TyFun _ _) <- typeOf e = + let + (a_in, ng') = freshId t ng + + tys = anonArgumentTypes e + (f_is, ng'') = freshIds tys ng' + + cll = mkApp $ Var a_in:map Var f_is + let_cll = Let (zip f_is $ map (SymGen SNoLog) tys) cll + + ds_type = typeOf ds_cll + + (ds_cll, ng''') = deepSeqFuncCall w ng'' ti rm let_cll + (bnd, ng'''') = freshId ds_type ng''' + + (lam_ids, ng''''') = freshIds tys ng'''' + + cse = Case ds_cll bnd ds_type [Alt Default $ mkLams (zip (repeat TermL) lam_ids) (Var bnd)] + in + Just (Lam TermL a_in cse, ng''''') | (TyVar (Id n _)) <- typeOf e , Just f <- lookup n ti = - Just $ Var f + Just (Var f, ng) | otherwise = Nothing walkerFunc :: Walkers -> [(Name, Id)] -> RenameMap -> Type -> Expr @@ -182,7 +208,7 @@ , Just f <- M.lookup n w = let as = renames rm $ map Type ts - ft = renames rm $ mapMaybe (deepSeqFunc w ti rm . PresType) ts + ft = renames rm . map fst $ mapMaybe (deepSeqFunc w undefined ti rm . PresType) ts in foldl' App (Var f) (as ++ ft) walkerFunc _ ni _ t = error $ "walkerFunc: bad argument passed" ++ "\n" ++ show ni ++ "\n" ++ show t diff --git a/src/G2/Initialization/ElimTicks.hs b/src/G2/Initialization/ElimTicks.hs --- a/src/G2/Initialization/ElimTicks.hs +++ b/src/G2/Initialization/ElimTicks.hs @@ -1,12 +1,12 @@ {-# LANGUAGE FlexibleContexts #-} -module G2.Initialization.ElimTicks (elimTicks) where +module G2.Initialization.ElimTicks (elimBreakpoints) where import G2.Language -elimTicks :: ASTContainer m Expr => m -> m -elimTicks = modifyASTsFix elimTicks' +elimBreakpoints :: ASTContainer m Expr => m -> m +elimBreakpoints = modifyASTs elimBreakpoints' -elimTicks' :: Expr -> Expr -elimTicks' (Tick _ e) = e -elimTicks' e = e +elimBreakpoints' :: Expr -> Expr +elimBreakpoints' (Tick (Breakpoint _) e) = elimBreakpoints' e +elimBreakpoints' e = e diff --git a/src/G2/Initialization/ElimTypeSynonyms.hs b/src/G2/Initialization/ElimTypeSynonyms.hs --- a/src/G2/Initialization/ElimTypeSynonyms.hs +++ b/src/G2/Initialization/ElimTypeSynonyms.hs @@ -1,26 +1,27 @@ {-# LANGUAGE FlexibleContexts #-} module G2.Initialization.ElimTypeSynonyms ( elimTypeSyms - , elimTypeSymsTEnv) where + , elimTypeSymsTEnv) where import G2.Language -import qualified Data.Map as M +import qualified Data.HashMap.Lazy as HM elimTypeSyms :: ASTContainer m Type => TypeEnv -> m -> m -elimTypeSyms tenv = modifyASTsFix (elimTypeSyms' tenv) +elimTypeSyms tenv = modifyASTs (elimTypeSyms' tenv) elimTypeSyms' :: TypeEnv -> Type -> Type elimTypeSyms' tenv t | (TyCon n _) <- tyAppCenter t , ts <- tyAppArgs t - , Just (TypeSynonym { bound_ids = is, synonym_of = st }) <- M.lookup n tenv + , Just (TypeSynonym { bound_ids = is, synonym_of = st }) <- HM.lookup n tenv , length ts == length is = - foldr (uncurry replaceASTs) st $ zip (map TyVar is) ts + -- We recursively call elimTypeSyms, in case a type synonym maps directly to a type synonym + elimTypeSyms' tenv $ foldr (uncurry replaceASTs) st $ zip (map TyVar is) ts elimTypeSyms' _ t = t elimTypeSymsTEnv :: TypeEnv -> TypeEnv -elimTypeSymsTEnv tenv = elimTypeSyms tenv . M.filter (not . typeSym) $ tenv +elimTypeSymsTEnv tenv = elimTypeSyms tenv . HM.filter (not . typeSym) $ tenv typeSym :: AlgDataTy -> Bool typeSym (TypeSynonym _ _) = True diff --git a/src/G2/Initialization/Interface.hs b/src/G2/Initialization/Interface.hs --- a/src/G2/Initialization/Interface.hs +++ b/src/G2/Initialization/Interface.hs @@ -6,26 +6,29 @@ import G2.Initialization.ElimTicks import G2.Initialization.ElimTypeSynonyms import G2.Initialization.InitVarLocs -import G2.Initialization.StructuralEq import G2.Initialization.Types as IT -runInitialization :: IT.SimpleState -> [Type] -> (IT.SimpleState, Walkers) -runInitialization s@(IT.SimpleState { IT.expr_env = eenv - , IT.type_env = tenv - , IT.name_gen = ng - , IT.type_classes = tc }) ts = +type MkArgTypes = IT.SimpleState -> [Type] + +runInitialization1 :: IT.SimpleState -> IT.SimpleState +runInitialization1 = elimBreakpoints . initVarLocs + +runInitialization2 :: IT.SimpleState -> MkArgTypes -> (IT.SimpleState, Walkers) +runInitialization2 s@(IT.SimpleState { IT.expr_env = eenv + , IT.type_env = tenv + , IT.name_gen = ng + , IT.type_classes = tc }) argTys = let eenv2 = elimTypeSyms tenv eenv tenv2 = elimTypeSymsTEnv tenv tc2 = elimTypeSyms tenv tc (eenv3, ng2, ds_walkers) = createDeepSeqWalks eenv2 tenv2 ng + ts = argTys (s { IT.expr_env = eenv3, IT.type_env = tenv2, IT.type_classes = tc2 }) + s' = s { IT.expr_env = eenv3 , IT.type_env = tenv2 , IT.name_gen = ng2 , IT.type_classes = tc2 } - - s'' = execSimpleStateM (createStructEqFuncs ts) s' - s''' = elimTicks . initVarLocs $ s'' in - (s''', ds_walkers) + (s', ds_walkers) diff --git a/src/G2/Initialization/KnownValues.hs b/src/G2/Initialization/KnownValues.hs --- a/src/G2/Initialization/KnownValues.hs +++ b/src/G2/Initialization/KnownValues.hs @@ -1,17 +1,27 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP, OverloadedStrings #-} module G2.Initialization.KnownValues (initKnownValues) where import qualified G2.Language.ExprEnv as E import G2.Language.KnownValues import G2.Language.Syntax +import G2.Language.TypeClasses import G2.Language.TypeEnv +import G2.Language.Typing (PresType (..), tyAppCenter, returnType) -import qualified Data.Map as M +import Data.List +import qualified Data.HashMap.Lazy as HM import qualified Data.Text as T -initKnownValues :: E.ExprEnv -> TypeEnv -> KnownValues -initKnownValues eenv tenv = +initKnownValues :: E.ExprEnv -> TypeEnv -> TypeClasses -> KnownValues +initKnownValues eenv tenv tc = + let + numT = typeWithStrName tenv "Num" + integralT = typeWithStrName tenv "Integral" + realT = typeWithStrName tenv "Real" + eqT = typeWithStrName tenv "Eq" + ordT = typeWithStrName tenv "Ord" + in KnownValues { tyInt = typeWithStrName tenv "Int" , dcInt = dcWithStrName tenv "Int" "I#" @@ -32,15 +42,37 @@ , dcTrue = dcWithStrName tenv "Bool" "True" , dcFalse = dcWithStrName tenv "Bool" "False" + , tyRational = typeWithStrName tenv "Rational" + +#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0) + , tyList = typeWithStrName tenv "List" + , dcCons = dcWithStrName tenv "List" ":" + , dcEmpty = dcWithStrName tenv "List" "[]" +#else , tyList = typeWithStrName tenv "[]" , dcCons = dcWithStrName tenv "[]" ":" , dcEmpty = dcWithStrName tenv "[]" "[]" +#endif - , eqTC = typeWithStrName tenv "Eq" - , numTC = typeWithStrName tenv "Num" - , ordTC = typeWithStrName tenv "Ord" - , integralTC = typeWithStrName tenv "Integral" + , tyMaybe = typeWithStrName tenv "Maybe" + , dcJust = dcWithStrName tenv "Maybe" "Just" + , dcNothing = dcWithStrName tenv "Maybe" "Nothing" + , tyUnit = typeWithStrName tenv "()" + , dcUnit = dcWithStrName tenv "()" "()" + + , eqTC = eqT + , numTC = numT + , ordTC = ordT + , integralTC = integralT + , realTC = realT + , fractionalTC = typeWithStrName tenv "Fractional" + + , integralExtactReal = superClassExtractor tc integralT realT + , realExtractNum = superClassExtractor tc realT numT + , realExtractOrd = superClassExtractor tc realT ordT + , ordExtractEq = superClassExtractor tc ordT eqT + , eqFunc = exprWithStrName eenv "==" , neqFunc = exprWithStrName eenv "/=" @@ -50,20 +82,28 @@ , divFunc = exprWithStrName eenv "/" , negateFunc = exprWithStrName eenv "negate" , modFunc = exprWithStrName eenv "mod" + , fromIntegerFunc = exprWithStrName eenv "fromInteger" , toIntegerFunc = exprWithStrName eenv "toInteger" + , toRatioFunc = exprWithStrName eenv "%" + , fromRationalFunc = exprWithStrName eenv "fromRational" + , geFunc = exprWithStrName eenv ">=" , gtFunc = exprWithStrName eenv ">" , ltFunc = exprWithStrName eenv "<" , leFunc = exprWithStrName eenv "<=" - , structEqTC = Name "NotDefinedYet" Nothing 0 Nothing - , structEqFunc = Name "NotDefinedYet" Nothing 0 Nothing + , impliesFunc = exprWithStrName eenv "implies" + , iffFunc = exprWithStrName eenv "iff" , andFunc = exprWithStrName eenv "&&" , orFunc = exprWithStrName eenv "||" + , notFunc = exprWithStrName eenv "not" + , errorFunc = exprWithStrName eenv "error" + , errorEmptyListFunc = exprWithStrName eenv "errorEmptyList" + , errorWithoutStackTraceFunc = exprWithStrName eenv "errorWithoutStackTrace" , patErrorFunc = exprWithStrName eenv "patError" } @@ -75,14 +115,14 @@ typeWithStrName :: TypeEnv -> T.Text -> Name typeWithStrName tenv s = - case M.toList $ M.filterWithKey (\(Name n _ _ _) _ -> n == s) tenv of + case HM.toList $ HM.filterWithKey (\(Name n _ _ _) _ -> n == s) tenv of (n, _):_ -> n _ -> error $ "No type found in typeWithStrName " ++ (show $ T.unpack s) dcWithStrName :: TypeEnv -> T.Text -> T.Text -> Name dcWithStrName tenv ts dcs = - case concatMap dataCon . M.elems $ M.filterWithKey (\(Name n _ _ _) _ -> n == ts) tenv of - [] -> error $ "No type found in typeWithStrName [" ++ + case concatMap dataCon . HM.elems $ HM.filterWithKey (\(Name n _ _ _) _ -> n == ts) tenv of + [] -> error $ "No type found in dcWithStrName [" ++ (show $ T.unpack ts) ++ "] [" ++ (show $ T.unpack dcs) ++ "]" dc -> dcWithStrName' dc dcs @@ -91,3 +131,18 @@ if n' == s then n else dcWithStrName' xs s dcWithStrName' _ s = error $ "No dc found in dcWithStrName [" ++ (show $ T.unpack s) ++ "]" +superClassExtractor :: TypeClasses -> Name -> Name -> Name +superClassExtractor tc tc_n sc_n = + case lookupTCClass tc_n tc of + Just c + | Just (_, i) <- find extractsSC (superclasses c) -> idName i + | otherwise -> error $ "superClassExtractor: Extractor not found\n" ++ show sc_n ++ "\n" ++ show (superclasses c) + Nothing -> error $ "superClassExtractor: Class not found " ++ show tc_n + where + extractsSC (t, _) = + let + t_c = tyAppCenter . returnType . PresType $ t + in + case t_c of + TyCon n _ -> n == sc_n + _ -> False diff --git a/src/G2/Initialization/MkCurrExpr.hs b/src/G2/Initialization/MkCurrExpr.hs --- a/src/G2/Initialization/MkCurrExpr.hs +++ b/src/G2/Initialization/MkCurrExpr.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase, OverloadedStrings #-} module G2.Initialization.MkCurrExpr ( mkCurrExpr , checkReaches @@ -10,23 +10,29 @@ import qualified G2.Language.ExprEnv as E import Data.List +import qualified Data.Map as M +import Data.Maybe import qualified Data.Text as T mkCurrExpr :: Maybe T.Text -> Maybe T.Text -> Id - -> TypeClasses -> NameGen -> ExprEnv -> Walkers + -> TypeClasses -> NameGen -> ExprEnv -> TypeEnv -> Walkers -> KnownValues -> Config -> (Expr, [Id], [Expr], NameGen) -mkCurrExpr m_assume m_assert f@(Id (Name _ m_mod _ _) _) tc ng eenv walkers kv config = +mkCurrExpr m_assume m_assert f@(Id (Name _ m_mod _ _) _) tc ng eenv _ walkers kv config = case E.lookup (idName f) eenv of Just ex -> let - typs = spArgumentTypes ex + var_ex = Var (Id (idName f) (typeOf ex)) + -- typs = spArgumentTypes ex - (typsE, typs') = instantitateTypes tc kv typs + -- (typsE, typs') = instantitateTypes tc kv typs - (var_ids, is, ng') = mkInputs ng typs' + -- (var_ids, is, ng') = mkInputs ng typs' - var_ex = Var f - app_ex = foldl' App var_ex $ typsE ++ var_ids + -- -- We refind the type of f, because type synonyms get replaced during the initializaton, + -- -- after we first got the type of f. + -- app_ex = foldl' App var_ex $ typsE ++ var_ids + (app_ex, is, typsE, ng') = mkMainExpr tc kv ng var_ex + var_ids = map Var is -- strict_app_ex = app_ex strict_app_ex = if strict config then mkStrict walkers app_ex else app_ex @@ -45,6 +51,19 @@ (let_ex, is, typsE, ng'') Nothing -> error "mkCurrExpr: Bad Name" +mkMainExpr :: TypeClasses -> KnownValues -> NameGen -> Expr -> (Expr, [Id], [Expr], NameGen) +mkMainExpr tc kv ng ex = + let + typs = spArgumentTypes ex + + (typsE, typs') = instantitateTypes tc kv typs + + (var_ids, is, ng') = mkInputs ng typs' + + app_ex = foldl' App ex $ typsE ++ var_ids + in + (app_ex, is, typsE, ng') + mkInputs :: NameGen -> [Type] -> ([Expr], [Id], NameGen) mkInputs ng [] = ([], [], ng) mkInputs ng (t:ts) = @@ -82,7 +101,7 @@ [] -> Right $ "No functions with name " ++ (T.unpack s) [(n, e)] -> Left (Id n (typeOf e) , e) pairs -> case m_mod of - Nothing -> Right $ "Multiple functions with same name. " ++ + Nothing -> Right $ "Multiple functions with same name. " ++ show s ++ " " ++ show m_mod ++ "Wrap the target function in a module so we can try again!" Just m -> case filter (\(n, _) -> nameModule n == Just m) pairs of [(n, e)] -> Left (Id n (typeOf e), e) @@ -90,7 +109,6 @@ _ -> Right $ "Multiple functions with same name " ++ (T.unpack s) ++ " in module " ++ (T.unpack m) - instantiateArgTypes :: TypeClasses -> KnownValues -> Expr -> ([Expr], [Type]) instantiateArgTypes tc kv e = let @@ -101,20 +119,24 @@ instantitateTypes :: TypeClasses -> KnownValues -> [ArgType] -> ([Expr], [Type]) instantitateTypes tc kv ts = let - tv = map (typeNamedId) $ filter (typeNamed) ts + tv = mapMaybe (\case NamedType i -> Just i; AnonType _ -> Nothing) ts -- Get non-TyForAll type reqs, identify typeclasses - ts' = map typeAnonType $ filter (not . typeNamed) ts - tcSat = map (\i -> (i, satisfyingTCTypes kv tc i ts')) tv + ts' = mapMaybe (\case AnonType t -> Just t; NamedType _ -> Nothing) ts + tcSat = snd $ mapAccumL (\ts'' i -> + let + sat = satisfyingTCTypes kv tc i ts'' + pt = pickForTyVar kv sat + in + (replaceTyVar (idName i) pt ts'', (i, pt))) ts' tv - -- TyForAll type reqs - tv' = map (\(i, ts'') -> (i, pickForTyVar kv ts'')) tcSat - tvt = map (\(i, t) -> (TyVar i, t)) tv' - -- Dictionary arguments - vi = concatMap (uncurry (satisfyingTC tc ts')) tv' + -- Get dictionary arguments + vi = mapMaybe (instantiateTCDict tc tcSat) ts' - ex = map (Type . snd) tv' ++ vi - tss = filter (not . isTypeClass tc) $ foldr (uncurry replaceASTs) ts' tvt + ex = map (Type . snd) tcSat ++ vi + tss = filter (not . isTypeClass tc) + . foldr (uncurry replaceASTs) ts' + $ map (\(i, t) -> (TyVar i, t)) tcSat in (ex, tss) @@ -125,17 +147,14 @@ | t:_ <- ts = t | otherwise = error "No type found in pickForTyVar" -typeNamedId :: ArgType -> Id -typeNamedId (NamedType i) = i -typeNamedId (AnonType _) = error "No Id in T" -typeAnonType :: ArgType -> Type -typeAnonType (NamedType _) = error "No type in NamedType" -typeAnonType (AnonType t) = t - -typeNamed :: ArgType -> Bool -typeNamed (NamedType _) = True -typeNamed _ = False +instantiateTCDict :: TypeClasses -> [(Id, Type)] -> Type -> Maybe Expr +instantiateTCDict tc it tyapp@(TyApp _ t) | TyCon n _ <- tyAppCenter tyapp = + let + t' = applyTypeMap (M.fromList $ map (\(Id ni _, ti) -> (ni,ti)) it) t + in + return . Var =<< lookupTCDict tc n t' +instantiateTCDict _ _ _ = Nothing checkReaches :: ExprEnv -> KnownValues -> Maybe T.Text -> Maybe T.Text -> ExprEnv checkReaches eenv _ Nothing _ = eenv diff --git a/src/G2/Initialization/StructuralEq.hs b/src/G2/Initialization/StructuralEq.hs deleted file mode 100644 --- a/src/G2/Initialization/StructuralEq.hs +++ /dev/null @@ -1,290 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} - -module G2.Initialization.StructuralEq ( createStructEqFuncs - , structEqFuncType - , structEqFuncTypeM) where - -import G2.Language as L -import G2.Language.Monad -import G2.Language.KnownValues - -import qualified Data.Foldable as F -import Data.List -import qualified Data.Map as M -import Data.Maybe -import qualified Data.Text as T - --- | createStructEqFuncs --- Creates a typeclass to compare two ADTs based on there structural equality- --- that is, compare if they have exactly the same (possibly recursive) constructors. --- If some of the constructors have higher order function arguments, --- those higher order functions are not checked for equality, and do not prevent --- the overall ADTs from being called structurally equal. --- Returns the name of the typeclass, and the function that checks for structural equality. -createStructEqFuncs :: ExState s m => [Type] -> m () -createStructEqFuncs ts = do - -- Create a name for the new type class, adt, and datacon - tcn <- freshSeededStringN "structEq" - adtn <- freshSeededStringN "structEq" - dcn <- freshSeededStringN "structEq" - - let t = TyCon tcn TYPE - - tyvn <- freshSeededStringN "a" - let tyvn' = TyVar (Id tyvn TYPE) - tb <- tyBoolT - - let dc = DataCon dcn (TyFun (TyFun tyvn' (TyFun tyvn' tb)) t) - - ex <- genExtractor t dc - - -- Update KnownValues - kv <- knownValues - let kv' = kv { structEqTC = tcn, structEqFunc = ex } - putKnownValues kv' - - tenv <- typeEnv - -- For efficiency, we only generate structural equality when it's needed - let types = mapMaybe (tcaName . returnType . PresType) $ filter isTyFun ts ++ (nubBy (.::.) $ argTypesTEnv tenv) - let tenv' = M.filterWithKey (\n _ -> n `elem` types) tenv - - insertT adtn (DataTyCon {bound_ids = [Id tyvn TYPE], data_cons = [dc]}) - - let (tenvK, tenvV) = unzip $ M.toList tenv' - - -- Create names for the new functions - let ns = map (\(Name n _ _ _) -> Name ("structEq" `T.append` n) Nothing 0 Nothing) tenvK - ns' <- freshSeededNamesN ns - let nsT = zip tenvK $ map (flip Id (TyCon tcn TYPE)) ns' - - tc <- typeClasses - tci <- freshIdN TYPE - - ins <- genInsts tcn nsT t dc $ M.toList tenv' - - let tc' = insertClass tcn (Class { insts = ins, typ_ids = [tci] }) tc - putTypeClasses tc' - - F.mapM_ (\(n, n', adt) -> createStructEqFunc dcn n n' adt) $ zip3 ns' tenvK tenvV - -tcaName :: Type -> Maybe Name -tcaName (TyCon n _) = Just n -tcaName (TyApp t _) = tcaName t -tcaName _ = Nothing - -genExtractor :: ExState s m => Type -> DataCon -> m Name -genExtractor t dc = do - lami <- freshIdN t - ci <- freshIdN t - - tb <- tyBoolT - tyvn <- freshSeededStringN "a" - let tyvn' = TyVar (Id tyvn TYPE) - fi <- freshIdN $ TyFun tyvn' (TyFun tyvn' tb) - - let alt = Alt (DataAlt dc [fi]) $ Var fi - let e = Lam TypeL (Id tyvn TYPE) $ Lam TermL lami $ Case (Var lami) ci $ [alt] - - extractN <- freshSeededStringN "structEq" - - insertE extractN e - - return extractN - - -genInsts :: ExState s m => Name -> [(Name, Id)] -> Type -> DataCon -> [(Name, AlgDataTy)] -> m [(Type, Id)] -genInsts _ _ _ _ [] = return [] -genInsts tcn nsT t dc ((n@(Name n' _ _ _), adt):xs) = do - let bn = map idName $ bound_ids adt - bn' <- freshSeededNamesN bn - - let bni = map (flip Id TYPE) bn - bnid = map (\(dni, i) -> Id dni (TyApp (TyCon tcn (TyFun TYPE TYPE)) (TyVar i))) $ zip bn' bni - - -- Make the expressions - bnv = map TyVar bni - bnvK = mkTyApp $ map (const TYPE) bnv - tbnv = map Type bnv - dv = map Var bnid - - eqfn = case lookup n nsT of - Just f -> f - Nothing -> error "No name found in genInsts" - - vs = mkApp (Var eqfn:tbnv ++ dv) - - e = mkLams (map (TypeL,) bni ++ map (TermL,) bnid) $ App (Data dc) vs - - dn <- freshSeededNameN (Name ("structEqDict" `T.append` n') Nothing 0 Nothing) - insertE dn e - - xs' <- genInsts tcn nsT t dc xs - - return $ (mkTyApp (TyCon n bnvK:bnv), Id dn t):xs' - - -createStructEqFunc :: ExState s m => Name -> Name -> Name -> AlgDataTy -> m () -createStructEqFunc dcn fn tn (DataTyCon {bound_ids = ns, data_cons = dc}) = do - ns' <- freshSeededNamesN $ map idName ns - let t = mkFullAppedTyCon tn (map (TyVar . flip Id TYPE) ns') TYPE - - bt <- freshIdsN $ map (const TYPE) ns - bd <- freshIdsN $ map (\i -> TyApp (TyCon dcn (TyFun TYPE TYPE)) (TyVar i)) bt - - let bm = zip (map idName bt) $ zip bt bd - - let dc' = foldr (\(i, rt) -> retype i rt) dc $ zip ns (map TyVar bt) - - e <- createStructEqFuncDC t bt bd bm dc' - insertE fn e -createStructEqFunc dcn fn tn (NewTyCon {bound_ids = ns, rep_type = rt}) = do - kv <- knownValues - - let t = mkFullAppedTyCon tn (map TyVar ns) TYPE - - bt <- freshIdsN $ map typeOf ns - bd <- freshIdsN $ map (\i -> TyApp (TyCon dcn (TyFun TYPE TYPE)) (TyVar i)) bt - let bm = zip (map idName bt) $ zip bt bd - - let t' = foldr (\(i, t_) -> retype i t_) t $ zip ns (map TyVar bt) - - lam1I <- freshIdN t' - lam2I <- freshIdN t' - - let rt' = foldr (\(i, rt_) -> retype i rt_) rt $ zip ns (map TyVar bt) - d <- dictForType bm rt' - - let ex = Var $ Id (structEqFunc kv) $ TyFun (typeOf (Type rt')) $ TyFun (typeOf d) $ TyFun t' $ TyFun t' t - let c = t' :~ rt' - let cLam1I = Cast (Var lam1I) c - let cLam2I = Cast (Var lam2I) c - - - let e = Lam TermL lam1I $ Lam TermL lam2I $ App (App (App (App ex (Type rt')) d) cLam1I) cLam2I - let e' = mkLams (map (TermL,) bd) e - let e'' = mkLams (map (TypeL,) bt) e' - - insertE fn e'' -createStructEqFunc _ _ _ (TypeSynonym {}) = error "Type synonym in createStructEqFunc" - -createStructEqFuncDC :: ExState s m => Type -> [Id] -> [Id] -> [(Name, (Id, Id))] -> [DataCon] -> m Expr -createStructEqFuncDC t bt bd bm dc = do - lam1I <- freshIdN t - lam2I <- freshIdN t - - b1 <- freshIdN t - - alts <- mapM (createStructEqFuncDCAlt (Var lam2I) t bm) dc - - let e = Lam TermL lam1I $ Lam TermL lam2I $ Case (Var lam1I) b1 alts - let e' = mkLams (map (TermL,) bd) e - return $ mkLams (map (TypeL,) bt) e' - -createStructEqFuncDCAlt :: ExState s m => Expr -> Type -> [(Name, (Id, Id))] -> DataCon -> m Alt -createStructEqFuncDCAlt e2 t bm dc@(DataCon _ _) = do - false <- mkFalseE - - bs <- freshIdsN $ anonArgumentTypes dc - - b <- freshIdN t - bs2 <- freshIdsN $ anonArgumentTypes dc - - sEqCheck <- boundChecks bs bs2 bm - - let alt2 = Alt (DataAlt dc bs2) sEqCheck - let altD = Alt Default false - - return $ Alt (DataAlt dc bs) (Case e2 b [alt2, altD]) - -boundChecks :: ExState s m => [Id] -> [Id] -> [(Name, (Id, Id))] -> m Expr -boundChecks is1 is2 bm = do - andE <- mkAndE - true <- mkTrueE - - bc <- mapM (uncurry (boundCheck bm)) $ zip is1 is2 - - return $ foldr (\e -> App (App andE e)) true bc - -boundCheck :: ExState s m => [(Name, (Id, Id))] -> Id -> Id -> m Expr -boundCheck bm i1 i2 = do - structEqCheck bm (typeOf i1) i1 i2 - -structEqCheck :: ExState s m => [(Name, (Id, Id))] -> Type -> Id -> Id -> m Expr -structEqCheck bm t i1 i2 - | TyCon _ _ <- tyAppCenter t = do - kv <- knownValues - sft <- structEqFuncTypeM - - let ex = Var $ Id (structEqFunc kv) sft - - dict <- dictForType bm t - - return (App (App (App (App ex (Type t)) dict) (Var i1)) (Var i2)) -structEqCheck bm (TyVar (Id n _)) (Id n' _) (Id n'' _) = do - kv <- knownValues - sft <- structEqFuncTypeM - - case lookup n bm of - Just (ty, dict) -> do - let ex = Var $ Id (structEqFunc kv) sft - - return (App (App (App (App ex (Var ty)) (Var dict)) (Var (Id n' (TyVar ty)))) (Var (Id n'' (TyVar ty)))) - Nothing -> error "Unaccounted for TyVar in structEqCheck" -structEqCheck _ TyLitInt i1 i2 = do - eq <- mkEqPrimIntE - return $ App (App eq (Var i1)) (Var i2) -structEqCheck _ TyLitFloat i1 i2 = do - eq <- mkEqPrimFloatE - return $ App (App eq (Var i1)) (Var i2) -structEqCheck _ TyLitDouble i1 i2 = do - eq <- mkEqPrimDoubleE - return $ App (App eq (Var i1)) (Var i2) -structEqCheck _ TyLitChar i1 i2 = do - eq <- mkEqPrimCharE - return $ App (App eq (Var i1)) (Var i2) -structEqCheck _ (TyForAll _ _) _ _ = mkTrueE -structEqCheck _ (TyFun _ _) i1 i2 = do - boolT <- tyBoolT - return $ App (App (Prim BindFunc (TyFun (typeOf i1) (TyFun (typeOf i2) boolT))) (Var i1)) (Var i2) -structEqCheck _ t _ _ = error $ "Unsupported type in structEqCheck" ++ show t - -dictForType :: ExState s m => [(Name, (Id, Id))] -> Type -> m Expr -dictForType bm t - | TyCon _ _ <- tyAppCenter t - , ts <- tyAppArgs t = do - kv <- knownValues - tc <- typeClasses - - ds <- mapM (dictForType bm) ts - - case structEqTCDict kv tc t of - Just i -> return $ foldl' App (Var i) (map Type ts ++ ds) - Nothing -> error $ "Required typeclass not found in dictForType" -dictForType bm (TyVar (Id n _)) = - case lookup n bm of - Just (_, dict) -> return (Var dict) - Nothing -> error "Unaccounted for TyVar in dictForType" -dictForType _ t = error $ "Unsupported type in dictForType" ++ show t - --- | Returns the type for the StructEq func. --- The Name is used for a bound type, and should be generated with a NameGen. -structEqFuncType :: KnownValues -> Name -> Type -structEqFuncType kv n = - let - i = Id n TYPE - dict = structEqTC kv - bool = L.tyBool kv - in - TyForAll (NamedTyBndr i) - (TyFun (TyCon dict TYPE) - (TyFun (TyVar i) - (TyFun (TyVar i) bool) - ) - ) - -structEqFuncTypeM :: ExState s m => m Type -structEqFuncTypeM = do - kv <- knownValues - n <- freshNameN - return $ structEqFuncType kv n diff --git a/src/G2/Initialization/Types.hs b/src/G2/Initialization/Types.hs --- a/src/G2/Initialization/Types.hs +++ b/src/G2/Initialization/Types.hs @@ -28,16 +28,18 @@ instance SM.MonadState SimpleState SimpleStateM where state f = SimpleStateM (SM.state f) -instance ExState SimpleState SimpleStateM where +instance NamingM SimpleState SimpleStateM where + nameGen = return . name_gen =<< SM.get + putNameGen = rep_name_genM + +instance ExprEnvM SimpleState SimpleStateM where exprEnv = return . expr_env =<< SM.get putExprEnv = rep_expr_envM +instance ExState SimpleState SimpleStateM where typeEnv = return . type_env =<< SM.get putTypeEnv = rep_type_envM - nameGen = return . name_gen =<< SM.get - putNameGen = rep_name_genM - knownValues = return . known_values =<< SM.get putKnownValues = rep_known_valuesM @@ -79,10 +81,13 @@ SM.put $ s {type_classes = tc} instance ASTContainer SimpleState Expr where - containedASTs s = containedASTs (expr_env s) - modifyContainedASTs f s = s { expr_env = modifyContainedASTs f (expr_env s) } + containedASTs s = containedASTs (expr_env s) ++ containedASTs (rewrite_rules s) + modifyContainedASTs f s = s { expr_env = modifyContainedASTs f (expr_env s) + , rewrite_rules = modifyContainedASTs f (rewrite_rules s) } instance ASTContainer SimpleState Type where - containedASTs s = containedASTs (expr_env s) ++ containedASTs (type_env s) + containedASTs s = + containedASTs (expr_env s) ++ containedASTs (type_env s) ++ containedASTs (rewrite_rules s) modifyContainedASTs f s = s { expr_env = modifyContainedASTs f (expr_env s) - , type_env = modifyContainedASTs f (type_env s) } + , type_env = modifyContainedASTs f (type_env s) + , rewrite_rules = modifyContainedASTs f (rewrite_rules s) } diff --git a/src/G2/Interface/Interface.hs b/src/G2/Interface/Interface.hs --- a/src/G2/Interface/Interface.hs +++ b/src/G2/Interface/Interface.hs @@ -1,14 +1,22 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -module G2.Interface.Interface ( doTimeout +module G2.Interface.Interface ( MkCurrExpr + , MkArgTypes + , IT.SimpleState + , doTimeout , maybeDoTimeout - , initState - , initState' + , initStateWithCall + , initStateWithCall' , initStateFromSimpleState , initStateFromSimpleState' + , initStateFromSimpleStateWithCall , initSimpleState + + , mkArgTys , initRedHaltOrd , initSolver @@ -16,6 +24,7 @@ , initialStateFromFileSimple , initialStateFromFile + , initialStateNoStartFunc , runG2FromFile , runG2WithConfig @@ -24,6 +33,7 @@ , runG2Post , runG2ThroughExecution , runExecution + , runG2SolvingResult , runG2Solving , runG2 , Config) where @@ -39,13 +49,17 @@ import G2.Preprocessing.Interface +import G2.Execution.HPC import G2.Execution.Interface import G2.Execution.Reducer +import G2.Execution.Rules import G2.Execution.PrimitiveEval import G2.Execution.Memory import G2.Interface.OutputTypes +import G2.Lib.Printers + import G2.Translation import G2.Solver @@ -56,10 +70,12 @@ import qualified G2.Language.PathConds as PC import qualified G2.Language.Stack as Stack +import Control.Monad.IO.Class +import qualified Control.Monad.State as SM import qualified Data.HashMap.Lazy as HM import qualified Data.HashSet as S -import qualified Data.Map as M import Data.Maybe +import qualified Data.Sequence as Seq import qualified Data.Text as T import System.Timeout @@ -71,7 +87,7 @@ type StartFunc = T.Text type ModuleName = Maybe T.Text -type MkCurrExpr = Id -> TypeClasses -> NameGen -> ExprEnv -> Walkers +type MkCurrExpr = TypeClasses -> NameGen -> ExprEnv -> TypeEnv -> Walkers -> KnownValues -> Config -> (Expr, [Id], [Expr], NameGen) doTimeout :: Int -> IO a -> IO (Maybe a) @@ -87,84 +103,122 @@ maybeDoTimeout (Just secs) = doTimeout secs maybeDoTimeout Nothing = fmap Just -initState :: ExtractedG2 -> Bool -> StartFunc -> ModuleName - -> MkCurrExpr - -> Config -> (State (), Id, Bindings) -initState exg2 useAssert f m_mod mkCurr config = + +{-# INLINE initStateWithCall #-} +initStateWithCall :: ExtractedG2 + -> Bool + -> StartFunc + -> ModuleName + -> (Id -> MkCurrExpr) + -> (Expr -> MkArgTypes) + -> Config + -> (State (), Bindings) +initStateWithCall exg2 useAssert f m_mod mkCurr argTys config = let s = initSimpleState exg2 + + (ie, fe) = case findFunc f m_mod (IT.expr_env s) of + Left ie' -> ie' + Right errs -> error errs in - initStateFromSimpleState s useAssert f m_mod mkCurr config + initStateFromSimpleState s m_mod useAssert (mkCurr ie) (argTys fe) config -initState' :: ExtractedG2 - -> StartFunc - -> ModuleName - -> MkCurrExpr - -> Config - -> (State (), Id, Bindings) -initState' exg2 sf m_mod mkCurr = - initState exg2 False sf m_mod mkCurr +{-# INLINE initStateWithCall' #-} +initStateWithCall' :: ExtractedG2 + -> StartFunc + -> ModuleName + -> (Id -> MkCurrExpr) + -> (Expr -> MkArgTypes) + -> Config + -> (State (), Bindings) +initStateWithCall' exg2 = + initStateWithCall exg2 False +{-# INLINE initStateFromSimpleStateWithCall #-} +initStateFromSimpleStateWithCall :: IT.SimpleState + -> Bool + -> StartFunc + -> ModuleName + -> (Id -> MkCurrExpr) + -> (Expr -> MkArgTypes) + -> Config + -> (State (), Id, Bindings) +initStateFromSimpleStateWithCall simp_s useAssert f m_mod mkCurr argTys config = + let + (ie, fe) = case findFunc f m_mod (IT.expr_env simp_s) of + Left ie' -> ie' + Right errs -> error errs + + (s, b) = initStateFromSimpleState simp_s m_mod useAssert (mkCurr ie) (argTys fe) config + in + (s, ie, b) + initStateFromSimpleState :: IT.SimpleState + -> Maybe T.Text -> Bool - -> StartFunc - -> ModuleName -> MkCurrExpr + -> MkArgTypes -> Config - -> (State (), Id, Bindings) -initStateFromSimpleState s useAssert f m_mod mkCurr config = + -> (State (), Bindings) +initStateFromSimpleState s m_mod useAssert mkCurr argTys config = let - (ie, fe) = case findFunc f m_mod (IT.expr_env s) of - Left ie' -> ie' - Right errs -> error errs - (_, ts) = instantiateArgTypes (IT.type_classes s) (IT.known_values s) fe - - (s', ds_walkers) = runInitialization s ts + (s', ds_walkers) = runInitialization2 s argTys eenv' = IT.expr_env s' tenv' = IT.type_env s' ng' = IT.name_gen s' kv' = IT.known_values s' tc' = IT.type_classes s' - (ce, is, f_i, ng'') = mkCurr ie tc' ng' eenv' ds_walkers kv' config + (ce, is, f_i, ng'') = mkCurr tc' ng' eenv' tenv' ds_walkers kv' config in (State { - expr_env = foldr (\i@(Id n _) -> E.insertSymbolic n i) eenv' is + expr_env = foldr E.insertSymbolic eenv' is , type_env = tenv' , curr_expr = CurrExpr Evaluate ce - , path_conds = PC.fromList kv' $ map PCExists is + , path_conds = PC.fromList [] , non_red_path_conds = [] , true_assert = if useAssert then False else True , assert_ids = Nothing , type_classes = tc' - , symbolic_ids = is , exec_stack = Stack.empty - , model = M.empty + , model = HM.empty , known_values = kv' , rules = [] , num_steps = 0 , track = () + , sym_gens = Seq.empty , tags = S.empty } - , ie , Bindings { deepseq_walkers = ds_walkers , fixed_inputs = f_i , arb_value_gen = arbValueInit , cleaned_names = HM.empty , input_names = map idName is - , higher_order_inst = IT.exports s + , higher_order_inst = S.filter (\n -> nameModule n == m_mod) . S.fromList $ IT.exports s , rewrite_rules = IT.rewrite_rules s - , name_gen = ng''}) + , name_gen = ng'' + , exported_funcs = IT.exports s }) +mkArgTys :: Expr -> MkArgTypes +mkArgTys e simp_s = + snd $ instantiateArgTypes (IT.type_classes simp_s) (IT.known_values simp_s) e + +{-# INLINE initStateFromSimpleState' #-} initStateFromSimpleState' :: IT.SimpleState -> StartFunc -> ModuleName -> Config - -> (State (), Id, Bindings) + -> (State (), Bindings) initStateFromSimpleState' s sf m_mod = - initStateFromSimpleState s False sf m_mod (mkCurrExpr Nothing Nothing) + let + (ie, fe) = case findFunc sf m_mod (IT.expr_env s) of + Left ie' -> ie' + Right errs -> error errs + in + initStateFromSimpleState s m_mod False (mkCurrExpr Nothing Nothing ie) (mkArgTys fe) +{-# INLINE initSimpleState #-} initSimpleState :: ExtractedG2 -> IT.SimpleState initSimpleState (ExtractedG2 { exg2_binds = prog @@ -173,53 +227,94 @@ , exg2_exports = es , exg2_rules = rs }) = let - eenv = mkExprEnv prog + eenv = E.fromExprMap prog tenv = mkTypeEnv prog_typ tc = initTypeClasses cls - kv = initKnownValues eenv tenv - ng = mkNameGen (prog, prog_typ) + kv = initKnownValues eenv tenv tc + ng = mkNameGen (prog, prog_typ, rs) + + s = IT.SimpleState { IT.expr_env = eenv + , IT.type_env = tenv + , IT.name_gen = ng + , IT.known_values = kv + , IT.type_classes = tc + , IT.rewrite_rules = rs + , IT.exports = es } in - IT.SimpleState { IT.expr_env = eenv - , IT.type_env = tenv - , IT.name_gen = ng - , IT.known_values = kv - , IT.type_classes = tc - , IT.rewrite_rules = rs - , IT.exports = es } + runInitialization1 s initCheckReaches :: State t -> ModuleName -> Maybe ReachFunc -> State t initCheckReaches s@(State { expr_env = eenv , known_values = kv }) m_mod reaches = s {expr_env = checkReaches eenv kv reaches m_mod } -initRedHaltOrd :: Solver conv => conv -> Config -> (SomeReducer (), SomeHalter (), SomeOrderer ()) -initRedHaltOrd conv config = +type RHOStack m = SM.StateT LengthNTrack (SM.StateT PrettyGuide (SM.StateT HpcTracker m)) + +{-# SPECIALIZE runReducer :: Ord b => + Reducer (RHOStack IO) rv () + -> Halter (RHOStack IO) hv () + -> Orderer (RHOStack IO) sov b () + -> State () + -> Bindings + -> (RHOStack IO) (Processed (State ()), Bindings) + #-} + +{-# SPECIALIZE + initRedHaltOrd :: (Solver solver, Simplifier simplifier) => + Maybe T.Text + -> solver + -> simplifier + -> Config + -> (SomeReducer (RHOStack IO) (), SomeHalter (RHOStack IO) (), SomeOrderer (RHOStack IO) ()) + #-} +initRedHaltOrd :: (MonadIO m, Solver solver, Simplifier simplifier) => + Maybe T.Text + -> solver + -> simplifier + -> Config + -> (SomeReducer (RHOStack m) (), SomeHalter (RHOStack m) (), SomeOrderer (RHOStack m) ()) +initRedHaltOrd mod_name solver simplifier config = let - tr_ng = mkNameGen () + share = sharing config + state_name = Name "state" Nothing 0 Nothing + + m_logger = fmap SomeReducer $ getLogger config + + hpc_red f = case hpc config of + True -> SomeReducer (hpcReducer mod_name ~> stdRed share f solver simplifier) + False -> SomeReducer (stdRed share f solver simplifier) + + logger_std_red f = case m_logger of + Just logger -> liftSomeReducer (logger .~> liftSomeReducer (hpc_red f)) + Nothing -> liftSomeReducer (liftSomeReducer (hpc_red f)) + + halter = switchEveryNHalter 20 + <~> maxOutputsHalter (maxOutputs config) + <~> zeroHalter (steps config) + <~> acceptIfViolatedHalter + + orderer = case search_strat config of + Subpath -> SomeOrderer $ lengthNSubpathOrderer (subpath_length config) + Iterative -> SomeOrderer $ pickLeastUsedOrderer in - if higherOrderSolver config == AllFuncs - then (SomeReducer (NonRedPCRed) - <~| (case logStates config of - Just fp -> SomeReducer (StdRed conv :<~ Logger fp) - Nothing -> SomeReducer (StdRed conv)) - , SomeHalter - (SwitchEveryNHalter 20 - :<~> MaxOutputsHalter (maxOutputs config) - :<~> ZeroHalter (steps config) - :<~> AcceptHalter) - , SomeOrderer $ PickLeastUsedOrderer) - else ( SomeReducer (NonRedPCRed :<~| TaggerRed state_name tr_ng) - <~| (case logStates config of - Just fp -> SomeReducer (StdRed conv :<~ Logger fp) - Nothing -> SomeReducer (StdRed conv)) - , SomeHalter - (DiscardIfAcceptedTag state_name - :<~> SwitchEveryNHalter 20 - :<~> MaxOutputsHalter (maxOutputs config) - :<~> ZeroHalter (steps config) - :<~> AcceptHalter) - , SomeOrderer $ PickLeastUsedOrderer) + case higherOrderSolver config of + AllFuncs -> + ( logger_std_red retReplaceSymbFuncVar .== Finished .--> SomeReducer nonRedPCRed + , SomeHalter halter + , orderer) + SingleFunc -> + ( logger_std_red retReplaceSymbFuncVar .== Finished .--> taggerRed state_name :== Finished --> nonRedPCRed + , SomeHalter (discardIfAcceptedTagHalter state_name <~> halter) + , orderer) + SymbolicFunc -> + ( logger_std_red retReplaceSymbFuncTemplate .== Finished .--> SomeReducer nonRedPCRed + , SomeHalter halter + , orderer) + SymbolicFuncTemplate -> + ( logger_std_red retReplaceSymbFuncVar .== Finished .--> taggerRed state_name :== Finished --> nonRedPCTemplates + , SomeHalter (discardIfAcceptedTagHalter state_name <~> halter) + , orderer) initSolver :: Config -> IO SomeSolver initSolver = initSolver' arbValue @@ -230,167 +325,270 @@ initSolver' :: ArbValueFunc -> Config -> IO SomeSolver initSolver' avf config = do SomeSMTSolver con <- getSMTAV avf config - let con' = GroupRelated avf (UndefinedHigherOrder :?> ADTSolver avf :?> con) + let con' = GroupRelated avf (UndefinedHigherOrder :?> (ADTNumericalSolver avf con)) return (SomeSolver con') -mkExprEnv :: [(Id, Expr)] -> E.ExprEnv -mkExprEnv = E.fromExprList . map (\(i, e) -> (idName i, e)) - -mkTypeEnv :: [ProgramType] -> TypeEnv -mkTypeEnv = M.fromList . map (\(n, dcs) -> (n, dcs)) +mkTypeEnv :: HM.HashMap Name AlgDataTy -> TypeEnv +mkTypeEnv = id +{-# INLINE initialStateFromFileSimple #-} initialStateFromFileSimple :: [FilePath] -> [FilePath] - -> [FilePath] -> StartFunc - -> MkCurrExpr + -> (Id -> MkCurrExpr) + -> (Expr -> MkArgTypes) -> Config -> IO (State (), Id, Bindings) -initialStateFromFileSimple proj src libs f mkCurr config = - initialStateFromFile proj src libs Nothing False f mkCurr config +initialStateFromFileSimple proj src f mkCurr argTys config = + initialStateFromFile proj src Nothing False f mkCurr argTys simplTranslationConfig config -initialStateFromFile :: [FilePath] +initialStateNoStartFunc :: [FilePath] -> [FilePath] + -> TranslationConfig + -> Config + -> IO (State (), Bindings) +initialStateNoStartFunc proj src transConfig config = do + (m_mod, exg2) <- translateLoaded proj src transConfig config + + let simp_state = initSimpleState exg2 + + (init_s, bindings) = initStateFromSimpleState simp_state m_mod False + (\_ ng _ _ _ _ _ -> (Prim Undefined TyBottom, [], [], ng)) + (E.higherOrderExprs . IT.expr_env) + config + + return (init_s, bindings) + +initialStateFromFile :: [FilePath] -> [FilePath] -> Maybe ReachFunc -> Bool -> StartFunc - -> MkCurrExpr + -> (Id -> MkCurrExpr) + -> (Expr -> MkArgTypes) + -> TranslationConfig -> Config -> IO (State (), Id, Bindings) -initialStateFromFile proj src libs m_reach def_assert f mkCurr config = do - (mb_modname, exg2) <- translateLoaded proj src libs simplTranslationConfig config - let (init_s, ent_f, bindings) = initState exg2 def_assert - f mb_modname mkCurr config +initialStateFromFile proj src m_reach def_assert f mkCurr argTys transConfig config = do + (mb_modname, exg2) <- translateLoaded proj src transConfig config + + let simp_state = initSimpleState exg2 + (ie, fe) = case findFunc f mb_modname (IT.expr_env simp_state) of + Left ie' -> ie' + Right errs -> error errs + + (init_s, bindings) = initStateFromSimpleState simp_state mb_modname def_assert + (mkCurr ie) (argTys fe) config + -- let (init_s, ent_f, bindings) = initState exg2 def_assert + -- f mb_modname mkCurr argTys config reaches_state = initCheckReaches init_s mb_modname m_reach - return (reaches_state, ent_f, bindings) + return (reaches_state, ie, bindings) runG2FromFile :: [FilePath] -> [FilePath] - -> [FilePath] -> Maybe AssumeFunc -> Maybe AssertFunc -> Maybe ReachFunc -> Bool -> StartFunc + -> TranslationConfig -> Config -> IO (([ExecRes ()], Bindings), Id) -runG2FromFile proj src libs m_assume m_assert m_reach def_assert f config = do - (init_state, entry_f, bindings) <- initialStateFromFile proj src libs - m_reach def_assert f (mkCurrExpr m_assume m_assert) config +runG2FromFile proj src m_assume m_assert m_reach def_assert f transConfig config = do + (init_state, entry_f, bindings) <- initialStateFromFile proj src + m_reach def_assert f (mkCurrExpr m_assume m_assert) (mkArgTys) + transConfig config - r <- runG2WithConfig init_state config bindings + r <- runG2WithConfig (nameModule $ idName entry_f) init_state config bindings return (r, entry_f) -runG2WithConfig :: State () -> Config -> Bindings -> IO ([ExecRes ()], Bindings) -runG2WithConfig state config bindings = do - SomeSolver con <- initSolver config +runG2WithConfig :: Maybe T.Text -> State () -> Config -> Bindings -> IO ([ExecRes ()], Bindings) +runG2WithConfig mod_name state config bindings = do + SomeSolver solver <- initSolver config + let simplifier = IdSimplifier - (in_out, bindings') <- case initRedHaltOrd con config of + hpc_t <- hpcTracker + + (in_out, bindings') <- case initRedHaltOrd mod_name solver simplifier config of (red, hal, ord) -> - runG2WithSomes red hal ord con [] state bindings + SM.evalStateT + (SM.evalStateT + (SM.evalStateT + (runG2WithSomes red hal ord solver simplifier emptyMemConfig state bindings) + lnt + ) + (mkPrettyGuide ()) + ) + hpc_t - close con + close solver return (in_out, bindings') -runG2WithSomes :: ( Named t + +{-# SPECIALIZE + runG2WithSomes :: ( Solver solver + , Simplifier simplifier) + => SomeReducer (RHOStack IO) () + -> SomeHalter (RHOStack IO) () + -> SomeOrderer (RHOStack IO) () + -> solver + -> simplifier + -> MemConfig + -> State () + -> Bindings + -> RHOStack IO ([ExecRes ()], Bindings) + #-} +runG2WithSomes :: ( MonadIO m + , Named t , ASTContainer t Expr , ASTContainer t Type - , Solver solver) - => (SomeReducer t) - -> (SomeHalter t) - -> (SomeOrderer t) + , Solver solver + , Simplifier simplifier) + => SomeReducer m t + -> SomeHalter m t + -> SomeOrderer m t -> solver - -> [Name] + -> simplifier + -> MemConfig -> State t -> Bindings - -> IO ([ExecRes t], Bindings) -runG2WithSomes red hal ord con pns state bindings = + -> m ([ExecRes t], Bindings) +runG2WithSomes red hal ord solver simplifier mem state bindings = case (red, hal, ord) of (SomeReducer red', SomeHalter hal', SomeOrderer ord') -> - runG2 red' hal' ord' con pns state bindings + runG2 red' hal' ord' solver simplifier mem state bindings runG2Pre :: ( Named t , ASTContainer t Expr - , ASTContainer t Type) => [Name] -> State t -> Bindings -> (State t, Bindings) -runG2Pre pns s@(State { known_values = kv, type_classes = tc }) bindings = + , ASTContainer t Type) => MemConfig -> State t -> Bindings -> (State t, Bindings) +runG2Pre mem s bindings = let - (swept, bindings') = markAndSweepPreserving (pns ++ names (lookupStructEqDicts kv tc)) s bindings + (swept, bindings') = markAndSweepPreserving mem s bindings in runPreprocessing swept bindings' -runG2Post :: ( Named t +runG2Post :: ( MonadIO m + , Named t , ASTContainer t Expr , ASTContainer t Type - , Reducer r rv t - , Halter h hv t - , Orderer or sov b t - , Solver solver) => r -> h -> or -> - solver -> State t -> Bindings -> IO ([ExecRes t], Bindings) -runG2Post red hal ord con is bindings = do + , Solver solver + , Simplifier simplifier + , Ord b) => Reducer m rv t -> Halter m hv t -> Orderer m sov b t -> + solver -> simplifier -> State t -> Bindings -> m ([ExecRes t], Bindings) +runG2Post red hal ord solver simplifier is bindings = do (exec_states, bindings') <- runExecution red hal ord is bindings - sol_states <- mapM (runG2Solving con bindings') exec_states + sol_states <- mapM (runG2Solving solver simplifier bindings') exec_states return (catMaybes sol_states, bindings') -runG2ThroughExecution :: +{-# SPECIALISE runG2ThroughExecution :: ( Named t , ASTContainer t Expr , ASTContainer t Type - , Reducer r rv t - , Halter h hv t - , Orderer or sov b t) => r -> h -> or -> - [Name] -> State t -> Bindings -> IO ([State t], Bindings) -runG2ThroughExecution red hal ord pns is bindings = do - let (is', bindings') = runG2Pre pns is bindings + , Ord b) => Reducer IO rv t -> Halter IO hv t -> Orderer IO sov b t -> + MemConfig -> State t -> Bindings -> IO ([State t], Bindings) #-} +{-# SPECIALISE runG2ThroughExecution :: + ( Named t + , ASTContainer t Expr + , ASTContainer t Type + , Ord b) => Reducer (SM.StateT PrettyGuide IO) rv t -> Halter (SM.StateT PrettyGuide IO) hv t -> Orderer (SM.StateT PrettyGuide IO) sov b t -> + MemConfig -> State t -> Bindings -> SM.StateT PrettyGuide IO ([State t], Bindings) #-} +runG2ThroughExecution :: + ( Monad m + , Named t + , ASTContainer t Expr + , ASTContainer t Type + , Ord b) => Reducer m rv t -> Halter m hv t -> Orderer m sov b t -> + MemConfig -> State t -> Bindings -> m ([State t], Bindings) +runG2ThroughExecution red hal ord mem is bindings = do + let (is', bindings') = runG2Pre mem is bindings runExecution red hal ord is' bindings' +{-# INLINABLE runG2ThroughExecution #-} -runG2Solving :: ( Named t - , ASTContainer t Expr - , ASTContainer t Type - , Solver solver) => - solver -> Bindings -> State t -> IO (Maybe (ExecRes t)) -runG2Solving con bindings s@(State { known_values = kv }) +runG2SolvingResult :: ( Named t + , Solver solver + , Simplifier simplifier) => + solver + -> simplifier + -> Bindings + -> State t + -> IO (Result (ExecRes t) () ()) +runG2SolvingResult solver simplifier bindings s | true_assert s = do - (_, m) <- solve con s bindings (symbolic_ids s) (path_conds s) - case m of - Just m' -> do - let s' = s { model = m' } + r <- solve solver s bindings (E.symbolicIds . expr_env $ s) (path_conds s) - let (es, e, ais) = subModel s' bindings - sm = ExecRes { final_state = s' - , conc_args = es - , conc_out = e - , violated = ais} + case r of + SAT m -> do + let m' = reverseSimplification simplifier s bindings m + return . SAT $ runG2SubstModel m' s bindings + UNSAT _ -> return $ UNSAT () + Unknown reason _ -> return $ Unknown reason () - let sm' = runPostprocessing bindings sm + | otherwise = return $ UNSAT () - let sm'' = ExecRes { final_state = final_state sm' - , conc_args = fixed_inputs bindings ++ conc_args sm' - , conc_out = evalPrims kv (conc_out sm') - , violated = evalPrims kv (violated sm')} - - return (Just sm'') - Nothing -> do - return Nothing +runG2Solving :: ( MonadIO m + , Named t + , Solver solver + , Simplifier simplifier) => + solver + -> simplifier + -> Bindings + -> State t + -> m (Maybe (ExecRes t)) +runG2Solving solver simplifier bindings s = do + res <- liftIO $ runG2SolvingResult solver simplifier bindings s + case res of + SAT m -> return $ Just m + _ -> return Nothing - | otherwise = return Nothing +runG2SubstModel :: Named t => + Model + -> State t + -> Bindings + -> ExecRes t +runG2SubstModel m s@(State { type_env = tenv, known_values = kv }) bindings = + let + s' = s { model = m } + (es, e, ais, gens) = subModel s' bindings + sm = ExecRes { final_state = s' + , conc_args = es + , conc_out = e + , conc_sym_gens = gens + , violated = ais} + + sm' = runPostprocessing bindings sm + + sm'' = ExecRes { final_state = final_state sm' + , conc_args = fixed_inputs bindings ++ conc_args sm' + , conc_out = evalPrims tenv kv (conc_out sm') + , conc_sym_gens = gens + , violated = evalPrims tenv kv (violated sm')} + in + sm'' + +{-# SPECIALIZE runG2 :: ( Solver solver + , Simplifier simplifier + , Ord b) => Reducer (RHOStack IO) rv () -> Halter (RHOStack IO) hv () -> Orderer (RHOStack IO) sov b () -> + solver -> simplifier -> MemConfig -> State () -> Bindings -> RHOStack IO ([ExecRes ()], Bindings) + #-} + + -- | Runs G2, returning both fully executed states, -- and states that have only been partially executed. -runG2 :: ( Named t +runG2 :: ( MonadIO m + , Named t , ASTContainer t Expr , ASTContainer t Type - , Reducer r rv t - , Halter h hv t - , Orderer or sov b t - , Solver solver) => r -> h -> or -> - solver -> [Name] -> State t -> Bindings -> IO ([ExecRes t], Bindings) -runG2 red hal ord con pns is bindings = do - (exec_states, bindings') <- runG2ThroughExecution red hal ord pns is bindings - sol_states <- mapM (runG2Solving con bindings') exec_states + , Solver solver + , Simplifier simplifier + , Ord b) => Reducer m rv t -> Halter m hv t -> Orderer m sov b t -> + solver -> simplifier -> MemConfig -> State t -> Bindings -> m ([ExecRes t], Bindings) +runG2 red hal ord solver simplifier mem is bindings = do + (exec_states, bindings') <- runG2ThroughExecution red hal ord mem is bindings + sol_states <- mapM (runG2Solving solver simplifier bindings') exec_states return (catMaybes sol_states, bindings') diff --git a/src/G2/Interface/OutputTypes.hs b/src/G2/Interface/OutputTypes.hs --- a/src/G2/Interface/OutputTypes.hs +++ b/src/G2/Interface/OutputTypes.hs @@ -5,10 +5,14 @@ import G2.Language --- | A fully executed State -data ExecRes t = ExecRes { final_state :: State t - , conc_args :: [Expr] - , conc_out :: Expr +import Data.Monoid ((<>)) +import qualified Data.Sequence as S + +-- | A fully executed `State`. +data ExecRes t = ExecRes { final_state :: State t -- ^ The final state. + , conc_args :: [Expr] -- ^ Fully concrete arguments for the state. + , conc_out :: Expr -- ^ Fully concrete output (final `curr_expr`) for the state + , conc_sym_gens :: S.Seq Expr , violated :: Maybe FuncCall -- ^ A violated assertion } deriving (Show, Read) @@ -16,55 +20,66 @@ names (ExecRes { final_state = s , conc_args = es , conc_out = r + , conc_sym_gens = g , violated = fc }) = - names s ++ names es ++ names r ++ names fc + names s <> names es <> names r <> names g <> names fc rename old new (ExecRes { final_state = s , conc_args = es , conc_out = r + , conc_sym_gens = g , violated = fc }) = ExecRes { final_state = rename old new s , conc_args = rename old new es , conc_out = rename old new r + , conc_sym_gens = rename old new g , violated = rename old new fc} renames hm (ExecRes { final_state = s , conc_args = es , conc_out = r + , conc_sym_gens = g , violated = fc }) = ExecRes { final_state = renames hm s , conc_args = renames hm es , conc_out = renames hm r + , conc_sym_gens = renames hm g , violated = renames hm fc } instance ASTContainer t Expr => ASTContainer (ExecRes t) Expr where containedASTs (ExecRes { final_state = s , conc_args = es , conc_out = r + , conc_sym_gens = g , violated = fc }) = - containedASTs s ++ containedASTs es ++ containedASTs r ++ containedASTs fc + containedASTs s ++ containedASTs es ++ containedASTs r ++ containedASTs g ++ containedASTs fc modifyContainedASTs f (ExecRes { final_state = s , conc_args = es , conc_out = r + , conc_sym_gens = g , violated = fc }) = ExecRes { final_state = modifyContainedASTs f s , conc_args = modifyContainedASTs f es , conc_out = modifyContainedASTs f r + , conc_sym_gens = modifyContainedASTs f g , violated = modifyContainedASTs f fc} instance ASTContainer t Type => ASTContainer (ExecRes t) Type where containedASTs (ExecRes { final_state = s , conc_args = es , conc_out = r + , conc_sym_gens = g , violated = fc }) = - containedASTs s ++ containedASTs es ++ containedASTs r ++ containedASTs fc + containedASTs s ++ containedASTs es ++ containedASTs r ++ containedASTs g ++ containedASTs fc modifyContainedASTs f (ExecRes { final_state = s , conc_args = es , conc_out = r + , conc_sym_gens = g , violated = fc }) = ExecRes { final_state = modifyContainedASTs f s , conc_args = modifyContainedASTs f es , conc_out = modifyContainedASTs f r + , conc_sym_gens = modifyContainedASTs f g , violated = modifyContainedASTs f fc } diff --git a/src/G2/Language/AST.hs b/src/G2/Language/AST.hs --- a/src/G2/Language/AST.hs +++ b/src/G2/Language/AST.hs @@ -1,4 +1,4 @@ --- | Defines typeclasses and functions for ease of AST manipulation. +-- | Defines typeclasses and functions to make it easier to write functions that require traversing ASTs. {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -10,6 +10,7 @@ , modify , modifyMonoid , modifyFix + , modifyMaybe , modifyContainedFix , modifyFixMonoid , eval @@ -26,6 +27,7 @@ , replaceASTs ) where +import qualified G2.Data.UFMap as UF import G2.Language.Syntax import G2.Language.AlgDataTy @@ -33,17 +35,26 @@ import qualified Data.HashMap.Lazy as HM import qualified Data.HashSet as HS import qualified Data.Map as M +import qualified Data.Sequence as S import qualified Data.Text as T -- | Describes data types that define an AST. class AST t where -- | Gets the direct children of the given node. children :: t -> [t] - -- | Applies the given function to all children of the given node. + -- | Applies the given function to all direct children of the given node. modifyChildren :: (t -> t) -> t -> t + -- | Calls the given function on the given node, and all of the descendants --- in a recursive, top down, manner. +-- top down recursively. +-- Typically, the passed higher order function will modify some subset +-- of the constructors of the given type, and leave the rest unchanged. +-- +-- >>> let go e = case e of Var (Id _ t) -> SymGen SLog t; _ -> e +-- >>> let n = Name "x" Nothing 0 Nothing +-- >>> modify go (Lam TypeL (Id n TyLitInt) (App (Var $ Id n TyLitInt) (Var $ Id n TyLitFloat))) +-- Lam TypeL (Id (Name "x" Nothing 0 Nothing) TyLitInt) (App (SymGen SLog TyLitInt) (SymGen SLog TyLitFloat)) modify :: AST t => (t -> t) -> t -> t modify f t = go t where @@ -70,6 +81,16 @@ go t' = let t'' = f t' in if t' == t'' then modifyChildren go t'' else go t'' +-- | Runs the given function f on the node t repeatedly, until f t = Nothing, then does the +-- same on all decendants of t recursively. +modifyMaybe :: AST t => (t -> Maybe t) -> t -> t +modifyMaybe f = go + where + go t = let mt = f t in + case mt of + Just v -> go v + Nothing -> modifyChildren go t + -- | Runs the given function f on the node t, t until t = f t modifyContainedFix :: (AST t, Eq t, Show t) => (t -> t) -> t -> t modifyContainedFix f t = let t' = f t @@ -92,6 +113,12 @@ -- | Recursively runs the given function on each node, top down. Uses mappend -- to combine the results after evaluation of the entire tree. +-- +-- >>> let go e = case e of Lit l -> [l]; _ -> [] +-- >>> plusInt = Prim Plus (TyFun TyLitInt (TyFun TyLitInt TyLitInt)) +-- >>> eval go $ App (App plusInt (Lit $ LitInt 0)) (Lit $ LitInt 1) +-- [LitInt 0, LitInt 1] +{-# INLINE eval #-} eval :: (AST t, Monoid a) => (t -> a) -> t -> a eval f t = go t where @@ -112,6 +139,7 @@ -- | Evaluates all children of the given AST node with the given monoid, -- and `mconcat`s the results +{-# INLINE evalChildren #-} evalChildren :: (AST t, Monoid a) => (t -> a) -> t -> a evalChildren f = mconcat . map f . children @@ -160,20 +188,20 @@ children (App f a) = [f, a] children (Lam _ _ e) = [e] children (Let bind e) = e : containedASTs bind - children (Case m _ as) = m : map (\(Alt _ e) -> e) as + children (Case m _ _ as) = m : map (\(Alt _ e) -> e) as children (Cast e _) = [e] children (Coercion _) = [] children (Type _) = [] children (Tick _ e) = [e] children (NonDet es) = es - children (SymGen _) = [] - children (Assume is e e') = containedASTs is ++ [e, e'] - children (Assert is e e') = containedASTs is ++ [e, e'] + children (SymGen _ _) = [] + children (Assume _ e e') = [e, e'] + children (Assert _ e e') = [e, e'] modifyChildren f (App fx ax) = App (f fx) (f ax) modifyChildren f (Lam u b e) = Lam u b (f e) modifyChildren f (Let bind e) = Let (modifyContainedASTs f bind) (f e) - modifyChildren f (Case m b as) = Case (f m) b (mapAlt f as) + modifyChildren f (Case m b t as) = Case (f m) b t (mapAlt f as) where mapAlt :: (Expr -> Expr) -> [Alt] -> [Alt] mapAlt g alts = map (\(Alt ac e) -> Alt ac (g e)) alts @@ -203,8 +231,7 @@ children _ = [] modifyChildren _ (DataCon n ty) = DataCon n ty --- | Instance ASTContainer of Itself --- Every AST is defined as an ASTContainer of itself. Generally, functions +-- | Every AST is defined as an ASTContainer of itself. Generally, functions -- should be written using the ASTContainer typeclass. instance AST t => ASTContainer t t where containedASTs t = [t] @@ -218,13 +245,13 @@ containedASTs (App e1 e2) = containedASTs e1 ++ containedASTs e2 containedASTs (Lam _ b e) = containedASTs b ++ containedASTs e containedASTs (Let bnd e) = containedASTs bnd ++ containedASTs e - containedASTs (Case e i as) = containedASTs e ++ containedASTs i ++ containedASTs as + containedASTs (Case e i t as) = containedASTs e ++ containedASTs i ++ containedASTs t ++ containedASTs as containedASTs (Cast e c) = containedASTs e ++ containedASTs c containedASTs (Coercion c) = containedASTs c containedASTs (Type t) = [t] containedASTs (Tick _ e) = containedASTs e containedASTs (NonDet es) = containedASTs es - containedASTs (SymGen t) = [t] + containedASTs (SymGen _ t) = [t] containedASTs (Assume is e e') = containedASTs is ++ containedASTs e ++ containedASTs e' containedASTs (Assert is e e') = containedASTs is ++ containedASTs e ++ containedASTs e' containedASTs _ = [] @@ -235,18 +262,26 @@ modifyContainedASTs f (App fx ax) = App (modifyContainedASTs f fx) (modifyContainedASTs f ax) modifyContainedASTs f (Lam u b e) = Lam u (modifyContainedASTs f b)(modifyContainedASTs f e) modifyContainedASTs f (Let bnd e) = Let (modifyContainedASTs f bnd) (modifyContainedASTs f e) - modifyContainedASTs f (Case m i as) = Case (modifyContainedASTs f m) (modifyContainedASTs f i) (modifyContainedASTs f as) + modifyContainedASTs f (Case m i t as) = Case (modifyContainedASTs f m) (modifyContainedASTs f i) (f t) (modifyContainedASTs f as) modifyContainedASTs f (Type t) = Type (f t) modifyContainedASTs f (Cast e c) = Cast (modifyContainedASTs f e) (modifyContainedASTs f c) modifyContainedASTs f (Coercion c) = Coercion (modifyContainedASTs f c) modifyContainedASTs f (Tick t e) = Tick t (modifyContainedASTs f e) modifyContainedASTs f (NonDet es) = NonDet (modifyContainedASTs f es) - modifyContainedASTs f (SymGen t) = SymGen (f t) + modifyContainedASTs f (SymGen sl t) = SymGen sl (f t) modifyContainedASTs f (Assume is e e') = Assume (modifyContainedASTs f is) (modifyContainedASTs f e) (modifyContainedASTs f e') modifyContainedASTs f (Assert is e e') = Assert (modifyContainedASTs f is) (modifyContainedASTs f e) (modifyContainedASTs f e') modifyContainedASTs _ e = e +instance ASTContainer LamUse Expr where + containedASTs _ = [] + modifyContainedASTs _ i = i + +instance ASTContainer LamUse Type where + containedASTs _ = [] + modifyContainedASTs _ i = i + instance ASTContainer Id Expr where containedASTs (Id _ _) = [] @@ -275,7 +310,6 @@ instance ASTContainer DataCon Type where containedASTs (DataCon _ t) = [t] - modifyContainedASTs f (DataCon n t) = DataCon n (f t) instance ASTContainer AltMatch Expr where @@ -298,17 +332,6 @@ modifyContainedASTs f (Alt a e) = Alt (modifyContainedASTs f a) (modifyContainedASTs f e) -instance ASTContainer TyBinder Expr where - containedASTs _ = [] - modifyContainedASTs _ b = b - -instance ASTContainer TyBinder Type where - containedASTs (AnonTyBndr t) = [t] - containedASTs (NamedTyBndr i) = containedASTs i - - modifyContainedASTs f (AnonTyBndr t) = AnonTyBndr (f t) - modifyContainedASTs f (NamedTyBndr i) = NamedTyBndr (modifyContainedASTs f i) - instance ASTContainer Coercion Expr where containedASTs _ = [] modifyContainedASTs _ c = c @@ -324,32 +347,52 @@ instance ASTContainer FuncCall Type where containedASTs (FuncCall { arguments = as, returns = r}) = containedASTs as ++ containedASTs r - modifyContainedASTs f fc@(FuncCall { arguments = as, returns = r}) = + modifyContainedASTs f fc@(FuncCall { arguments = as, returns = r}) = fc {arguments = modifyContainedASTs f as, returns = modifyContainedASTs f r} +instance ASTContainer RewriteRule Expr where + containedASTs (RewriteRule { ru_args = a, ru_rhs = s }) = a ++ [s] + modifyContainedASTs f rr@(RewriteRule { ru_args = a, ru_rhs = s }) = + rr { ru_args = modifyContainedASTs f a, ru_rhs = modifyContainedASTs f s } + +instance ASTContainer RewriteRule Type where + containedASTs (RewriteRule { ru_bndrs = b, ru_args = a, ru_rhs = s }) = + (containedASTs b) ++ (containedASTs a) ++ (containedASTs s) + modifyContainedASTs f rr@(RewriteRule { ru_bndrs = b, ru_args = a, ru_rhs = s }) = + rr { + ru_bndrs = modifyContainedASTs f b + , ru_args = modifyContainedASTs f a + , ru_rhs = modifyContainedASTs f s + } + -- instance (Foldable f, Functor f, ASTContainer c t) => ASTContainer (f c) t where -- containedASTs = foldMap (containedASTs) -- modifyContainedASTs f = fmap (modifyContainedASTs f) instance ASTContainer c t => ASTContainer [c] t where - containedASTs = foldMap (containedASTs) + containedASTs = foldMap containedASTs modifyContainedASTs f = fmap (modifyContainedASTs f) +instance ASTContainer c t => ASTContainer (S.Seq c) t where + containedASTs = foldMap containedASTs + + modifyContainedASTs f = fmap (modifyContainedASTs f) + instance ASTContainer c t => ASTContainer (Maybe c) t where - containedASTs = foldMap (containedASTs) + containedASTs = foldMap containedASTs modifyContainedASTs f = fmap (modifyContainedASTs f) instance ASTContainer c t => ASTContainer (HM.HashMap k c) t where - containedASTs = foldMap (containedASTs) + containedASTs = foldMap containedASTs modifyContainedASTs f = fmap (modifyContainedASTs f) instance ASTContainer c t => ASTContainer (M.Map k c) t where - containedASTs = foldMap (containedASTs) + containedASTs = foldMap containedASTs modifyContainedASTs f = fmap (modifyContainedASTs f) @@ -389,10 +432,11 @@ modifyContainedASTs f (x, y, z, w, a) = (modifyContainedASTs f x, modifyContainedASTs f y, modifyContainedASTs f z, modifyContainedASTs f w, modifyContainedASTs f a) --- | Miscellaneous Instances +-- Miscellaneous Instances -- These instances exist so that we can use them in other types that contain -- ASTs and still consider those types ASTContainers. For example (Expr, Bool) -- should be an ASTContainer. + instance ASTContainer Lit Expr where containedASTs _ = [] modifyContainedASTs _ t = t @@ -458,18 +502,17 @@ modifyContainedASTs f (NewTyCon ns dc rt) = NewTyCon ns (modifyContainedASTs f dc) rt modifyContainedASTs _ st@(TypeSynonym _ _) = st +instance (ASTContainer k t, ASTContainer v t, Eq k, Hashable k) => ASTContainer (UF.UFMap k v) t where + containedASTs = containedASTs . UF.toList + modifyContainedASTs f = UF.fromList . modifyContainedASTs f . UF.toList -- ====== -- -- AST Helper functions -- ====== -- --- | replaceASTs --- Replaces all instances of old with new in the ASTContainer +-- | `replaceASTs old new container` returns `container` but with all occurences of `old` replaced with `new`. replaceASTs :: (Eq e, ASTContainer c e) => e -> e -> c -> c replaceASTs old new = modifyContainedASTs (replaceASTs' old new) replaceASTs' :: (Eq e, AST e) => e -> e -> e -> e replaceASTs' old new e = if e == old then new else modifyChildren (replaceASTs' old new) e - - - diff --git a/src/G2/Language/AlgDataTy.hs b/src/G2/Language/AlgDataTy.hs --- a/src/G2/Language/AlgDataTy.hs +++ b/src/G2/Language/AlgDataTy.hs @@ -1,25 +1,50 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} -module G2.Language.AlgDataTy where +module G2.Language.AlgDataTy ( AlgDataTy (..) + , dataCon + , dataConWithName) where +import GHC.Generics (Generic) import Data.Data (Data, Typeable) +import Data.Hashable +import Data.List import G2.Language.Syntax - -type ProgramType = (Name, AlgDataTy) - -- | Algebraic data types are types constructed with parametrization of some -- names over types, and a list of data constructors for said type. -data AlgDataTy = DataTyCon { bound_ids :: [Id] - , data_cons :: [DataCon] } - | NewTyCon { bound_ids :: [Id] - , data_con :: DataCon - , rep_type :: Type } - | TypeSynonym { bound_ids :: [Id] - , synonym_of :: Type - } deriving (Show, Eq, Read, Typeable, Data) +data AlgDataTy = + -- | A type defined using the `data` keyword. + DataTyCon { bound_ids :: [Id] -- ^ Polymorphic type variables + , data_cons :: [DataCon] -- ^ Data constructors for the type + } + -- | A type defined using the `newtype` keyword. + | NewTyCon { bound_ids :: [Id] -- ^ Polymorphic type variables + , data_con :: DataCon -- ^ The data constructor for the newtype + , rep_type :: Type -- ^ The type being wrapped by the newtype + } + -- | A type defined using the `type` keyword. + | TypeSynonym { bound_ids :: [Id] -- ^ Polymorphic type variables + , synonym_of :: Type -- ^ What type is the type synonym equivalent to? + } deriving (Show, Eq, Read, Generic, Typeable, Data) +-- | Get the data constructors for the passed data type. +-- +-- Warning: Does not "dig in" to type synonyms- a type synonym +-- will just give back an empty list. +dataCon :: AlgDataTy -> [DataCon] +dataCon (DataTyCon {data_cons = dc}) = dc +dataCon (NewTyCon {data_con = dc}) = [dc] +dataCon (TypeSynonym {}) = [] +dataConWithName :: AlgDataTy -> Name -> Maybe DataCon +dataConWithName (DataTyCon _ dcs) n = find (`dataConHasName` n) dcs +dataConWithName _ _ = Nothing + +dataConHasName :: DataCon -> Name -> Bool +dataConHasName (DataCon n _) n' = n == n' + +instance Hashable AlgDataTy diff --git a/src/G2/Language/Approximation.hs b/src/G2/Language/Approximation.hs new file mode 100644 --- /dev/null +++ b/src/G2/Language/Approximation.hs @@ -0,0 +1,309 @@ +module G2.Language.Approximation ( GenerateLemma + , Lookup + , MRCont + + , moreRestrictive + , moreRestrictive' + , moreRestrictivePC + + , applySolver + + , inlineEquiv) where + +import G2.Execution.NormalForms +import G2.Language.Expr +import qualified G2.Language.ExprEnv as E +import G2.Language.Naming +import qualified G2.Language.PathConds as P +import G2.Language.Support +import G2.Language.Syntax +import G2.Language.Typing as T +import qualified G2.Solver as S + +import Control.Monad.Extra +import Control.Monad.IO.Class +import qualified Data.HashSet as HS +import qualified Data.HashMap.Lazy as HM + +type GenerateLemma t l = State t -> State t -> (HM.HashMap Id Expr, HS.HashSet (Expr, Expr)) -> Expr -> Expr -> l +type Lookup t = Name -> State t -> Maybe E.ConcOrSym + +type MRCont t l = State t + -> State t + -> HS.HashSet Name + -> (HM.HashMap Id Expr, HS.HashSet (Expr, Expr)) + -> Bool -- ^ indicates whether this is part of the "active expression" + -> [(Name, Expr)] -- ^ variables inlined previously on the LHS + -> [(Name, Expr)] -- ^ variables inlined previously on the RHS + -> Expr + -> Expr + -> Either [l] (HM.HashMap Id Expr, HS.HashSet (Expr, Expr)) + +------------------------------------------------------------------------------- +-- [Inlining] +-- We keep two separate lists of variables that have been inlined previously on +-- the LHS and RHS. This means that inlinings on one side do not block any inlinings +-- that need to happen on the other side. +-- +-- Whenever a variable is inlined, we record the expression that was on the +-- opposite side at the time. Not allowing a variable to be inlined at all on one +-- side in any sub-expressions that resulted from an inlining of it is too restrictive +-- in practice. We allow repeated inlinings of a variable as long as the expression on +-- the opposite side is not the same as it was when a previous inlining of the +-- same variable happened. +------------------------------------------------------------------------------- + +-- | Check is s1 is an approximation of s2 (if s2 is more restrictive than s1.) +moreRestrictive :: MRCont t l -- ^ For special case handling - what to do if we don't match elsewhere in moreRestrictive + -> GenerateLemma t l + -> Lookup t -- ^ How to lookup variable names + -> State t -- ^ s1 + -> State t -- ^ s2 + -> HS.HashSet Name -- ^ Names that should not be inlined (often: top level names from the original source code) + -> (HM.HashMap Id Expr, HS.HashSet (Expr, Expr)) + -> Either [l] (HM.HashMap Id Expr, HS.HashSet (Expr, Expr)) +moreRestrictive mr_cont gen_lemma lkp s1 s2 ns hm = + moreRestrictive' mr_cont gen_lemma lkp s1 s2 ns hm True [] [] (getExpr s1) (getExpr s2) + +moreRestrictive' :: MRCont t l -- ^ For special case handling - what to do if we don't match elsewhere in moreRestrictive' + -> GenerateLemma t l + -> Lookup t + -> State t + -> State t + -> HS.HashSet Name -- ^ Names that should not be inlined (often: top level names from the original source code) + -> (HM.HashMap Id Expr, HS.HashSet (Expr, Expr)) + -> Bool -- ^ indicates whether this is part of the "active expression" + -> [(Name, Expr)] -- ^ variables inlined previously on the LHS (see [Inlining]) + -> [(Name, Expr)] -- ^ variables inlined previously on the RHS + -> Expr + -> Expr + -> Either [l] (HM.HashMap Id Expr, HS.HashSet (Expr, Expr)) +moreRestrictive' mr_cont gen_lemma lkp s1@(State {expr_env = h1}) s2@(State {expr_env = h2}) ns hm active n1 n2 e1 e2 = + case (e1, e2) of + (Var i, _) | m <- idName i + , not $ HS.member m ns + , not $ (m, e2) `elem` n1 + , Just (E.Conc e) <- lkp m s1 -> + moreRestrictive' mr_cont gen_lemma lkp s1 s2 ns hm active ((m, e2):n1) n2 e e2 + (_, Var i) | m <- idName i + , not $ HS.member m ns + , not $ (m, e1) `elem` n2 + , Just (E.Conc e) <- lkp m s2 -> + moreRestrictive' mr_cont gen_lemma lkp s1 s2 ns hm active n1 ((m, e1):n2) e1 e + (Var i1, Var i2) | HS.member (idName i1) ns + , idName i1 == idName i2 -> Right hm + | HS.member (idName i1) ns -> Left [] + | HS.member (idName i2) ns -> Left [] + (Var i, _) | Just (E.Sym _) <- lkp (idName i) s1 + , (hm', hs) <- hm + , Nothing <- HM.lookup i hm' -> Right (HM.insert i (inlineEquiv lkp s2 ns e2) hm', hs) + | Just (E.Sym _) <- lkp (idName i) s1 + , Just e <- HM.lookup i (fst hm) + , e == inlineEquiv lkp s2 ns e2 -> Right hm + -- this last case means there's a mismatch + | Just (E.Sym _) <- lkp (idName i) s1 -> Left [] + | not $ (idName i, e2) `elem` n1 + , not $ HS.member (idName i) ns -> error $ "unmapped variable " ++ (show i) + (_, Var i) | Just (E.Sym _) <- lkp (idName i) s2 -> Left [] -- sym replaces non-sym + | not $ (idName i, e1) `elem` n2 + , not $ HS.member (idName i) ns -> error $ "unmapped variable " ++ (show i) + + (App f1 a1, App f2 a2) | Right hm_fa <- moreResFA -> Right hm_fa + -- don't just choose the minimal conflicting expressions + -- collect all suitable pairs for potential lemmas + | not (hasFuncType e1) + , not (hasFuncType e2) + , not active + , Var (Id m1 _):_ <- unApp (modifyASTs stripTicks e1) + , Var (Id m2 _):_ <- unApp (modifyASTs stripTicks e2) + , nameOcc m1 == nameOcc m2 + , Left lems <- moreResFA -> + Left $ (gen_lemma s1 s2 hm e1 e2):lems + | Left (_:_) <- moreResFA -> moreResFA + where + moreResFA = do + hm_f <- moreRestrictive' mr_cont gen_lemma lkp s1 s2 ns hm active n1 n2 f1 f2 + moreRestrictive' mr_cont gen_lemma lkp s1 s2 ns hm_f False n1 n2 a1 a2 + -- These two cases should come after the main App-App case. If an + -- expression pair fits both patterns, then discharging it in a way that + -- does not add any extra proof obligations is preferable. + -- + -- We use an empty HashSet when inlining because when generating a path constraint + -- we DO NOT want any top level names being preserved- these would just confuse the SMT solver. + (App _ _, _) | e1':_ <- unApp e1 + , (Prim _ _) <- inlineEquiv lkp s1 HS.empty e1' + , T.isPrimType $ typeOf e1 + , T.isPrimType $ typeOf e2 + , isSWHNF $ (s2 { curr_expr = CurrExpr Evaluate e2 }) -> + let (hm', hs) = hm + in Right (hm', HS.insert (inlineEquiv lkp s1 HS.empty e1, inlineEquiv lkp s2 HS.empty e2) hs) + (_, App _ _) | e2':_ <- unApp e2 + , (Prim _ _) <- inlineEquiv lkp s2 HS.empty e2' + , T.isPrimType $ typeOf e2 + , T.isPrimType $ typeOf e1 + , isSWHNF $ (s1 { curr_expr = CurrExpr Evaluate e1 }) -> + let (hm', hs) = hm + in Right (hm', HS.insert (inlineEquiv lkp s1 HS.empty e1, inlineEquiv lkp s2 HS.empty e2) hs) + -- We just compare the names of the DataCons, not the types of the DataCons. + -- This is because (1) if two DataCons share the same name, they must share the + -- same type, but (2) "the same type" may be represented in different syntactic + -- ways, most significantly bound variable names may differ + -- "forall a . a" is the same type as "forall b . b", but fails a syntactic check. + (Data (DataCon d1 _), Data (DataCon d2 _)) + | d1 == d2 -> Right hm + | otherwise -> Left [] + -- We neglect to check type equality here for the same reason. + (Prim p1 _, Prim p2 _) | p1 == p2 -> Right hm + | otherwise -> Left [] + (Lit l1, Lit l2) | l1 == l2 -> Right hm + | otherwise -> Left [] + (Lam lu1 i1 b1, Lam lu2 i2 b2) + | lu1 == lu2 + , i1 == i2 -> + let ns' = HS.insert (idName i1) ns + -- no need to insert twice over because they're equal + in moreRestrictive' mr_cont gen_lemma lkp s1 s2 ns' hm active n1 n2 b1 b2 + | otherwise -> Left [] + -- ignore types, like in exprPairing + (Type _, Type _) -> Right hm + -- only works if both binding lists are the same length + (Let binds1 e1', Let binds2 e2') -> + let pairs = (e1', e2'):(zip (map snd binds1) (map snd binds2)) + ins (i_, e_) h_ = E.insert (idName i_) e_ h_ + h1_ = foldr ins h1 binds1 + h2_ = foldr ins h2 binds2 + s1' = s1 { expr_env = h1_ } + s2' = s2 { expr_env = h2_ } + mf hm_ (e1_, e2_) = moreRestrictive' mr_cont gen_lemma lkp s1' s2' ns hm_ active n1 n2 e1_ e2_ + in + if length binds1 == length binds2 + then foldM mf hm pairs + else Left [] + -- id equality never checked directly, but it's covered indirectly + (Case e1' i1 _ a1, Case e2' i2 _ a2) + | Right hm' <- b_mr -> + let h1_ = E.insert (idName i1) e1' h1 + h2_ = E.insert (idName i2) e2' h2 + s1' = s1 { expr_env = h1_ } + s2' = s2 { expr_env = h2_ } + mf hm_ (e1_, e2_) = moreRestrictiveAlt mr_cont gen_lemma lkp s1' s2' ns hm_ False n1 n2 e1_ e2_ + l = zip a1 a2 + in foldM mf hm' l + | otherwise -> b_mr + where + b_mr = moreRestrictive' mr_cont gen_lemma lkp s1 s2 ns hm active n1 n2 e1' e2' + (Cast e1' c1, Cast e2' c2) | c1 == c2 -> + moreRestrictive' mr_cont gen_lemma lkp s1 s2 ns hm active n1 n2 e1' e2' + + -- ignore all Ticks + _ -> mr_cont s1 s2 ns hm active n1 n2 e1 e2 + +-- check only the names for DataAlt +altEquiv :: AltMatch -> AltMatch -> Bool +altEquiv (DataAlt dc1 ids1) (DataAlt dc2 ids2) = + let DataCon dn1 _ = dc1 + DataCon dn2 _ = dc2 + n1 = map idName ids1 + n2 = map idName ids2 + in + dn1 == dn2 && n1 == n2 +altEquiv (LitAlt l1) (LitAlt l2) = l1 == l2 +altEquiv Default Default = True +altEquiv _ _ = False + +inlineEquiv :: Lookup t -> State t -> HS.HashSet Name -> Expr -> Expr +inlineEquiv lkp s ns v@(Var (Id n _)) + | Just (E.Sym _) <- cs = v + | HS.member n ns = v + | Just (E.Conc e) <- cs = inlineEquiv lkp s (HS.insert n ns) e + where + cs = lkp n s +inlineEquiv lkp s ns e = modifyChildren (inlineEquiv lkp s ns) e + +-- ids are the same between both sides; no need to insert twice +moreRestrictiveAlt :: MRCont t l + -> GenerateLemma t l + -> Lookup t + -> State t + -> State t + -> HS.HashSet Name + -> (HM.HashMap Id Expr, HS.HashSet (Expr, Expr)) + -> Bool -- ^ active expression? + -> [(Name, Expr)] -- ^ variables inlined previously on the LHS + -> [(Name, Expr)] -- ^ variables inlined previously on the RHS + -> Alt + -> Alt + -> Either [l] (HM.HashMap Id Expr, HS.HashSet (Expr, Expr)) +moreRestrictiveAlt mr_cont gen_lemma lkp s1 s2 ns hm active n1 n2 (Alt am1 e1) (Alt am2 e2) = + if altEquiv am1 am2 then + case am1 of + DataAlt _ t1 -> let ns' = foldr HS.insert ns $ map idName t1 + in moreRestrictive' mr_cont gen_lemma lkp s1 s2 ns' hm active n1 n2 e1 e2 + _ -> moreRestrictive' mr_cont gen_lemma lkp s1 s2 ns hm active n1 n2 e1 e2 + else Left [] + +-- s1 is old state, s2 is new state +-- only apply to old-new state pairs for which moreRestrictive' works +moreRestrictivePC :: (MonadIO m, S.Solver solver) => + solver -> + State t -> + State t -> + HM.HashMap Id Expr -> + m Bool +moreRestrictivePC solver s1 s2 hm = do + let new_conds = map extractCond (P.toList $ path_conds s2) + old_conds = map extractCond (P.toList $ path_conds s1) + l = map (\(i, e) -> (Var i, e)) $ HM.toList hm + -- this should only be used with primitive types + -- no apparent problems come from using TyUnknown + l' = map (\(e1, e2) -> + if (T.isPrimType $ typeOf e1) && (T.isPrimType $ typeOf e2) + then Just $ App (App (Prim Eq TyUnknown) e1) e2 + else Nothing) l + l'' = [c | Just c <- l'] + new_conds' = l'' ++ new_conds + -- not safe to use unless the lists are non-empty + conj_new = foldr1 (\o1 o2 -> App (App (Prim And TyUnknown) o1) o2) new_conds' + conj_old = foldr1 (\o1 o2 -> App (App (Prim And TyUnknown) o1) o2) old_conds + + imp = App (App (Prim Implies TyUnknown) conj_new) conj_old + neg_imp = ExtCond (App (Prim Not TyUnknown) imp) True + neg_conj = ExtCond (App (Prim Not TyUnknown) conj_old) True + + res <- if null old_conds + then return $ S.UNSAT () + else if null new_conds' + then liftIO $ applySolver solver (P.insert neg_conj P.empty) s1 s2 + else liftIO $ applySolver solver (P.insert neg_imp P.empty) s1 s2 + case res of + S.UNSAT () -> return True + _ -> return False + +-- shortcut: don't invoke Z3 if there are no path conds +applySolver :: S.Solver solver => + solver -> + PathConds -> + State t -> + State t -> + IO (S.Result () () ()) +applySolver solver extraPC s1 s2 = + let unionEnv = E.union (expr_env s1) (expr_env s2) + rightPC = P.toList $ path_conds s2 + unionPC = foldr P.insert (path_conds s1) rightPC + -- adding extraPC in here may be redundant + allPC = foldr P.insert unionPC (P.toList extraPC) + newState = s1 { expr_env = unionEnv, path_conds = extraPC } + in case (P.toList allPC) of + [] -> return $ S.SAT () + _ -> S.check solver newState allPC + +-- All the PathConds that this receives are generated by symbolic execution. +-- Consequently, non-primitive types are not an issue here. +extractCond :: PathCond -> Expr +extractCond (ExtCond e True) = e +extractCond (ExtCond e False) = App (Prim Not TyUnknown) e +extractCond (AltCond l e True) = + App (App (Prim Eq TyUnknown) e) (Lit l) +extractCond (AltCond l e False) = + App (App (Prim Neq TyUnknown) e) (Lit l) +extractCond _ = error "Not Supported" diff --git a/src/G2/Language/ArbValueGen.hs b/src/G2/Language/ArbValueGen.hs --- a/src/G2/Language/ArbValueGen.hs +++ b/src/G2/Language/ArbValueGen.hs @@ -1,20 +1,23 @@ +{-# LANGUAGE OverloadedStrings #-} + module G2.Language.ArbValueGen ( ArbValueGen , ArbValueFunc , arbValueInit , arbValue - , arbValueInfinite ) where + , arbValueInfinite + , constArbValue ) where -import G2.Language.AST import G2.Language.Expr import G2.Language.Support import G2.Language.Syntax import G2.Language.Typing import Data.List -import qualified Data.Map as M +import qualified Data.HashMap.Lazy as HM import Data.Ord import Data.Tuple +-- | A default `ArbValueGen`. arbValueInit :: ArbValueGen arbValueInit = ArbValueGen { intGen = 0 , floatGen = 0 @@ -32,94 +35,171 @@ charGenInit :: [Char] charGenInit = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] --- | arbValue --- Allows the generation of arbitrary values of the given type. +-- | Allows the generation of arbitrary values of the given type. -- Cuts off recursive ADTs with a Prim Undefined -- Returns a new ArbValueGen that (in the case of the primitives) -- will give a different value the next time arbValue is called with -- the same Type. arbValue :: Type -> TypeEnv -> ArbValueGen -> (Expr, ArbValueGen) -arbValue = arbValue' getFiniteADT +arbValue t tenv = arbValue' getFiniteADT HM.empty t tenv --- | arbValue --- Allows the generation of arbitrary values of the given type. +-- | Allows the generation of arbitrary values of the given type. +-- Cuts off recursive ADTs with a Prim Undefined +-- Returns a new ArbValueGen that is identical to the passed ArbValueGen +constArbValue :: Type -> TypeEnv -> ArbValueGen -> (Expr, ArbValueGen) +constArbValue = constArbValue' getFiniteADT HM.empty + +-- | Allows the generation of arbitrary values of the given type. -- Does not always cut off recursive ADTs. -- Returns a new ArbValueGen that (in the case of the primitives) -- will give a different value the next time arbValue is called with -- the same Type. arbValueInfinite :: Type -> TypeEnv -> ArbValueGen -> (Expr, ArbValueGen) -arbValueInfinite = arbValue' getADT +arbValueInfinite t = arbValueInfinite' cutOffVal HM.empty t -arbValue' :: GetADT -> Type -> TypeEnv -> ArbValueGen -> (Expr, ArbValueGen) -arbValue' getADTF t tenv av +arbValueInfinite' :: Int -> HM.HashMap Name Type -> Type -> TypeEnv -> ArbValueGen -> (Expr, ArbValueGen) +arbValueInfinite' cutoff = arbValue' (getADT cutoff) + +arbValue' :: GetADT + -> HM.HashMap Name Type -- ^ Maps TyVar's to Types + -> Type + -> TypeEnv + -> ArbValueGen + -> (Expr, ArbValueGen) +arbValue' getADTF m (TyFun t t') tenv av = + let + (e, av') = arbValue' getADTF m t' tenv av + in + (Lam TermL (Id (Name "_" Nothing 0 Nothing) t) e, av') +arbValue' getADTF m t tenv av | TyCon n _ <- tyAppCenter t , ts <- tyAppArgs t = maybe (Prim Undefined TyBottom, av) - (\adt -> getADTF tenv av adt ts) - (M.lookup n tenv) -arbValue' getADTF (TyApp t1 t2) tenv av = + (\adt -> getADTF m tenv av adt ts) + (HM.lookup n tenv) +arbValue' getADTF m (TyApp t1 t2) tenv av = let - (e1, av') = arbValue' getADTF t1 tenv av - (e2, av'') = arbValue' getADTF t2 tenv av' + (e1, av') = arbValue' getADTF m t1 tenv av + (e2, av'') = arbValue' getADTF m t2 tenv av' in (App e1 e2, av'') -arbValue' _ TyLitInt _ av = +arbValue' _ _ TyLitInt _ av = let i = intGen av in (Lit (LitInt $ i), av { intGen = i + 1 }) -arbValue' _ TyLitFloat _ av = +arbValue' _ _ TyLitFloat _ av = let f = floatGen av in (Lit (LitFloat $ f), av { floatGen = f + 1 }) -arbValue' _ TyLitDouble _ av = +arbValue' _ _ TyLitDouble _ av = let d = doubleGen av in (Lit (LitDouble $ d), av { doubleGen = d + 1 }) -arbValue' _ TyLitChar _ av = +arbValue' _ _ TyLitChar _ av = let c:cs = case charGen av of xs@(_:_) -> xs _ -> charGenInit in (Lit (LitChar c), av { charGen = cs}) -arbValue' _ t _ av = (Prim Undefined t, av) +arbValue' getADTF m (TyVar (Id n _)) tenv av + | Just t <- HM.lookup n m = arbValue' getADTF m t tenv av +arbValue' _ _ t _ av = (Prim Undefined t, av) -type GetADT = TypeEnv -> ArbValueGen -> AlgDataTy -> [Type] -> (Expr, ArbValueGen) --- Generates an arbitrary value of the given ADT, --- but will return something containing @(Prim Undefined)@ instead of an infinite Expr -getFiniteADT :: TypeEnv -> ArbValueGen -> AlgDataTy -> [Type] -> (Expr, ArbValueGen) -getFiniteADT tenv av adt ts = +constArbValue' :: GetADT -> HM.HashMap Name Type -> Type -> TypeEnv -> ArbValueGen -> (Expr, ArbValueGen) +constArbValue' getADTF m (TyFun t t') tenv av = let - (e, av') = getADT tenv av adt ts + (e, _) = constArbValue' getADTF m t' tenv av in + (Lam TermL (Id (Name "_" Nothing 0 Nothing) t) e, av) +constArbValue' getADTF m t tenv av + | TyCon n _ <- tyAppCenter t + , ts <- tyAppArgs t = + maybe (Prim Undefined TyBottom, av) + (\adt -> getADTF m tenv av adt ts) + (HM.lookup n tenv) +constArbValue' getADTF m (TyApp t1 t2) tenv av = + let + (e1, _) = constArbValue' getADTF m t1 tenv av + (e2, _) = constArbValue' getADTF m t2 tenv av + in + (App e1 e2, av) +constArbValue' _ _ TyLitInt _ av = + let + i = intGen av + in + (Lit (LitInt $ i), av) +constArbValue' _ _ TyLitFloat _ av = + let + f = floatGen av + in + (Lit (LitFloat $ f), av) +constArbValue' _ _ TyLitDouble _ av = + let + d = doubleGen av + in + (Lit (LitDouble $ d), av) +constArbValue' _ _ TyLitChar _ av = + let + c:_ = case charGen av of + xs@(_:_) -> xs + _ -> charGenInit + in + (Lit (LitChar c), av) +constArbValue' getADTF m (TyVar (Id n _)) tenv av + | Just t <- HM.lookup n m = constArbValue' getADTF m t tenv av +constArbValue' _ _ t _ av = (Prim Undefined t, av) + +type GetADT = HM.HashMap Name Type -> TypeEnv -> ArbValueGen -> AlgDataTy -> [Type] -> (Expr, ArbValueGen) + +-- | Generates an arbitrary value of the given ADT, +-- but will return something containing @(Prim Undefined)@ instead of an infinite Expr. +getFiniteADT :: HM.HashMap Name Type -> TypeEnv -> ArbValueGen -> AlgDataTy -> [Type] -> (Expr, ArbValueGen) +getFiniteADT m tenv av adt ts = + let + (e, av') = getADT cutOffVal m tenv av adt ts + in (cutOff [] e, av') +-- | How long to go before cutting off finite ADTs? +cutOffVal :: Int +cutOffVal = 3 + cutOff :: [Name] -> Expr -> Expr cutOff ns a@(App _ _) | Data (DataCon n _) <- appCenter a = - case n `elem` ns of + case length (filter (== n) ns) > cutOffVal of True -> Prim Undefined TyBottom False -> mapArgs (cutOff (n:ns)) a cutOff _ e = e -- | Generates an arbitrary value of the given AlgDataTy --- If there is no such finite value, this may return an infinite Expr -getADT :: TypeEnv -> ArbValueGen -> AlgDataTy -> [Type] -> (Expr, ArbValueGen) -getADT tenv av adt ts = - let - dcs = dataCon adt - ids = boundIds adt +-- If there is no such finite value, this may return an infinite Expr. +-- +-- Has a bit of a hack: will update the ArbValueGen, but only for a limited number of loops. +-- This is to ensure that an ArbValueGen is eventually returned. +-- To see why this is needed, suppose we are returning an infinitely large Expr. +-- This Expr will be returned lazily. But the return of the ArbValueGen is not lazy- +-- so we must just cut off and return at some point. +getADT :: Int -> HM.HashMap Name Type -> TypeEnv -> ArbValueGen -> AlgDataTy -> [Type] -> (Expr, ArbValueGen) +getADT cutoff m tenv av adt ts + | dcs <- dataCon adt + , _:_ <- dcs = + let + ids = bound_ids adt - -- Finds the DataCon for adt with the least arguments - min_dc = minimumBy (comparing (length . dataConArgs)) dcs + -- Finds the DataCon for adt with the least arguments + min_dc = minimumBy (comparing (length . anonArgumentTypes)) dcs - tyVIds = map TyVar ids - min_dc' = foldr (uncurry replaceASTs) min_dc $ zip tyVIds ts + m' = foldr (uncurry HM.insert) m $ zip (map idName ids) ts - (av', es) = mapAccumL (\av_ t -> swap $ arbValueInfinite t tenv av_) av $ dataConArgs min_dc' - in - (mkApp $ Data min_dc':map Type ts ++ es, av') + (av', es) = mapAccumL (\av_ t -> swap $ arbValueInfinite' (cutoff - 1) m' (applyTypeHashMap m' t) tenv av_) av $ anonArgumentTypes min_dc + + final_av = if cutoff >= 0 then av' else av + in + (mkApp $ Data min_dc:map Type ts ++ es, final_av) + | otherwise = (Prim Undefined TyBottom, av) diff --git a/src/G2/Language/CallGraph.hs b/src/G2/Language/CallGraph.hs new file mode 100644 --- /dev/null +++ b/src/G2/Language/CallGraph.hs @@ -0,0 +1,86 @@ +module G2.Language.CallGraph ( CallGraph + , getCallGraph + , functions + , calls + , calledBy + , nameLevels + , reachable ) where + +import qualified G2.Language.ExprEnv as E +import G2.Language.Naming +import G2.Language.Syntax + +import Data.Graph hiding (reachable) +import qualified Data.Graph as G +import Data.Maybe + +data CallGraph = CallGraph { graph :: Graph + , nfv :: Vertex -> ((), Name, [Name]) + , vert :: Name -> Maybe Vertex} + +getCallGraph :: E.ExprEnv -> CallGraph +getCallGraph eenv = + let + funcs = E.keys eenv + + (g, nfv', vert') = graphFromEdges + . map (\(n, e) -> + let + clls = filter (\n' -> n' `elem` funcs) . map idName $ varIds e + in + ((), n, clls)) $ E.toList eenv + in + CallGraph g nfv' vert' + +functions :: CallGraph -> [Name] +functions cg = map (\(_, n, _) -> n) . map (nfv cg) . vertices $ graph cg + +callsList :: CallGraph -> [(Name, Name)] +callsList cg = map (\(v1, v2) -> (mid $ nfv cg v1, mid $ nfv cg v2)) . edges $ graph cg + where + mid (_, m, _) = m + +nodeName :: CallGraph -> Vertex -> Name +nodeName g v = (\(_, n, _) -> n) $ nfv g v + +-- | Functions directly called by the named function +calls :: Name -> CallGraph -> Maybe [Name] +calls n g = fmap (\(_, _, ns) -> ns) . fmap (nfv g) $ vert g n + +calledBy :: Name -> CallGraph -> [Name] +calledBy n g = map fst + . filter ((==) n . snd) + . map (\(v1, v2) -> (nodeName g v1, nodeName g v2)) $ edges (graph g) + +-- Functions directly and indirectly called by the named function +reachable :: Name -> CallGraph -> [Name] +reachable n g = + map ((\(_, x, _) -> x) . nfv g) . maybe [] (G.reachable $ graph g) $ vert g n + +-- | Returns: +-- (1) a list of list of names, where the first list contains functions +-- that are not called by any functions (except themselves), and the nth list, n > 2, +-- includes functions called by functions in the (n - 1)th list. +nameLevels :: CallGraph -> [[Name]] +nameLevels cg = + let + fs = functions cg + eds = callsList cg + + callers = fs + called_by_others = mapMaybe (\(n1, n2) -> if n1 /= n2 then Just n2 else Nothing) eds + + only_caller = filter (`notElem` called_by_others) callers + in + only_caller:nameLevels' only_caller (removeEdgesTo only_caller eds) + +nameLevels' :: [Name] -> [(Name, Name)] -> [[Name]] +nameLevels' [] _ = [] +nameLevels' callers eds = + let + called = map snd $ filter (\(n1, _) -> n1 `elem` callers) eds + in + called:nameLevels' called (removeEdgesTo called eds) + +removeEdgesTo :: [Name] -> [(Name, Name)] -> [(Name, Name)] +removeEdgesTo ns = filter (\(_, n2) -> n2 `notElem` ns) diff --git a/src/G2/Language/Casts.hs b/src/G2/Language/Casts.hs --- a/src/G2/Language/Casts.hs +++ b/src/G2/Language/Casts.hs @@ -13,22 +13,44 @@ import G2.Language.Naming import G2.Language.Syntax import G2.Language.Typing +import Data.Monoid as M +containsCast :: ASTContainer m Expr => m -> M.Any +containsCast = evalASTs isCast + +isCast :: Expr -> M.Any +isCast (Cast _ _) = Any True +isCast _ = Any False + -- | Removes all casts from the expression. Makes no guarantees about the type -- correctness of the resulting expression. In particular, the expression -- is likely to not actually type correctly if it contains variables that -- are mapped in the Expression Environment unsafeElimCast :: ASTContainer m Expr => m -> m -unsafeElimCast = modifyASTsFix unsafeElimOuterCast +unsafeElimCast e = if (getAny $ containsCast e) then modifyContainedASTs unsafeElimOuterCast e else e unsafeElimOuterCast :: Expr -> Expr unsafeElimOuterCast (Cast e (t1 :~ t2)) = replaceASTs t1 t2 e unsafeElimOuterCast e = e -- | Given a function cast from (t1 -> t2) to (t1' -> t2'), decomposes it to two --- seperate casts, from t1 to t1', and from t2 to t2'. Given a cast (t1 ~ t2) --- where t1 is a NewTyCon N t3 such that t2 /= t3, changes the cast to be --- (t1 ~ t3) (t3 ~ t2). +-- seperate casts, from t1' to t1, and from t2 to t2'. +-- Note that the direction of the cast differs intentionally. Consider: +-- +-- @ newtype Money = Money Int +-- newtype Person = Person String +-- f :: String -> Money +-- p :: Person +-- +-- g = coerce (f :: Person -> Int) p +-- g' = coerce (f (coerce p :: String)) :: Int +-- @ +-- g and g' are equivalent. To shift the coercion from a function coercion to coercions on the inputs and outputs, +-- we keep the same result type coercion, but have to flip the argument coercion. +-- +-- In addition to splitting function casts, given a cast (t1 ~ t2) where t1 is a NewTyCon N t3 such that t2 /= t3, +-- we change the cast to be (t1 ~ t3) (t3 ~ t2). +-- -- Given any other expression, acts as the identity function splitCast :: NameGen -> Expr -> (Expr, NameGen) splitCast ng (Cast e ((TyFun t1 t2) :~ (TyFun t1' t2'))) = @@ -39,13 +61,13 @@ (Cast (App e - (Cast (Var i) (t1 :~ t1')) + (Cast (Var i) (t1' :~ t1)) ) (t2 :~ t2') ) in (e', ng') -splitCast ng (Cast e ((TyForAll (NamedTyBndr ni) t2) :~ (TyForAll (NamedTyBndr ni') t2'))) = +splitCast ng (Cast e ((TyForAll ni t2) :~ (TyForAll ni' t2'))) = let t1 = typeOf ni t1' = typeOf ni' @@ -58,12 +80,12 @@ e (Cast (Var i) (t1 :~ t1')) ) - (t2 :~ t2') + (rename (idName ni) (idName i) t2 :~ rename (idName ni') (idName i) t2') ) in (e', ng') -splitCast ng c@(Cast e (t1 :~ t2)) = - if hasFuncType (PresType t1) || hasFuncType (PresType t2) then (e, ng) else (c, ng) +-- splitCast ng c@(Cast e (t1 :~ t2)) = +-- if hasFuncType (PresType t1) || hasFuncType (PresType t2) then (e, ng) else (c, ng) splitCast ng e = (e, ng) -- | Eliminates redundant casts. @@ -89,7 +111,7 @@ liftCasts' e = e liftCasts'' :: Expr-> Expr -liftCasts'' (App (Cast f (TyForAll (NamedTyBndr b1) t1 :~ TyForAll (NamedTyBndr b2) t2)) e@(Type t)) = +liftCasts'' (App (Cast f (TyForAll b1 t1 :~ TyForAll b2 t2)) e@(Type t)) = let t1' = retype b1 t t1 t2' = retype b2 t t2 diff --git a/src/G2/Language/Expr.hs b/src/G2/Language/Expr.hs --- a/src/G2/Language/Expr.hs +++ b/src/G2/Language/Expr.hs @@ -3,51 +3,85 @@ {-# LANGUAGE OverloadedStrings #-} module G2.Language.Expr ( module G2.Language.Casts - , unApp - , mkApp - , mkDCTrue - , mkDCFalse - , mkTrue - , mkFalse - , mkBool - , mkDCInt - , mkDCInteger - , mkDCFloat - , mkDCDouble - , mkDCChar - , mkCons - , mkEmpty - , mkIdentity - , getFuncCalls - , getFuncCallsRHS - , modifyAppTop - , modifyAppLHS - , modifyAppRHS - , modifyLamTop - , nonDataFunctionCalls - , appCenter - , mapArgs - , mkLams - , elimAsserts - , leadingLamUsesIds - , leadingLamIds - , insertInLams - , maybeInsertInLams - , inLams - , replaceASTs - , args - , passedArgs - , vars - , varIds - , varNames - , varId - , symbVars - , freeVars - , alphaReduction - , varBetaReduction - , etaExpandTo - , mkStrict) where + , eqUpToTypes + , unApp + , mkApp + , mkDCTrue + , mkDCFalse + , mkTrue + , mkFalse + , mkBool + , mkDCInt + , mkDCInteger + , mkDCFloat + , mkDCDouble + , mkDCChar + , mkCons + , mkEmpty + , mkG2List + , mkJust + , mkNothing + , mkUnit + , mkIdentity + , mkEqExpr + , mkGeIntExpr + , mkLeIntExpr + , mkAndExpr + , mkOrExpr + , mkNotExpr + , mkImpliesExpr + , mkToRatioExpr + , mkFromRationalExpr + , mkIntegralExtactReal + , mkRealExtractNum + , mkRealExtractOrd + , mkOrdExtractEq + + , mkEqPrimExpr + + , isData + , isLit + , isLam + , isADT + + , replaceVar + , getFuncCalls + , getFuncCallsRHS + , modifyAppTop + , modifyAppedDatas + , modifyAppLHS + , modifyAppRHS + , modifyLamTop + , nonDataFunctionCalls + , appCenter + , mapArgs + , mkLams + , elimAsserts + , elimAssumes + , assertsToAssumes + , leadingLamUsesIds + , leadingLamIds + , insertInLams + , maybeInsertInLams + , inLams + , simplifyLams + , flattenLets + , replaceASTs + , args + , passedArgs + , vars + , varIds + , varNames + , varId + , symbVars + , freeVars + , alphaReduction + , varBetaReduction + , etaExpandTo + , mkStrict + , mkStrict_maybe) where + import G2.Language.AST import G2.Language.Casts import qualified G2.Language.ExprEnv as E @@ -56,17 +90,44 @@ import G2.Language.Support import G2.Language.Syntax import G2.Language.Typing +import G2.Language.Primitives import Data.Foldable import qualified Data.Map as M import Data.Maybe import Data.Semigroup +eqUpToTypes :: Expr -> Expr -> Bool +eqUpToTypes (Var (Id n _)) (Var (Id n' _)) = n == n' +eqUpToTypes (Lit l) (Lit l') = l == l' +eqUpToTypes (Prim p _) (Prim p' _) = p == p' +eqUpToTypes (Data (DataCon n _)) (Data (DataCon n' _)) = n == n' +eqUpToTypes (App e1 e2) (App e1' e2') = e1 `eqUpToTypes` e1' && e2 `eqUpToTypes` e2' +eqUpToTypes (Lam lu (Id n _) e) (Lam lu' (Id n' _) e') = lu == lu' && n == n' && e `eqUpToTypes` e' +eqUpToTypes (Let b e) (Let b' e') = + let + be_eq = all (\((Id n _, be), (Id n' _, be')) -> n == n' && be `eqUpToTypes` be') $ zip b b' + in + be_eq && e `eqUpToTypes` e' +eqUpToTypes (Case _ _ _ _) (Case _ _ _ _) = error "Case not supported" +eqUpToTypes (Type _) (Type _) = True +eqUpToTypes (Cast e _) (Cast e' _) = e `eqUpToTypes` e' +eqUpToTypes (Coercion _) (Coercion _) = True +eqUpToTypes (Tick _ e) (Tick _ e') = e `eqUpToTypes` e' +eqUpToTypes (NonDet es) (NonDet es') = all (uncurry eqUpToTypes) $ zip es es' +eqUpToTypes (SymGen _ _) (SymGen _ _) = True +eqUpToTypes (Assume _ _ _) (Assume _ _ _) = True +eqUpToTypes (Assert _ _ _) (Assert _ _ _) = True +eqUpToTypes _ _ = False + -- | Unravels the application spine. unApp :: Expr -> [Expr] -unApp (App f a) = unApp f ++ [a] -unApp expr = [expr] +unApp = unApp' [] +unApp' :: [Expr] -> Expr -> [Expr] +unApp' xs (App f a) = unApp' (a:xs) f +unApp' xs e = e:xs + -- | Turns the Expr list into an Application -- -- @ mkApp [e1, e2, e3] == App (App e1 e2) e3@ @@ -110,7 +171,29 @@ mkEmpty :: KnownValues -> TypeEnv -> Expr mkEmpty kv tenv = Data . fromJust $ getDataCon tenv (KV.tyList kv) (KV.dcEmpty kv) + +-- | Construct a G2 list `Expr` containing a list of `Expr`s +mkG2List :: KnownValues + -> TypeEnv + -> Type -- ^ The type of the values in the list. + -> [Expr] + -> Expr +mkG2List kv tenv t = foldr go (App emp (Type t)) + where + cons = mkCons kv tenv + emp = mkEmpty kv tenv + go e es = App (App (App cons (Type t)) e) es + +mkJust :: KnownValues -> TypeEnv -> Expr +mkJust kv tenv = Data . fromJust $ getDataCon tenv (KV.tyMaybe kv) (KV.dcJust kv) + +mkNothing :: KnownValues -> TypeEnv -> Expr +mkNothing kv tenv = Data . fromJust $ getDataCon tenv (KV.tyMaybe kv) (KV.dcNothing kv) + +mkUnit :: KnownValues -> TypeEnv -> Expr +mkUnit kv tenv = Data . fromJust $ getDataCon tenv (KV.tyUnit kv) (KV.dcUnit kv) + mkIdentity :: Type -> Expr mkIdentity t = let @@ -118,6 +201,89 @@ in Lam TermL x (Var x) +mkEqExpr :: KnownValues -> Expr -> Expr -> Expr +mkEqExpr kv e1 e2 = App (App eq e1) e2 + where eq = mkEqPrimType (typeOf e1) kv + +mkEqPrimExpr :: KnownValues -> Expr -> Expr -> Expr +mkEqPrimExpr kv e1 e2 = App (App eq e1) e2 + where eq = mkEqPrimType (typeOf e1) kv + +mkGeIntExpr :: KnownValues -> Expr -> Integer -> Expr +mkGeIntExpr kv e num = App (App ge e) (Lit (LitInt num)) + where ge = mkGePrimInt kv + +mkLeIntExpr :: KnownValues -> Expr -> Integer -> Expr +mkLeIntExpr kv e num = App (App le e) (Lit (LitInt num)) + where le = mkLePrimInt kv + +mkAndExpr :: KnownValues -> Expr -> Expr -> Expr +mkAndExpr kv e1 e2 = App (App andEx e1) e2 + where andEx = mkAndPrim kv + +mkOrExpr :: KnownValues -> Expr -> Expr -> Expr +mkOrExpr kv e1 e2 = App (App orEx e1) e2 + where orEx = mkOrPrim kv + +mkImpliesExpr :: KnownValues -> Expr -> Expr -> Expr +mkImpliesExpr kv e1 e2 = App (App impEx e1) e2 + where impEx = mkImpliesPrim kv + +mkNotExpr :: KnownValues -> Expr -> Expr +mkNotExpr kv e = App notEx e + where notEx = mkNotPrim kv + +mkToRatioExpr :: KnownValues -> Expr +mkToRatioExpr kv = Var $ Id (KV.toRatioFunc kv) TyUnknown + +mkFromRationalExpr :: KnownValues -> Expr +mkFromRationalExpr kv = Var $ Id (KV.fromRationalFunc kv) TyUnknown + +mkIntegralExtactReal :: KnownValues -> Expr +mkIntegralExtactReal kv = Var $ Id (KV.integralExtactReal kv) TyUnknown + +mkRealExtractNum :: KnownValues -> Expr +mkRealExtractNum kv = Var $ Id (KV.realExtractNum kv) TyUnknown + +mkRealExtractOrd :: KnownValues -> Expr +mkRealExtractOrd kv = Var $ Id (KV.realExtractOrd kv) TyUnknown + +mkOrdExtractEq :: KnownValues -> Expr +mkOrdExtractEq kv = Var $ Id (KV.ordExtractEq kv) TyUnknown + +isData :: Expr -> Bool +isData (Data _) = True +isData _ = False + +isLit :: Expr -> Bool +isLit (Lit _) = True +isLit _ = False + +isLam :: Expr -> Bool +isLam (Lam _ _ _) = True +isLam _ = False + +isADT :: Expr -> Bool +isADT e + | Data _:_ <- unApp e = True + | otherwise = False + +replaceVar :: ASTContainer m Expr => Name -> Expr -> m -> m +replaceVar n e = modifyContainedASTs (replaceVar' n e) + +replaceVar' :: Name -> Expr -> Expr -> Expr +replaceVar' n e v@(Var (Id n' _)) = + if n == n' then e else v +replaceVar' n _ le@(Lam _ (Id n' _) _) | n == n' = le +replaceVar' n e (Case b i@(Id n' _) t as) | n == n' = Case (replaceVar n e b) i t as +replaceVar' n e (Case b i t as) = Case (replaceVar' n e b) i t (map repAlt as) + where + repAlt a@(Alt (DataAlt _ is) _) + | n `elem` map idName is = a + repAlt a = modifyContainedASTs (replaceVar' n e) a +replaceVar' n _ le@(Let b _) | n `elem` map (idName . fst) b = le +replaceVar' n e e' = modifyChildren (replaceVar' n e) e' + getFuncCalls :: ASTContainer m Expr => m -> [Expr] getFuncCalls = evalContainedASTs getFuncCalls' @@ -141,17 +307,33 @@ let e' = f e in - modifyAppRHS (modifyAppTop' f) e' -modifyAppTop' f e = modifyChildren f e + modifyAppCenter (modifyChildren (modifyAppTop' f)) $ modifyAppRHS (modifyAppTop' f) e' +modifyAppTop' f e = modifyChildren (modifyAppTop' f) e -modifyAppLHS :: (Expr -> Expr) -> Expr -> Expr -modifyAppLHS f (App e e') = App (f e) (modifyAppLHS f e') -modifyAppLHS _ e = e +modifyAppedDatas :: ASTContainer m Expr => (DataCon -> [Expr] -> Expr) -> m -> m +modifyAppedDatas f = modifyContainedASTs (modifyAppedDatas' f) +modifyAppedDatas' :: (DataCon -> [Expr] -> Expr) -> Expr -> Expr +modifyAppedDatas' f e + | (Data dc:es) <- unApp e = + let + e' = f dc es + in + modifyAppCenter (modifyChildren (modifyAppedDatas' f)) $ modifyAppRHS (modifyAppedDatas' f) e' + | otherwise = modifyChildren (modifyAppedDatas' f) e + modifyAppRHS :: (Expr -> Expr) -> Expr -> Expr modifyAppRHS f (App e e') = App (modifyAppRHS f e) (f e') modifyAppRHS _ e = e +modifyAppLHS :: (Expr -> Expr) -> Expr -> Expr +modifyAppLHS f (App e e') = App (f e) (modifyAppLHS f e') +modifyAppLHS _ e = e + +modifyAppCenter :: (Expr -> Expr) -> Expr -> Expr +modifyAppCenter f (App e e') = App (modifyAppCenter f e) e' +modifyAppCenter f e = f e + modifyLamTop :: ASTContainer m Expr => (Expr -> Expr) -> m -> m modifyLamTop f = modifyContainedASTs (modifyLamTop' f) @@ -196,6 +378,21 @@ elimAsserts' (Assert _ _ e) = e elimAsserts' e = e +-- | Remove all @Assume@s from the given `Expr` +elimAssumes :: ASTContainer m Expr => m -> m +elimAssumes = modifyASTs elimAssumes' + +elimAssumes' :: Expr -> Expr +elimAssumes' (Assume _ _ e) = e +elimAssumes' e = e + +assertsToAssumes :: ASTContainer m Expr => m -> m +assertsToAssumes = modifyASTs assertsToAssumes' + +assertsToAssumes' :: Expr -> Expr +assertsToAssumes' (Assert fc e e') = Assume fc e e' +assertsToAssumes' e = e + -- Runs the given function f on the expression nested in the lambdas, and -- rewraps the new expression with the Lambdas insertInLams :: ([Id] -> Expr -> Expr) -> Expr -> Expr @@ -217,6 +414,13 @@ inLams (Lam _ _ e) = inLams e inLams e = e +simplifyLams :: ASTContainer c Expr => c -> c +simplifyLams = modifyASTs simplifyLams' + +simplifyLams' :: Expr -> Expr +simplifyLams' (App (Lam _ i e1) e2) = replaceASTs (Var i) e2 e1 +simplifyLams' e = e + leadingLamUsesIds :: Expr -> [(LamUse, Id)] leadingLamUsesIds (Lam u i e) = (u, i):leadingLamUsesIds e leadingLamUsesIds _ = [] @@ -225,6 +429,28 @@ leadingLamIds (Lam _ i e) = i:leadingLamIds e leadingLamIds _ = [] +flattenLets :: ASTContainer m Expr => m -> m +flattenLets = modifyASTs flattenLet + +flattenLet :: Expr -> Expr +flattenLet l@(Let be e) = + case findElem (isLet . snd) be of + Just ((bi, Let ibe ie), be') -> flattenLet $ Let (ibe ++ (bi, ie):be') e + _ -> l +flattenLet e = e + +isLet :: Expr -> Bool +isLet (Let _ _) = True +isLet _ = False + +findElem :: (a -> Bool) -> [a] -> Maybe (a, [a]) +findElem p = find' id + where + find' _ [] = Nothing + find' pre (x : xs) + | p x = Just (x, pre xs) + | otherwise = find' (pre . (x:)) xs + -- | Returns all Ids from Lam's at the top of the Expr args :: Expr -> [Id] args (Lam _ i e) = i:args e @@ -238,32 +464,36 @@ passedArgs' _ = [] --Returns all Vars in an ASTContainer -vars :: (ASTContainer m Expr) => m -> [Expr] +vars :: (ASTContainer m Expr) => m -> [Id] vars = evalASTs vars' -vars' :: Expr -> [Expr] -vars' v@(Var _) = [v] +vars' :: Expr -> [Id] +vars' (Var i) = [i] vars' _ = [] varId :: Expr -> Maybe Id varId (Var i) = Just i varId _ = Nothing -symbVars :: (ASTContainer m Expr) => ExprEnv -> m -> [Expr] +symbVars :: (ASTContainer m Expr) => ExprEnv -> m -> [Id] symbVars eenv = filter (symbVars' eenv) . vars -symbVars' :: ExprEnv -> Expr -> Bool -symbVars' eenv (Var (Id n _)) = E.isSymbolic n eenv -symbVars' _ _ = False +symbVars' :: ExprEnv -> Id -> Bool +symbVars' eenv (Id n _) = E.isSymbolic n eenv -- | freeVars -- Returns the free (unbound by a Lambda, Let, or the Expr Env) variables of an expr freeVars :: ASTContainer m Expr => E.ExprEnv -> m -> [Id] freeVars eenv = evalASTsMonoid (freeVars' eenv) +freeAltMatch :: AltMatch -> [Id] +freeAltMatch (DataAlt _ is) = is +freeAltMatch _ = [] + freeVars' :: E.ExprEnv -> [Id] -> Expr -> ([Id], [Id]) freeVars' _ _ (Let b _) = (map fst b, []) freeVars' _ _ (Lam _ b _) = ([b], []) +freeVars' _ _ (Case _ b _ alt) = (b:concatMap (freeAltMatch . altMatch) alt, []) freeVars' eenv bound (Var i) = if E.member (idName i) eenv || i `elem` bound then ([], []) @@ -357,6 +587,7 @@ | otherwise = n' where m' = M.insert v i m + validN _ _ i (Data _) = i validN eenv' m i (App e' _) = validN eenv' m (i + 1) e' validN eenv' m i (Let b e') = let @@ -367,8 +598,8 @@ addLamApps :: [Name] -> Type -> Expr -> Expr addLamApps [] _ e' = e' - addLamApps (_:ns) (TyForAll (NamedTyBndr b) t') e' = - Lam TypeL b (App (addLamApps ns t' e') (Var b)) + addLamApps (_:ns) (TyForAll b t') e' = + Lam TypeL b (App (addLamApps ns t' e') (Type (TyVar b))) addLamApps (ln:ns) (TyFun t t') e' = Lam TermL (Id ln t) (App (addLamApps ns t' e') (Var (Id ln t))) addLamApps _ _ e' = e' @@ -399,3 +630,24 @@ Just i -> foldl' (App) (Var i) (map Type ts ++ map (typeToWalker w) ts) Nothing -> error $ "typeToWalker: failed to find type: " ++ show n typeToWalker _ t = mkIdentity t + +mkStrict_maybe :: Walkers -> Expr -> Maybe Expr +mkStrict_maybe w e = + let + t = tyAppCenter (typeOf e) + ts = tyAppArgs (typeOf e) + in + case t of + (TyCon n _) -> case M.lookup n w of + Just i -> Just $ App (foldl' (App) (Var i) (map Type ts ++ map (typeToWalker_maybe w) ts)) e + Nothing -> Nothing + _ -> Nothing + +typeToWalker_maybe :: Walkers -> Type -> Expr +typeToWalker_maybe w t + | TyCon n _ <- tyAppCenter t + , ts <- tyAppArgs t = + case M.lookup n w of + Just i -> foldl' (App) (Var i) (map Type ts ++ map (typeToWalker_maybe w) ts) + Nothing -> mkIdentity t +typeToWalker_maybe _ t = mkIdentity t diff --git a/src/G2/Language/ExprEnv.hs b/src/G2/Language/ExprEnv.hs --- a/src/G2/Language/ExprEnv.hs +++ b/src/G2/Language/ExprEnv.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} @@ -6,6 +7,10 @@ module G2.Language.ExprEnv ( ExprEnv , ConcOrSym (..) + , EnvObj (..) + + , concOrSymToExpr + , empty , singleton , fromList @@ -14,21 +19,31 @@ , member , lookup , lookupConcOrSym + , lookupEnvObj , deepLookup , isSymbolic , occLookup , lookupNameMod + , nameModMap , insert , insertSymbolic , insertExprs , redirect + , difference , union + , union' + , unionWith + , unionWithM + , unionWithNameM , (!) , map , map' + , mapConc , mapWithKey , mapWithKey' - , mapKeys + , mapConcWithKey + , mapConcOrSym + , mapConcOrSymWithKey , mapM , mapWithKeyM , filter @@ -37,12 +52,15 @@ , getIdFromName , funcsOfType , keys - , symbolicKeys + , symbolicIds , elems , higherOrderExprs + , redirsToExprs , toList , toExprList , fromExprList + , fromExprMap + , toHashMap ) where import G2.Language.AST @@ -58,14 +76,24 @@ import qualified Prelude as Pre import Data.Coerce import Data.Data (Data, Typeable) +import Data.Hashable import qualified Data.List as L -import qualified Data.Map as M +import qualified Data.HashMap.Lazy as M import Data.Maybe +import Data.Monoid ((<>)) +import qualified Data.Sequence as S import qualified Data.Text as T +import qualified Data.Traversable as Trav +import GHC.Generics (Generic) data ConcOrSym = Conc Expr | Sym Id + deriving (Show) +concOrSymToExpr :: ConcOrSym -> Expr +concOrSymToExpr (Conc e) = e +concOrSymToExpr (Sym i) = Var i + -- From a user perspective, `ExprEnv`s are mappings from `Name` to -- `Expr`s. however, there are two complications: -- 1) Redirection pointers can map two names to the same expr @@ -75,14 +103,27 @@ data EnvObj = ExprObj Expr | RedirObj Name | SymbObj Id - deriving (Show, Eq, Read, Typeable, Data) + deriving (Show, Eq, Read, Generic, Typeable, Data) -newtype ExprEnv = ExprEnv (M.Map Name EnvObj) - deriving (Show, Eq, Read, Typeable, Data) +instance Hashable EnvObj -unwrapExprEnv :: ExprEnv -> M.Map Name EnvObj +-- | Maps `Name`s to `Expr`s. Tracks `Type`s of symbolic variables. +newtype ExprEnv = ExprEnv (M.HashMap Name EnvObj) + deriving (Show, Eq, Read, Generic, Typeable, Data) + +instance Hashable ExprEnv + +{-# INLINE unwrapExprEnv #-} +unwrapExprEnv :: ExprEnv -> M.HashMap Name EnvObj unwrapExprEnv = coerce +toHashMap :: ExprEnv -> M.HashMap Name Expr +toHashMap eenv = + M.map(\e -> case e of + ExprObj e' -> e' + RedirObj n' -> eenv ! n' + SymbObj i -> Var i) . unwrapExprEnv $ eenv + -- | Constructs an empty `ExprEnv` empty :: ExprEnv empty = ExprEnv M.empty @@ -95,7 +136,7 @@ fromList :: [(Name, Expr)] -> ExprEnv fromList = ExprEnv . M.fromList . Pre.map (\(n, e) -> (n, ExprObj e)) --- Is the `ExprEnv` empty? +-- | Is the `ExprEnv` empty? null :: ExprEnv -> Bool null = M.null . unwrapExprEnv @@ -125,6 +166,9 @@ Just (SymbObj i) -> Just $ Sym i Nothing -> Nothing +lookupEnvObj :: Name -> ExprEnv -> Maybe EnvObj +lookupEnvObj n = M.lookup n . unwrapExprEnv + -- | Lookup the `Expr` with the given `Name`. -- If the name is bound to a @Var@, recursively searches that @Vars@ name. -- Returns `Nothing` if the `Name` is not in the `ExprEnv`. @@ -153,6 +197,9 @@ lookupNameMod ns ms = listToMaybe . L.filter (\(Name n m _ _, _) -> ns == n && ms == m) . toExprList +nameModMap :: ExprEnv -> M.HashMap (T.Text, Maybe T.Text) (Name, Expr) +nameModMap = M.fromList . L.map (\(n@(Name n' m _ _), e) -> ((n', m), (n, e))) . toExprList + -- | Looks up a `Name` in the `ExprEnv`. Crashes if the `Name` is not found. (!) :: ExprEnv -> Name -> Expr (!) env@(ExprEnv env') n = @@ -167,8 +214,8 @@ insert :: Name -> Expr -> ExprEnv -> ExprEnv insert n e = ExprEnv . M.insert n (ExprObj e) . unwrapExprEnv -insertSymbolic :: Name -> Id -> ExprEnv -> ExprEnv -insertSymbolic n i = ExprEnv. M.insert n (SymbObj i) . unwrapExprEnv +insertSymbolic :: Id -> ExprEnv -> ExprEnv +insertSymbolic i = ExprEnv. M.insert (idName i) (SymbObj i) . unwrapExprEnv insertExprs :: [(Name, Expr)] -> ExprEnv -> ExprEnv insertExprs kvs scope = foldr (uncurry insert) scope kvs @@ -177,19 +224,54 @@ redirect :: Name -> Name -> ExprEnv -> ExprEnv redirect n n' = ExprEnv . M.insert n (RedirObj n') . unwrapExprEnv +difference :: ExprEnv -> ExprEnv -> ExprEnv +difference (ExprEnv m1) (ExprEnv m2) = + ExprEnv $ M.difference m1 m2 + +-- | Get the union of two `ExprEnv`. If names overlap, keep the mapping in the left `ExprEnv`. union :: ExprEnv -> ExprEnv -> ExprEnv union (ExprEnv eenv) (ExprEnv eenv') = ExprEnv $ eenv `M.union` eenv' +union' :: M.HashMap Name Expr -> ExprEnv -> ExprEnv +union' m (ExprEnv eenv) = ExprEnv (M.map ExprObj m `M.union` eenv) + +-- | Get the union of two `ExprEnv`. If names overlap, use the passed function to get an `EnvObj`. +unionWith :: (EnvObj -> EnvObj -> EnvObj) -> ExprEnv -> ExprEnv -> ExprEnv +unionWith f (ExprEnv m1) (ExprEnv m2) = + ExprEnv $ M.unionWith f m1 m2 + +unionWithM :: Monad m => (EnvObj -> EnvObj -> m EnvObj) -> ExprEnv -> ExprEnv -> m ExprEnv +unionWithM f (ExprEnv m1) (ExprEnv m2) = + return . ExprEnv =<< (Trav.sequence $ M.unionWith (\x y -> do + x' <- x + y' <- y + f x' y') + (M.map return m1) + (M.map return m2)) + +unionWithNameM :: Monad m => (Name -> EnvObj -> EnvObj -> m EnvObj) -> ExprEnv -> ExprEnv -> m ExprEnv +unionWithNameM f (ExprEnv m1) (ExprEnv m2) = + return . ExprEnv =<< (Trav.sequence $ M.unionWithKey (\n x y -> do + x' <- x + y' <- y + f n x' y') + (M.map return m1) + (M.map return m2)) + -- | Map a function over all `Expr` in the `ExprEnv`. -- Will not replace symbolic variables with non-symbolic values, --- but will rename symbolic values. +-- but will rename symbolic values if the passed function +-- returns a `Var`. map :: (Expr -> Expr) -> ExprEnv -> ExprEnv map f = mapWithKey (\_ -> f) --- | Maps a function with an arbitrary return type over all `Expr` in the `ExprEnv`, to get a `Data.Map`. -map' :: (Expr -> a) -> ExprEnv -> M.Map Name a +-- | Maps a function with an arbitrary return type over all `Expr` in the `ExprEnv`, to get a `Data.HashMap`. +map' :: (Expr -> a) -> ExprEnv -> M.HashMap Name a map' f = mapWithKey' (\_ -> f) +mapConc :: (Expr -> Expr) -> ExprEnv -> ExprEnv +mapConc f = mapConcWithKey (\_ -> f) + -- | Map a function over all `Expr` in the `ExprEnv`, with access to the `Name`. -- Will not replace symbolic variables with non-symbolic values, -- but will rename symbolic values. @@ -204,12 +286,31 @@ _ -> s f' _ n = n -mapWithKey' :: (Name -> Expr -> a) -> ExprEnv -> M.Map Name a +mapWithKey' :: (Name -> Expr -> a) -> ExprEnv -> M.HashMap Name a mapWithKey' f = M.mapWithKey f . toExprMap -mapKeys :: (Name -> Name) -> ExprEnv -> ExprEnv -mapKeys f = coerce . M.mapKeys f . unwrapExprEnv +mapConcWithKey :: (Name -> Expr -> Expr) -> ExprEnv -> ExprEnv +mapConcWithKey f (ExprEnv env) = ExprEnv $ M.mapWithKey f' env + where + f' :: Name -> EnvObj -> EnvObj + f' n (ExprObj e) = ExprObj $ f n e + f' _ s@(SymbObj _) = s + f' _ n = n +mapConcOrSym :: (ConcOrSym -> ConcOrSym) -> ExprEnv -> ExprEnv +mapConcOrSym f = mapConcOrSymWithKey (\_ -> f) + +mapConcOrSymWithKey :: (Name -> ConcOrSym -> ConcOrSym) -> ExprEnv -> ExprEnv +mapConcOrSymWithKey f (ExprEnv env) = ExprEnv $ M.mapWithKey f' env + where + g :: ConcOrSym -> EnvObj + g (Conc e) = ExprObj e + g (Sym i) = SymbObj i + f' :: Name -> EnvObj -> EnvObj + f' n (ExprObj e) = g $ f n $ Conc e + f' n (SymbObj i) = g $ f n $ Sym i + f' _ e = e + mapM :: Monad m => (Expr -> m Expr) -> ExprEnv -> m ExprEnv mapM f eenv = return . ExprEnv =<< Pre.mapM f' (unwrapExprEnv eenv) where @@ -246,7 +347,9 @@ -- | Returns a new `ExprEnv`, which contains only the symbolic values. filterToSymbolic :: ExprEnv -> ExprEnv -filterToSymbolic eenv = filterWithKey (\n _ -> isSymbolic n eenv) eenv +filterToSymbolic = ExprEnv . M.filter (\e -> case e of + SymbObj _ -> True + _ -> False) . unwrapExprEnv -- | Returns the names of all expressions with the given type in the expression environment funcsOfType :: Type -> ExprEnv -> [Name] @@ -255,8 +358,10 @@ keys :: ExprEnv -> [Name] keys = M.keys . unwrapExprEnv -symbolicKeys :: ExprEnv -> [Name] -symbolicKeys eenv = M.keys . unwrapExprEnv . filterWithKey (\n _ -> isSymbolic n eenv) $ eenv +symbolicIds :: ExprEnv -> [Id] +symbolicIds = mapMaybe (\e -> case e of + SymbObj i -> Just i + _ -> Nothing) . M.elems . unwrapExprEnv -- | Returns all `Expr`@s@ in the `ExprEnv` elems :: ExprEnv -> [Expr] @@ -266,6 +371,13 @@ higherOrderExprs :: ExprEnv -> [Type] higherOrderExprs = concatMap (higherOrderFuncs) . elems +-- | Converts all RedirObjs in ExprObjs. Useful for certain kinds of analysis +redirsToExprs :: ExprEnv -> ExprEnv +redirsToExprs eenv = coerce . M.map rToE . coerce $ eenv + where + rToE (RedirObj n) = ExprObj . Var . Id n . typeOf $ eenv ! n + rToE e = e + toList :: ExprEnv -> [(Name, EnvObj)] toList = M.toList . unwrapExprEnv @@ -279,7 +391,10 @@ fromExprList :: [(Name, Expr)] -> ExprEnv fromExprList = ExprEnv . M.fromList . L.map (\(n, e) -> (n, ExprObj e)) -toExprMap :: ExprEnv -> M.Map Name Expr +fromExprMap :: M.HashMap Name Expr -> ExprEnv +fromExprMap = ExprEnv . M.map ExprObj + +toExprMap :: ExprEnv -> M.HashMap Name Expr toExprMap env = M.mapWithKey (\k _ -> env ! k) $ unwrapExprEnv env getIdFromName :: ExprEnv -> Name -> Maybe Id @@ -322,23 +437,25 @@ modifyContainedASTs _ r = r instance Named ExprEnv where - names (ExprEnv eenv) = names (M.keys eenv) ++ names eenv + names (ExprEnv eenv) = names (M.keys eenv) <> names eenv rename old new = ExprEnv - . M.mapKeys (\k -> if k == old then new else k) + . M.fromList . rename old new + . M.toList . unwrapExprEnv renames hm = ExprEnv - . M.mapKeys (renames hm) + . M.fromList . renames hm + . M.toList . unwrapExprEnv instance Named EnvObj where names (ExprObj e) = names e - names (RedirObj r) = [r] + names (RedirObj r) = S.singleton r names (SymbObj s) = names s rename old new (ExprObj e) = ExprObj $ rename old new e diff --git a/src/G2/Language/Ids.hs b/src/G2/Language/Ids.hs --- a/src/G2/Language/Ids.hs +++ b/src/G2/Language/Ids.hs @@ -3,10 +3,13 @@ module G2.Language.Ids where +import qualified G2.Data.UnionFind as UF +import qualified G2.Data.UFMap as UFM import G2.Language.Syntax import G2.Language.AST import qualified Data.Map as M +import Data.Hashable import qualified Data.HashSet as HS class Ided a where @@ -29,7 +32,7 @@ go (Data d) = ids d go (Lam _ i _) = ids i go (Let b _) = concatMap (ids . fst) b - go (Case _ i a) = ids i ++ concatMap (ids . altMatch) a + go (Case _ i t a) = ids i ++ ids t ++ concatMap (ids . altMatch) a go (Type t) = ids t go _ = [] @@ -49,11 +52,6 @@ ids (DataAlt dc i) = ids dc ++ i ids _ = [] -instance Ided TyBinder where - {-# INLINE ids #-} - ids (AnonTyBndr t) = ids t - ids (NamedTyBndr i) = ids i - instance Ided Coercion where {-# INLINE ids #-} ids (t1 :~ t2) = ids t1 ++ ids t2 @@ -79,3 +77,9 @@ instance (Ided a, Ided b, Ided c) => Ided (a, b, c) where ids (a, b, c) = ids a ++ ids b ++ ids c + +instance (Eq k, Hashable k, Ided k) => Ided (UF.UnionFind k) where + ids = ids . UF.toList + +instance (Eq k, Hashable k, Ided k, Ided v) => Ided (UFM.UFMap k v) where + ids = ids . UFM.toList diff --git a/src/G2/Language/KnownValues.hs b/src/G2/Language/KnownValues.hs --- a/src/G2/Language/KnownValues.hs +++ b/src/G2/Language/KnownValues.hs @@ -1,14 +1,17 @@ {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} --- We define a datatype to hol the names of other data types we know should --- exist, and that we care about for some special reason --- (for example: the Bool type) --- Try to avoid imports from G2 other than G2.Internal.Language.Syntax here! + module G2.Language.KnownValues where +-- Try to avoid imports from G2 other than G2..Language.Syntax here! import G2.Language.Syntax import Data.Data (Data, Typeable) +import Data.Hashable +import GHC.Generics (Generic) +-- | A `KnownValues` tracks the names of data types we know should +-- exist, and that we care about for some special reason. data KnownValues = KnownValues { tyInt :: Name , dcInt :: Name @@ -29,15 +32,33 @@ , dcTrue :: Name , dcFalse :: Name + , tyRational :: Name + , tyList :: Name , dcCons :: Name , dcEmpty :: Name + , tyMaybe :: Name + , dcJust :: Name + , dcNothing :: Name + + , tyUnit :: Name + , dcUnit :: Name + + -- Typeclasses , eqTC :: Name , numTC :: Name , ordTC :: Name , integralTC :: Name + , realTC :: Name + , fractionalTC :: Name + -- Typeclass superclass extractors + , integralExtactReal :: Name + , realExtractNum :: Name + , realExtractOrd :: Name + , ordExtractEq :: Name + , eqFunc :: Name , neqFunc :: Name @@ -51,16 +72,32 @@ , fromIntegerFunc :: Name , toIntegerFunc :: Name + , toRatioFunc :: Name + , fromRationalFunc :: Name + , geFunc :: Name , gtFunc :: Name , ltFunc :: Name , leFunc :: Name - , structEqTC :: Name - , structEqFunc :: Name + , impliesFunc :: Name + , iffFunc :: Name , andFunc :: Name , orFunc :: Name + , notFunc :: Name + , errorFunc :: Name + , errorWithoutStackTraceFunc :: Name + , errorEmptyListFunc :: Name , patErrorFunc :: Name - } deriving (Show, Eq, Read, Typeable, Data) + } deriving (Show, Eq, Read, Typeable, Data, Generic) + +instance Hashable KnownValues + +-- | Checks if the `Name` corresponds to a function that is an error. +isErrorFunc :: KnownValues -> Name -> Bool +isErrorFunc kv n = n == errorFunc kv + || n == errorEmptyListFunc kv + || n == errorWithoutStackTraceFunc kv + || n == patErrorFunc kv diff --git a/src/G2/Language/Located.hs b/src/G2/Language/Located.hs --- a/src/G2/Language/Located.hs +++ b/src/G2/Language/Located.hs @@ -18,6 +18,7 @@ import Data.Hashable import qualified Data.Map as M import Data.Maybe +import Data.Foldable class Located l where loc :: l -> Maybe Loc @@ -102,7 +103,7 @@ -- | Constructs a map of Spans to Names, based on all Names in the ExprEnv spanLookup :: ExprEnv -> M.Map Span Name spanLookup = - M.fromList . mapMaybe (\n -> maybe Nothing (\s -> Just (s, n)) (spanning n)) . names + M.fromList . mapMaybe (\n -> maybe Nothing (\s -> Just (s, n)) (spanning n)) . toList . names -- | Constructs a map of Locs to Names, based on all Names in the ExprEnv locLookup :: ExprEnv -> M.Map Loc Name diff --git a/src/G2/Language/Monad/AST.hs b/src/G2/Language/Monad/AST.hs --- a/src/G2/Language/Monad/AST.hs +++ b/src/G2/Language/Monad/AST.hs @@ -44,9 +44,9 @@ modifyChildrenM f (Let bind e) = do bind' <- modifyContainedASTsM f bind return . Let bind' =<< f e - modifyChildrenM f (Case m b as) = do + modifyChildrenM f (Case m b t as) = do m' <- f m - return . Case m' b =<< modifyContainedASTsM f as + return . Case m' b t =<< modifyContainedASTsM f as modifyChildrenM f (Cast e c) = do e' <- f e return $ Cast e' c @@ -97,11 +97,12 @@ bnd' <- modifyContainedASTsM f bnd e' <- modifyContainedASTsM f e return $ Let bnd' e' - modifyContainedASTsM f (Case m i as) = do + modifyContainedASTsM f (Case m i t as) = do m' <- modifyContainedASTsM f m i' <- modifyContainedASTsM f i + t' <- f t as' <- modifyContainedASTsM f as - return $ Case m' i' as' + return $ Case m' i' t' as' modifyContainedASTsM f (Type t) = return . Type =<< f t modifyContainedASTsM f (Cast e c) = do e' <- modifyContainedASTsM f e @@ -134,17 +135,27 @@ y' <- modifyContainedASTsM f y return (x', y') +instance (ASTContainerM c t, ASTContainerM d t, ASTContainerM e t) => ASTContainerM (c, d, e) t where + modifyContainedASTsM f (x, y, z) = do + x' <- modifyContainedASTsM f x + y' <- modifyContainedASTsM f y + z' <- modifyContainedASTsM f z + return (x', y', z') + +instance ASTContainerM LamUse Expr where + {-# INLINE modifyContainedASTsM #-} + modifyContainedASTsM _ i = return i + +instance ASTContainerM LamUse Type where + {-# INLINE modifyContainedASTsM #-} + modifyContainedASTsM _ i = return i + instance ASTContainerM Id Expr where {-# INLINE modifyContainedASTsM #-} modifyContainedASTsM _ i = return i instance ASTContainerM Id Type where modifyContainedASTsM f (Id n t) = return . Id n =<< f t - -instance ASTContainerM TyBinder Type where - modifyContainedASTsM f (AnonTyBndr t) = return . AnonTyBndr =<< f t - modifyContainedASTsM f (NamedTyBndr i) = - return . NamedTyBndr =<< modifyContainedASTsM f i instance ASTContainerM DataCon Expr where {-# INLINE modifyContainedASTsM #-} diff --git a/src/G2/Language/Monad/Expr.hs b/src/G2/Language/Monad/Expr.hs --- a/src/G2/Language/Monad/Expr.hs +++ b/src/G2/Language/Monad/Expr.hs @@ -2,19 +2,21 @@ {-# LANGUAGE TupleSections #-} module G2.Language.Monad.Expr ( mkDCTrueM - , mkDCFalseM - , mkDCIntE - , mkDCIntegerE - , mkDCFloatE - , mkDCDoubleE - , mkTrueE - , mkFalseE - , mkConsE - , mkEmptyE - , modifyAppTopE - , modifyLamTopE - , insertInLamsE - , etaExpandToE ) where + , mkDCFalseM + , mkDCIntE + , mkDCIntegerE + , mkDCFloatE + , mkDCDoubleE + , mkTrueE + , mkFalseE + , mkConsE + , mkEmptyE + , mkUnitE + , modifyAppTopE + , modifyLamTopE + , modifyAppRHSE + , insertInLamsE + , etaExpandToE ) where import G2.Language.Expr import G2.Language.Syntax @@ -63,6 +65,9 @@ mkEmptyE :: ExState s m => m Expr mkEmptyE = appKVTEnv mkEmpty + +mkUnitE :: ExState s m => m Expr +mkUnitE = appKVTEnv mkUnit modifyAppTopE :: (Monad m, ASTContainerM c Expr) => (Expr -> m Expr) -> c -> m c modifyAppTopE f = modifyContainedASTsM (modifyAppTopE' f) diff --git a/src/G2/Language/Monad/ExprEnv.hs b/src/G2/Language/Monad/ExprEnv.hs --- a/src/G2/Language/Monad/ExprEnv.hs +++ b/src/G2/Language/Monad/ExprEnv.hs @@ -1,9 +1,10 @@ module G2.Language.Monad.ExprEnv ( memberE - , lookupE - , insertE - , mapE - , mapME - , mapWithKeyME ) where + , lookupE + , insertE + , insertSymbolicE + , mapE + , mapME + , mapWithKeyME ) where import G2.Language @@ -15,34 +16,40 @@ , map , null) -liftEE :: ExState s m => (ExprEnv -> a) -> m a +liftEE :: ExprEnvM s m => (ExprEnv -> a) -> m a liftEE f = return . f =<< exprEnv -memberE :: ExState s m => Name -> m Bool +memberE :: ExprEnvM s m => Name -> m Bool memberE n = liftEE (E.member n) -lookupE :: ExState s m => Name -> m (Maybe Expr) +lookupE :: ExprEnvM s m => Name -> m (Maybe Expr) lookupE n = liftEE (E.lookup n) -insertE :: ExState s m => Name -> Expr -> m () +insertE :: ExprEnvM s m => Name -> Expr -> m () insertE n e = do eenv <- exprEnv let eenv' = E.insert n e eenv putExprEnv eenv' -mapE :: ExState s m => (Expr -> Expr) -> m () +insertSymbolicE :: ExprEnvM s m => Id -> m () +insertSymbolicE i = do + eenv <- exprEnv + let eenv' = E.insertSymbolic i eenv + putExprEnv eenv' + +mapE :: ExprEnvM s m => (Expr -> Expr) -> m () mapE f = do eenv <- exprEnv let eenv' = E.map f eenv putExprEnv eenv' -mapME :: ExState s m => (Expr -> m Expr) -> m () +mapME :: ExprEnvM s m => (Expr -> m Expr) -> m () mapME f = do eenv <- exprEnv eenv' <- E.mapM f eenv putExprEnv eenv' -mapWithKeyME :: ExState s m => (Name -> Expr -> m Expr) -> m () +mapWithKeyME :: ExprEnvM s m => (Name -> Expr -> m Expr) -> m () mapWithKeyME f = do eenv <- exprEnv eenv' <- E.mapWithKeyM f eenv diff --git a/src/G2/Language/Monad/Naming.hs b/src/G2/Language/Monad/Naming.hs --- a/src/G2/Language/Monad/Naming.hs +++ b/src/G2/Language/Monad/Naming.hs @@ -17,38 +17,38 @@ import qualified Data.Text as T -doRenameN :: (ExState s m, Named a) => Name -> a -> m a +doRenameN :: (NamingM s m, Named a) => Name -> a -> m a doRenameN n a = withNG $ \ng -> doRename n ng a -doRenamesN :: (ExState s m, Named a) => [Name] -> a -> m a +doRenamesN :: (NamingM s m, Named a) => [Name] -> a -> m a doRenamesN ns a = withNG $ \ng -> doRenames ns ng a -renameAllN :: (ExState s m, Named a) => a -> m a +renameAllN :: (NamingM s m, Named a) => a -> m a renameAllN a = withNG (renameAll a) -freshSeededStringN :: ExState s m => T.Text -> m Name +freshSeededStringN :: NamingM s m => T.Text -> m Name freshSeededStringN t = withNG (freshSeededString t) -freshSeededStringsN :: ExState s m => [T.Text] -> m [Name] +freshSeededStringsN :: NamingM s m => [T.Text] -> m [Name] freshSeededStringsN t = withNG (freshSeededStrings t) -freshSeededNameN :: ExState s m => Name -> m Name +freshSeededNameN :: NamingM s m => Name -> m Name freshSeededNameN n = withNG (freshSeededName n) -freshSeededNamesN :: ExState s m => [Name] -> m [Name] +freshSeededNamesN :: NamingM s m => [Name] -> m [Name] freshSeededNamesN ns = withNG (freshSeededNames ns) -freshNameN :: ExState s m => m Name +freshNameN :: NamingM s m => m Name freshNameN = withNG (freshName) -freshNamesN :: ExState s m => Int -> m [Name] +freshNamesN :: NamingM s m => Int -> m [Name] freshNamesN i = withNG (freshNames i) -freshIdN :: ExState s m => Type -> m Id +freshIdN :: NamingM s m => Type -> m Id freshIdN t = withNG (freshId t) -freshSeededIdN :: (Named n, ExState s m) => n -> Type -> m Id +freshSeededIdN :: (Named n, NamingM s m) => n -> Type -> m Id freshSeededIdN n t = withNG (freshSeededId n t) -freshIdsN :: ExState s m => [Type] -> m [Id] +freshIdsN :: NamingM s m => [Type] -> m [Id] freshIdsN ts = withNG (freshIds ts) diff --git a/src/G2/Language/Monad/Primitives.hs b/src/G2/Language/Monad/Primitives.hs --- a/src/G2/Language/Monad/Primitives.hs +++ b/src/G2/Language/Monad/Primitives.hs @@ -22,71 +22,78 @@ , mkEqPrimDoubleE , mkEqPrimCharE ) where +import G2.Language.KnownValues import G2.Language.Primitives import G2.Language.Syntax -import G2.Language.Support +import G2.Language.Typing +import G2.Language.Monad.ExprEnv import G2.Language.Monad.Support -appExpr :: ExState s m => (ExprEnv -> Expr) -> m Expr -appExpr f = return . f =<< exprEnv - mkGeE :: ExState s m => m Expr -mkGeE = appExpr mkGe +mkGeE = appKVEEnv geFunc mkGtE :: ExState s m => m Expr -mkGtE = appExpr mkGt +mkGtE = appKVEEnv gtFunc mkEqE :: ExState s m => m Expr -mkEqE = appExpr mkEq +mkEqE = appKVEEnv eqFunc mkNeqE :: ExState s m => m Expr -mkNeqE = appExpr mkNeq +mkNeqE = appKVEEnv neqFunc mkLtE :: ExState s m => m Expr -mkLtE = appExpr mkLt +mkLtE = appKVEEnv ltFunc mkLeE :: ExState s m => m Expr -mkLeE = appExpr mkLe +mkLeE = appKVEEnv leFunc mkAndE :: ExState s m => m Expr -mkAndE = appExpr mkAnd +mkAndE = appKVEEnv andFunc mkOrE :: ExState s m => m Expr -mkOrE = appExpr mkOr +mkOrE = appKVEEnv orFunc mkNotE :: ExState s m => m Expr -mkNotE = appExpr mkNot +mkNotE = appKVEEnv notFunc mkPlusE :: ExState s m => m Expr -mkPlusE = appExpr mkPlus +mkPlusE = appKVEEnv plusFunc mkMinusE :: ExState s m => m Expr -mkMinusE = appExpr mkMinus +mkMinusE = appKVEEnv minusFunc mkMultE :: ExState s m => m Expr -mkMultE = appExpr mkMult +mkMultE = appKVEEnv timesFunc mkDivE :: ExState s m => m Expr -mkDivE = appExpr mkDiv +mkDivE = appKVEEnv divFunc mkModE :: ExState s m => m Expr -mkModE = appExpr mkMod +mkModE = appKVEEnv modFunc mkNegateE :: ExState s m => m Expr -mkNegateE = appExpr mkNegate +mkNegateE = appKVEEnv negateFunc mkImpliesE :: ExState s m => m Expr -mkImpliesE = appExpr mkImplies +mkImpliesE = appKVEEnv impliesFunc mkIffE :: ExState s m => m Expr -mkIffE = appExpr mkIff +mkIffE = appKVEEnv iffFunc mkFromIntegerE :: ExState s m => m Expr -mkFromIntegerE = appExpr mkFromInteger +mkFromIntegerE = appKVEEnv fromIntegerFunc mkToIntegerE :: ExState s m => m Expr -mkToIntegerE = appExpr mkToInteger +mkToIntegerE = appKVEEnv toIntegerFunc + +appKVEEnv :: ExState s m => (KnownValues -> Name) -> m Expr +appKVEEnv f = do + n <- return . f =<< knownValues + e <- lookupE n + case e of + Just e' -> return . Var $ Id n (typeOf e') + Nothing -> error "appKVEEnv: not found" appKV :: ExState s m => (KnownValues -> Expr) -> m Expr appKV f = return . f =<< knownValues diff --git a/src/G2/Language/Monad/Support.hs b/src/G2/Language/Monad/Support.hs --- a/src/G2/Language/Monad/Support.hs +++ b/src/G2/Language/Monad/Support.hs @@ -2,43 +2,84 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} -module G2.Language.Monad.Support ( StateM +module G2.Language.Monad.Support ( StateT + , StateM + , StateNGT + , StateNG + , NameGenT + , NameGenM + , NamingM (..) + , ExprEnvM (..) , ExState (..) , FullState (..) , runStateM + , execStateM + , runNamingM + , runNamingT + , runExprEnvM + , runStateMInNamingM + , runStateNG + , execStateNG , readRecord , withNG - , mapCurrExpr ) where + , mapCurrExpr + , insertPC + , insertPCStateNG + , mapMAccumB ) where +import Control.Monad.Identity import qualified Control.Monad.State.Lazy as SM import G2.Language.Naming +import qualified G2.Language.PathConds as PC import G2.Language.Syntax import G2.Language.Support import G2.Language.TypeClasses -- | A wrapper for `State`, allowing it to be used as a monadic context. -newtype StateM t a = StateM (SM.State (State t, Bindings) a) deriving (Applicative, Functor, Monad) +type StateT t m a = SM.StateT (State t, Bindings) m a +type StateM t a = StateT t Identity a -instance SM.MonadState (State t, Bindings) (StateM t) where - state f = StateM (SM.state f) +type StateNGT t m a = SM.StateT (State t, NameGen) m a +type StateNG t a = StateNGT t Identity a +-- | A wrapper for `NameGen`, allowing it to be used as a monadic context. +type NameGenT m a = SM.StateT NameGen m a +type NameGenM a = NameGenT Identity a + +-- | A wrapper for `ExprEnv`, allowing it to be used as a monadic context. +type EET m a = SM.StateT ExprEnv m a +type EEM a = EET Identity a + +-- instance SM.MonadState (State t, Bindings) (SM.State (State t, Bindings)) where +-- state f = StateM (SM.state f) + +-- instance SM.MonadState (State t, NameGen) (SM.State (State t, NameGen)) where +-- state f = StateNG (SM.state f) + +-- instance SM.MonadState NameGen (SM.State NameGen) where +-- state f = NameGenM (SM.state f) + -- We split the State Monad into two pieces, so we can use it in the --- initialization stage of G2. In this stage, we do not have an entire State. --- See G2.Initialization.Types +-- initialization stage of G2 (in this stage, we do not have an entire State. +-- See G2.Initialization.Types), or so that we can just use it with smaller +-- pieces of a state. --- | Allows access to certain basic components of a state. -class SM.MonadState s m => ExState s m | m -> s where +class Monad m => NamingM s m | m -> s where + nameGen :: m NameGen + putNameGen :: NameGen -> m () + +class Monad m => ExprEnvM s m | m -> s where exprEnv :: m ExprEnv putExprEnv :: ExprEnv -> m () +-- | Allows access to certain basic components of a state. +class (ExprEnvM s m, NamingM s m) => ExState s m | m -> s where typeEnv :: m TypeEnv putTypeEnv :: TypeEnv -> m () - nameGen :: m NameGen - putNameGen :: NameGen -> m () - knownValues :: m KnownValues putKnownValues :: KnownValues -> m () @@ -51,35 +92,91 @@ currExpr :: m CurrExpr putCurrExpr :: CurrExpr -> m () + pathConds :: m PathConds + putPathConds :: PathConds -> m () + inputNames :: m [Name] fixedInputs :: m [Expr] -instance ExState (State t, Bindings) (StateM t) where +instance Monad m => NamingM NameGen (SM.StateT NameGen m) where + nameGen = SM.get + putNameGen = SM.put + +instance Monad m => NamingM (State t, Bindings) (SM.StateT (State t, Bindings) m) where + nameGen = readRecord (\(_, b) -> name_gen b) + putNameGen = rep_name_genM + +instance Monad m => NamingM (State t, NameGen) (SM.StateT (State t, NameGen) m) where + nameGen = readRecord (\(_, ng) -> ng) + putNameGen = rep_name_genNG + +instance ExprEnvM (State t, Bindings) (SM.State (State t, Bindings)) where exprEnv = readRecord (\(s, _) -> expr_env s) putExprEnv = rep_expr_envM +instance ExprEnvM (State t, NameGen) (SM.State (State t, NameGen)) where + exprEnv = readRecord (\(s, _) -> expr_env s) + putExprEnv = rep_expr_envNG + +instance ExState (State t, Bindings) (SM.State (State t, Bindings)) where typeEnv = readRecord (\(s, _) -> type_env s) putTypeEnv = rep_type_envM - nameGen = readRecord (\(_, b) -> name_gen b) - putNameGen = rep_name_genM - knownValues = readRecord (\(s, _) -> known_values s) putKnownValues = rep_known_valuesM typeClasses = readRecord (\(s, _) -> type_classes s) putTypeClasses = rep_type_classesM -instance FullState (State t, Bindings) (StateM t) where +instance ExState (State t, NameGen) (SM.State (State t, NameGen)) where + typeEnv = readRecord (\(s, _) -> type_env s) + putTypeEnv = rep_type_envNG + + knownValues = readRecord (\(s, _) -> known_values s) + putKnownValues = rep_known_valuesNG + + typeClasses = readRecord (\(s, _) -> type_classes s) + putTypeClasses = rep_type_classesNG + +instance FullState (State t, Bindings) (SM.State (State t, Bindings)) where currExpr = readRecord (\(s, _) -> curr_expr s) putCurrExpr = rep_curr_exprM + pathConds = readRecord (\(s, _) -> path_conds s) + putPathConds = rep_path_condsM + inputNames = readRecord (\(_, b) -> input_names b) fixedInputs = readRecord (\(_,b) -> fixed_inputs b) + runStateM :: StateM t a -> State t -> Bindings -> (a, (State t, Bindings)) -runStateM (StateM s) s' b = SM.runState s (s', b) +runStateM s s' b = SM.runState s (s', b) +execStateM :: StateM t a -> State t -> Bindings -> (State t, Bindings) +execStateM s = (\lh_s b -> snd (runStateM s lh_s b)) + +runStateNG :: StateNG t a -> State t -> NameGen -> (a, (State t, NameGen)) +runStateNG s s' ng = SM.runState s (s', ng) + +execStateNG :: StateNG t a -> State t -> NameGen -> (State t, NameGen) +execStateNG s = (\lh_s ng -> snd (runStateNG s lh_s ng)) + +runNamingT :: NameGenT m a -> NameGen -> m (a, NameGen) +runNamingT s = SM.runStateT s + +runNamingM :: NameGenM a -> NameGen -> (a, NameGen) +runNamingM s = SM.runState s + +runExprEnvM :: EEM a -> ExprEnv -> (a, ExprEnv) +runExprEnvM s = SM.runState s + +runStateMInNamingM :: (Monad m, NamingM s m) => StateNG t a -> State t -> m (a, State t) +runStateMInNamingM m s = do + ng <- nameGen + let (a, (s', ng')) = runStateNG m s ng + putNameGen ng' + return (a, s') + readRecord :: SM.MonadState s m => (s -> r) -> m r readRecord f = return . f =<< SM.get @@ -88,33 +185,59 @@ (s,b) <- SM.get SM.put $ (s {expr_env = eenv}, b) +rep_expr_envNG :: ExprEnv -> StateNG t () +rep_expr_envNG eenv = do + (s,b) <- SM.get + SM.put $ (s {expr_env = eenv}, b) + rep_type_envM :: TypeEnv -> StateM t () rep_type_envM tenv = do (s,b) <- SM.get SM.put $ (s {type_env = tenv}, b) -withNG :: ExState s m => (NameGen -> (a, NameGen)) -> m a +rep_type_envNG :: TypeEnv -> StateNG t () +rep_type_envNG tenv = do + (s,b) <- SM.get + SM.put $ (s {type_env = tenv}, b) + +withNG :: NamingM s m => (NameGen -> (a, NameGen)) -> m a withNG f = do ng <- nameGen let (a, ng') = f ng putNameGen ng' return a -rep_name_genM :: NameGen -> StateM t () +rep_name_genM :: Monad m => NameGen -> StateT t m () rep_name_genM ng = do (s,b) <- SM.get SM.put $ (s, b {name_gen = ng}) +rep_name_genNG :: Monad m => NameGen -> StateNGT t m () +rep_name_genNG ng = do + (s, _) <- SM.get + SM.put $ (s, ng) + rep_known_valuesM :: KnownValues -> StateM t () rep_known_valuesM kv = do (s, b) <- SM.get SM.put $ (s {known_values = kv}, b) +rep_known_valuesNG :: KnownValues -> StateNG t () +rep_known_valuesNG kv = do + (s, b) <- SM.get + SM.put $ (s {known_values = kv}, b) + + rep_type_classesM :: TypeClasses -> StateM t () rep_type_classesM tc = do (s, b) <- SM.get SM.put $ (s {type_classes = tc}, b) +rep_type_classesNG :: TypeClasses -> StateNG t () +rep_type_classesNG tc = do + (s, b) <- SM.get + SM.put $ (s {type_classes = tc}, b) + rep_curr_exprM :: CurrExpr -> StateM t () rep_curr_exprM ce = do (s, b) <- SM.get @@ -125,3 +248,26 @@ (CurrExpr er e) <- currExpr e' <- f e putCurrExpr (CurrExpr er e') + +rep_path_condsM :: PathConds -> StateM t () +rep_path_condsM pc = do + (s, b) <- SM.get + SM.put $ (s {path_conds = pc}, b) + +insertPC :: FullState s m => PathCond -> m () +insertPC pc = do + pcs <- pathConds + putPathConds $ PC.insert pc pcs + +insertPCStateNG :: PathCond -> StateNG t () +insertPCStateNG pc = do + (s@(State { path_conds = pcs }), ng) <- SM.get + SM.put (s { path_conds = PC.insert pc pcs}, ng) + +mapMAccumB :: Monad m => (a -> b -> m (a, c)) -> a -> [b] -> m (a, [c]) +mapMAccumB _ a [] = do + return (a, []) +mapMAccumB f a (x:xs) = do + (a', res) <- f a x + (a'', res2) <- mapMAccumB f a' xs + return $ (a'', res:res2) diff --git a/src/G2/Language/Monad/TypeClasses.hs b/src/G2/Language/Monad/TypeClasses.hs --- a/src/G2/Language/Monad/TypeClasses.hs +++ b/src/G2/Language/Monad/TypeClasses.hs @@ -8,14 +8,14 @@ import G2.Language.TypeClasses import G2.Language.Monad.Support -import qualified Data.Map as M +import qualified Data.HashMap.Lazy as HM lookupTCDictTC :: FullState s m => Name -> Type -> m (Maybe Id) lookupTCDictTC n t = do tc <- typeClasses return $ lookupTCDict tc n t -typeClassInstTC :: FullState s m => M.Map Name Id -> Name -> Type -> m (Maybe Expr) +typeClassInstTC :: FullState s m => HM.HashMap Name Id -> Name -> Type -> m (Maybe Expr) typeClassInstTC m n t = do tc <- typeClasses return $ typeClassInst tc m n t diff --git a/src/G2/Language/Monad/TypeEnv.hs b/src/G2/Language/Monad/TypeEnv.hs --- a/src/G2/Language/Monad/TypeEnv.hs +++ b/src/G2/Language/Monad/TypeEnv.hs @@ -1,11 +1,11 @@ module G2.Language.Monad.TypeEnv ( lookupT - , insertT ) where + , insertT ) where import G2.Language import G2.Language.Monad.Support -import qualified Data.Map as M +import qualified Data.HashMap.Lazy as HM import Prelude hiding( filter , lookup @@ -16,10 +16,10 @@ liftTE f = return . f =<< typeEnv lookupT :: ExState s m => Name -> m (Maybe AlgDataTy) -lookupT n = liftTE (M.lookup n) +lookupT n = liftTE (HM.lookup n) insertT :: ExState s m => Name -> AlgDataTy -> m () insertT n t = do tenv <- typeEnv - let tenv' = M.insert n t tenv + let tenv' = HM.insert n t tenv putTypeEnv tenv' diff --git a/src/G2/Language/Monad/Typing.hs b/src/G2/Language/Monad/Typing.hs --- a/src/G2/Language/Monad/Typing.hs +++ b/src/G2/Language/Monad/Typing.hs @@ -2,7 +2,9 @@ , tyIntegerT , tyDoubleT , tyFloatT - , tyBoolT ) where + , tyBoolT + , tyRationalT + , tyUnitT ) where import G2.Language.Syntax import G2.Language.Support @@ -30,3 +32,9 @@ tyBoolT :: ExState s m => m Type tyBoolT = appKV tyBool + +tyRationalT :: ExState s m => m Type +tyRationalT = appKV tyRational + +tyUnitT :: ExState s m => m Type +tyUnitT = appKV tyUnit diff --git a/src/G2/Language/Naming.hs b/src/G2/Language/Naming.hs --- a/src/G2/Language/Naming.hs +++ b/src/G2/Language/Naming.hs @@ -6,14 +6,21 @@ module G2.Language.Naming ( nameOcc , nameModule + , nameUnique + , nameTuple , nameLoc , NameGen - , Named (names, rename, renames) + , Named (..) + , namesList , doRename , doRenames , renameAll , nameToStr + , nameToBuilder , strToName + , maybe_StrToName + , builderToName + , mkNameGen , varIds , varNames @@ -21,6 +28,7 @@ , typeNames , renameExprs + , renamesExprs , renameExpr , renameVars @@ -37,71 +45,107 @@ , freshIds , freshVar - , childrenNames - , mapNG ) where +import qualified G2.Data.UFMap as UF import G2.Language.AST import G2.Language.KnownValues import G2.Language.Syntax import G2.Language.TypeEnv import Data.Data (Data, Typeable) +import Data.Foldable import Data.Hashable import qualified Data.HashMap.Lazy as HM import qualified Data.HashSet as HS import Data.List import Data.List.Utils import qualified Data.Map as M +import Data.Monoid ((<>)) +import qualified Data.Sequence as S import qualified Data.Text as T import Data.Tuple +import qualified Text.Builder as TB +-- | Extract the "occurence" from a `Name`. +-- +-- >>> nameOcc (Name "x" (Just "mod") 100 Nothing) +-- "x" nameOcc :: Name -> T.Text nameOcc (Name occ _ _ _) = occ +-- | Extract the module from a `Name`. +-- +-- >>> nameModule (Name "x" (Just "mod") 100 Nothing) +-- Just "mod" nameModule :: Name -> Maybe T.Text nameModule (Name _ mb _ _) = mb +-- | Extract the "unique" from a `Name`. +-- +-- >>> nameUnique (Name "x" (Just "mod") 100 Nothing) +-- 100 +nameUnique :: Name -> Int +nameUnique (Name _ _ i _) = i + +-- | Get a tuple with the "occurence" and module of a `Name`. +-- +-- >>> nameTuple (Name "x" (Just "mod") 100 Nothing) +-- ("x", Just "mod") +nameTuple :: Name -> (T.Text, Maybe T.Text) +nameTuple n = (nameOcc n, nameModule n) + +-- | Get the location of a `Name`. nameLoc :: Name -> Maybe Span nameLoc (Name _ _ _ s) = s -- | Allows the creation of fresh `Name`s. -data NameGen = NameGen { max_uniq :: (HM.HashMap (T.Text, Maybe T.Text) Int) - , dc_children :: (HM.HashMap Name [Name]) } +newtype NameGen = NameGen (HM.HashMap (T.Text, Maybe T.Text) Int) deriving (Show, Eq, Read, Typeable, Data) -- nameToStr relies on NameCleaner eliminating all '_', to preserve uniqueness --- | Converts a name to a string, which is useful to interact with solvers. +-- | Converts a `Name` to a string, which is useful to interact with solvers. nameToStr :: Name -> String nameToStr (Name n (Just m) i _) = T.unpack n ++ "_m_" ++ T.unpack m ++ "_" ++ show i nameToStr (Name n Nothing i _) = T.unpack n ++ "_n__" ++ show i --- | Converts a string generated by nameToStr to a name. +-- | Similar to `nameToStr`, but converts a `Name` to a `TB.Builder`. +nameToBuilder :: Name -> TB.Builder +nameToBuilder (Name n (Just m) i _) = mconcat [TB.text n, TB.text "_m_", TB.text m, TB.text "_", TB.string $ show i] +nameToBuilder (Name n Nothing i _) = mconcat [TB.text n, TB.text "_n__", TB.string $ show i] + +-- | Converts a `String` generated by `nameToStr` to a `Name`. -- Loses location information strToName :: String -> Name strToName str = + case maybe_StrToName str of + Just n -> n + Nothing -> error "strToName: Bad conversion" + +maybe_StrToName :: String -> Maybe Name +maybe_StrToName str + | (n, _:q:_:mi) <- breakList (\s -> isPrefixOf "_m_" s || isPrefixOf "_n_" s) str + , (m, _:i) <- break ((==) '_') mi = let - (n, _:q:_:mi) = breakList (\s -> isPrefixOf "_m_" s || isPrefixOf "_n_" s) str - (m, _:i) = break ((==) '_') mi m' = if q == 'm' then Just m else Nothing in - Name (T.pack n) (fmap T.pack m') (read i :: Int) Nothing + Just $ Name (T.pack n) (fmap T.pack m') (read i :: Int) Nothing + | otherwise = Nothing +-- | Converts a `TB.Builder` generated by `nameToBuilder` to a `Name`. +-- Loses location information +builderToName :: TB.Builder -> Name +builderToName txt = strToName $ show txt + -- | Initializes a `NameGen`. The returned `NameGen` is guarenteed to not give any `Name` -- in the given `Named` type. mkNameGen :: Named n => n -> NameGen mkNameGen nmd = let - allNames = names nmd + allNames = toList $ names nmd in - NameGen { - max_uniq = HM.fromListWith max $ map (\(Name n m i _) -> ((n, m), i + 1)) allNames - -- (foldr (\(Name n m i _) hm -> HM.insertWith max (n, m) (i + 1) hm) - -- HM.empty allNames - -- ) - , dc_children = HM.empty - } + NameGen (HM.fromListWith max $ map (\(Name n m i _) -> ((n, m), i + 1)) allNames) -- | Returns all @Var@ Ids in an ASTContainer varIds :: (ASTContainer m Expr) => m -> [Id] @@ -123,7 +167,7 @@ exprTopNames (Data dc) = dataConName dc exprTopNames (Lam _ b _) = [idName b] exprTopNames (Let kvs _) = map (idName . fst) kvs -exprTopNames (Case _ cvar as) = idName cvar : +exprTopNames (Case _ cvar _ as) = idName cvar : concatMap (\(Alt am _) -> altMatchNames am) as exprTopNames (Assume (Just is) _ _) = [funcName is] @@ -143,7 +187,7 @@ typeTopNames :: Type -> [Name] typeTopNames (TyVar i) = [idName i] typeTopNames (TyCon n _) = [n] -typeTopNames (TyForAll (NamedTyBndr v) _) = [idName v] +typeTopNames (TyForAll v _) = [idName v] typeTopNames _ = [] doRename :: Named a => Name -> NameGen -> a -> (a, NameGen) @@ -161,13 +205,16 @@ renameAll :: (Named a) => a -> NameGen -> (a, NameGen) renameAll x ng = let - old = nub $ names x + old = nub . toList $ names x in doRenames old ng x +namesList :: Named a => a -> [Name] +namesList = toList . names + -- | Types that contain `Name`@s@ class Named a where - names :: a -> [Name] + names :: a -> S.Seq Name rename :: Name -> Name -> a -> a renames :: HM.HashMap Name Name -> a -> a @@ -175,7 +222,7 @@ instance Named Name where {-# INLINE names #-} - names n = [n] + names n = S.singleton n {-# INLINE rename #-} rename old (Name nn nm ni _) n@(Name _ _ _ l) = if old == n then Name nn nm ni l else n {-# INLINE renames #-} @@ -185,7 +232,7 @@ instance Named Id where {-# INLINE names #-} - names (Id n t) = n:names t + names (Id n t) = n S.<| names t {-# INLINE rename #-} rename old new (Id n t) = Id (rename old new n) (rename old new t) {-# INLINE renames #-} @@ -194,21 +241,21 @@ instance Named Expr where names = eval go where - go :: Expr -> [Name] + go :: Expr -> S.Seq Name go (Var i) = names i go (Prim _ t) = names t go (Data d) = names d go (Lam _ i _) = names i - go (Let b _) = concatMap (names . fst) b - go (Case _ i a) = names i ++ concatMap (names . altMatch) a + go (Let b _) = foldr (<>) S.empty $ map (names . fst) b + go (Case _ i t a) = names i <> names t <> (foldr (<>) S.empty $ map (names . altMatch) a) go (Type t) = names t go (Cast _ c) = names c go (Coercion c) = names c go (Tick t _) = names t - go (SymGen t) = names t + go (SymGen _ t) = names t go (Assume is _ _) = names is go (Assert is _ _) = names is - go _ = [] + go _ = S.empty rename old new = modify go where @@ -219,13 +266,13 @@ go (Let b e) = let b' = map (\(n, e') -> (rename old new n, e')) b in Let b' e - go (Case e i a) = - Case e (rename old new i) (map goAlt a) + go (Case e i t a) = + Case e (rename old new i) (rename old new t) (map goAlt a) go (Type t) = Type (rename old new t) go (Cast e c) = Cast e (rename old new c) go (Coercion c) = Coercion (rename old new c) go (Tick t e) = Tick (rename old new t) e - go (SymGen t) = SymGen (rename old new t) + go (SymGen sl t) = SymGen sl (rename old new t) go (Assume is e e') = Assume (rename old new is) e e' go (Assert is e e') = Assert (rename old new is) e e' go e = e @@ -242,12 +289,12 @@ go (Let b e) = let b' = map (\(n, e') -> (renames hm n, e')) b in Let b' e - go (Case e i a) = Case e (renames hm i) (map goAlt a) + go (Case e i t a) = Case e (renames hm i) (renames hm t) (map goAlt a) go (Type t) = Type (renames hm t) go (Cast e c) = Cast e (renames hm c) go (Coercion c) = Coercion (renames hm c) go (Tick t e) = Tick (renames hm t) e - go (SymGen t) = SymGen (renames hm t) + go (SymGen sl t) = SymGen sl (renames hm t) go (Assume is e e') = Assume (renames hm is) e e' go (Assert is e e') = Assert (renames hm is) e e' go e = e @@ -256,7 +303,7 @@ goAlt (Alt am e) = Alt (renames hm am) e renameExprs :: ASTContainer m Expr => [(Name, Name)] -> m -> m -renameExprs n a = foldr (\(old, new) -> renameExpr old new) a n +renameExprs n = renamesExprs (HM.fromList n) -- | Rename only the names in an `Expr` that are the `Name` of an `Id`/`Let`/`Data`/`Case` Binding. -- Does not change Types. @@ -268,7 +315,7 @@ renameExpr' old new (Data d) = Data (renameExprDataCon old new d) renameExpr' old new (Lam u i e) = Lam u (renameExprId old new i) e renameExpr' old new (Let b e) = Let (map (\(b', e') -> (renameExprId old new b', e')) b) e -renameExpr' old new (Case e i a) = Case e (renameExprId old new i) $ map (renameExprAlt old new) a +renameExpr' old new (Case e i t a) = Case e (renameExprId old new i) t $ map (renameExprAlt old new) a renameExpr' old new (Assume is e e') = Assume (fmap (rename old new) is) e e' renameExpr' old new (Assert is e e') = Assert (fmap (rename old new) is) e e' renameExpr' _ _ e = e @@ -281,7 +328,7 @@ renameVars' old new (Var i) = Var (renameExprId old new i) renameVars' old new (Lam u i e) = Lam u (renameExprId old new i) e renameVars' old new (Let b e) = Let (map (\(b', e') -> (renameExprId old new b', e')) b) e -renameVars' old new (Case e i a) = Case e (renameExprId old new i) $ map (renameExprAltIds old new) a +renameVars' old new (Case e i t a) = Case e (renameExprId old new i) t $ map (renameExprAltIds old new) a renameVars' old new (Assert is e e') = Assert (fmap (rename old new) is) e e' renameVars' _ _ e = e @@ -309,21 +356,48 @@ Alt (DataAlt dc is') e renameExprAltIds _ _ a = a +renamesExprs :: ASTContainer m Expr => HM.HashMap Name Name -> m -> m +renamesExprs hm = modifyASTs (renamesExprs' hm) +renamesExprs' :: HM.HashMap Name Name -> Expr -> Expr +renamesExprs' hm (Var i) = Var (renamesExprId hm i) +renamesExprs' hm (Data d) = Data (renamesExprDataCon hm d) +renamesExprs' hm (Lam u i e) = Lam u (renamesExprId hm i) e +renamesExprs' hm (Let b e) = Let (map (\(b', e') -> (renamesExprId hm b', e')) b) e +renamesExprs' hm (Case e i t a) = Case e (renamesExprId hm i) t $ map (renamesExprAlt hm) a +renamesExprs' hm (Assume is e e') = Assume (fmap (renames hm) is) e e' +renamesExprs' hm (Assert is e e') = Assert (fmap (renames hm) is) e e' +renamesExprs' _ e = e + +renamesExprId :: HM.HashMap Name Name -> Id -> Id +renamesExprId hm (Id n t) = Id (renames hm n) t + +renamesExprDataCon :: HM.HashMap Name Name -> DataCon -> DataCon +renamesExprDataCon hm (DataCon n t) = DataCon (renames hm n) t + +renamesExprAlt :: HM.HashMap Name Name -> Alt -> Alt +renamesExprAlt hm (Alt (DataAlt dc is) e) = + let + dc' = renamesExprDataCon hm dc + is' = map (renamesExprId hm) is + in + Alt (DataAlt dc' is') e +renamesExprAlt _ a = a + instance Named Type where names = eval go where go (TyVar i) = idNamesInType i - go (TyCon n _) = [n] - go (TyForAll b _) = tyBinderNamesInType b - go _ = [] + go (TyCon n _) = S.singleton n + go (TyForAll b _) = idNamesInType b + go _ = S.empty rename old new = modify go where go :: Type -> Type go (TyVar i) = TyVar (renameIdInType old new i) go (TyCon n ts) = TyCon (rename old new n) ts - go (TyForAll tb t) = TyForAll (renameTyBinderInType old new tb) t + go (TyForAll tb t) = TyForAll (renameIdInType old new tb) t go t = t renames hm = modify go @@ -331,35 +405,23 @@ go :: Type -> Type go (TyVar i) = TyVar (renamesIdInType hm i) go (TyCon n ts) = TyCon (renames hm n) ts - go (TyForAll tb t) = TyForAll (renamesTyBinderInType hm tb) t + go (TyForAll tb t) = TyForAll (renamesIdInType hm tb) t go t = t --- We don't want both modify and go to recurse on the Type's in TyBinders or Ids +-- We don't want both modify and go to recurse on the Type's in Ids -- so we introduce functions to collect or rename only the Names directly in those types -tyBinderNamesInType :: TyBinder -> [Name] -tyBinderNamesInType (NamedTyBndr i) = idNamesInType i -tyBinderNamesInType _ = [] - -idNamesInType :: Id -> [Name] -idNamesInType (Id n _) = [n] - -renameTyBinderInType :: Name -> Name -> TyBinder -> TyBinder -renameTyBinderInType old new (NamedTyBndr i) = NamedTyBndr $ renameIdInType old new i -renameTyBinderInType _ _ tyb = tyb +idNamesInType :: Id -> S.Seq Name +idNamesInType (Id n _) = S.singleton n renameIdInType :: Name -> Name -> Id -> Id renameIdInType old new (Id n t) = Id (rename old new n) t -renamesTyBinderInType :: HM.HashMap Name Name -> TyBinder -> TyBinder -renamesTyBinderInType hm (NamedTyBndr i) = NamedTyBndr $ renamesIdInType hm i -renamesTyBinderInType _ tyb = tyb - renamesIdInType :: HM.HashMap Name Name -> Id -> Id renamesIdInType hm (Id n t) = Id (renames hm n) t instance Named Alt where {-# INLINE names #-} - names (Alt am e) = names am ++ names e + names (Alt am e) = names am <> names e {-# INLINE rename #-} rename old new (Alt am e) = Alt (rename old new am) (rename old new e) @@ -369,7 +431,7 @@ instance Named DataCon where {-# INLINE names #-} - names (DataCon n t) = n:names t + names (DataCon n t) = n S.<| names t {-# INLINE rename #-} rename old new (DataCon n t) = @@ -381,8 +443,8 @@ instance Named AltMatch where {-# INLINE names #-} - names (DataAlt dc i) = names dc ++ names i - names _ = [] + names (DataAlt dc i) = names dc <> names i + names _ = S.empty {-# INLINE rename #-} rename old new (DataAlt dc i) = @@ -394,29 +456,22 @@ DataAlt (renames hm dc) (renames hm i) renames _ am = am -instance Named TyBinder where - names (AnonTyBndr t) = names t - names (NamedTyBndr i) = names i - - rename old new (AnonTyBndr t) = AnonTyBndr (rename old new t) - rename old new (NamedTyBndr i) = NamedTyBndr (rename old new i) - - renames hm (AnonTyBndr t) = AnonTyBndr (renames hm t) - renames hm (NamedTyBndr i) = NamedTyBndr (renames hm i) - instance Named Coercion where - names (t1 :~ t2) = names t1 ++ names t2 + names (t1 :~ t2) = names t1 <> names t2 rename old new (t1 :~ t2) = rename old new t1 :~ rename old new t2 renames hm (t1 :~ t2) = renames hm t1 :~ renames hm t2 instance Named Tickish where - names (Breakpoint _) = [] - names (NamedLoc n) = [n] + names (Breakpoint _) = S.empty + names (HpcTick _ _) = S.empty + names (NamedLoc n) = S.singleton n rename _ _ bp@(Breakpoint _) = bp + rename _ _ hpc@(HpcTick _ _) = hpc rename old new (NamedLoc n) = NamedLoc $ rename old new n renames _ bp@(Breakpoint _) = bp + renames _ hpc@(HpcTick _ _) = hpc renames hm (NamedLoc n) = NamedLoc $ renames hm n instance Named RewriteRule where @@ -425,15 +480,17 @@ , ru_bndrs = b , ru_args = as , ru_rhs = rhs}) = - h:names rs ++ names b ++ names as ++ names rhs + h S.<| names rs <> names b <> names as <> names rhs rename old new (RewriteRule { ru_name = n + , ru_module = mdl , ru_head = h , ru_rough = rs , ru_bndrs = b , ru_args = as , ru_rhs = rhs}) = RewriteRule { ru_name = n + , ru_module = mdl , ru_head = rename old new h , ru_rough = rename old new rs , ru_bndrs = rename old new b @@ -441,12 +498,14 @@ , ru_rhs = rename old new rhs} renames hm (RewriteRule { ru_name = n + , ru_module = mdl , ru_head = h , ru_rough = rs , ru_bndrs = b , ru_args = as , ru_rhs = rhs}) = RewriteRule { ru_name = n + , ru_module = mdl , ru_head = renames hm h , ru_rough = renames hm rs , ru_bndrs = renames hm b @@ -454,7 +513,7 @@ , ru_rhs = renames hm rhs} instance Named FuncCall where - names (FuncCall {funcName = n, arguments = as, returns = r}) = n:names as ++ names r + names (FuncCall {funcName = n, arguments = as, returns = r}) = n S.<| names as <> names r rename old new (FuncCall {funcName = n, arguments = as, returns = r}) = FuncCall {funcName = rename old new n, arguments = rename old new as, returns = rename old new r} renames hm (FuncCall {funcName = n, arguments = as, returns = r} ) = @@ -462,9 +521,9 @@ instance Named AlgDataTy where - names (DataTyCon ns dc) = names ns ++ names dc - names (NewTyCon ns dc rt) = names ns ++ names dc ++ names rt - names (TypeSynonym is st) = names is ++ names st + names (DataTyCon ns dc) = names ns <> names dc + names (NewTyCon ns dc rt) = names ns <> names dc <> names rt + names (TypeSynonym is st) = names is <> names st rename old new (DataTyCon n dc) = DataTyCon (rename old new n) (rename old new dc) rename old new (NewTyCon n dc rt) = NewTyCon (rename old new n) (rename old new dc) (rename old new rt) @@ -492,15 +551,31 @@ , dcTrue = dcT , dcFalse = dcF + , tyRational = tR + , tyList = tList , dcCons = tCons , dcEmpty = tEmp + , tyMaybe = tMaybe + , dcJust = dJust + , dcNothing = dNothing + + , tyUnit = tUnit + , dcUnit = dUnit + , eqTC = eqT , numTC = numT , ordTC = ordT , integralTC = integralT + , realTC = realT + , fractionalTC = fractionalT + , integralExtactReal = integralEReal + , realExtractNum = realENum + , realExtractOrd = realEOrd + , ordExtractEq = ordEEq + , eqFunc = eqF , neqFunc = neqF @@ -510,26 +585,44 @@ , divFunc = divF , negateFunc = negF , modFunc = modF + , fromIntegerFunc = fromIntegerF , toIntegerFunc = toIntegerF + , toRatioFunc = toRatioF + , fromRationalFunc = fromRationalF + , geFunc = geF , gtFunc = gtF , ltFunc = ltF , leFunc = leF - , structEqTC = seT - , structEqFunc = seF + , impliesFunc = impF + , iffFunc = iffF , andFunc = andF , orFunc = orF + , notFunc = notF + , errorFunc = errF + , errorEmptyListFunc = errEmpListF + , errorWithoutStackTraceFunc = errWOST , patErrorFunc = patE }) = - [dI, dF, dD, dI2, dcCh, tI, tI2, tF, tD, tCh, tB, dcT, dcF, tList, tCons, tEmp - , eqT, numT, ordT, integralT, eqF, neqF, plF, minusF, tmsF, divF, negF, modF, fromIntegerF, toIntegerF - , geF, gtF, ltF, leF, seT, seF - , andF, orF, patE] + S.fromList + [dI, dF, dD, dI2, dcCh, tI, tI2, tF, tD, tCh, tB, dcT, dcF, tR + , tList, tCons, tEmp + , tMaybe, dJust, dNothing + , tUnit, dUnit + , eqT, numT, ordT, integralT, realT, fractionalT + , integralEReal, realENum, realEOrd, ordEEq + , eqF, neqF, plF, minusF, tmsF, divF, negF, modF + , fromIntegerF, toIntegerF + , toRatioF, fromRationalF + , geF, gtF, ltF, leF + , impF, iffF + , andF, orF, notF + , errF, errEmpListF, errWOST, patE] rename old new (KnownValues { dcInt = dI @@ -548,15 +641,31 @@ , dcTrue = dcT , dcFalse = dcF + , tyRational = tR + , tyList = tList , dcCons = tCons , dcEmpty = tEmp + , tyMaybe = tMaybe + , dcJust = dJust + , dcNothing = dNothing + + , tyUnit = tUnit + , dcUnit = dUnit + , eqTC = eqT , numTC = numT , ordTC = ordT , integralTC = integralT + , realTC = realT + , fractionalTC = fractionalT + , integralExtactReal = integralEReal + , realExtractNum = realENum + , realExtractOrd = realEOrd + , ordExtractEq = ordEEq + , eqFunc = eqF , neqFunc = neqF @@ -566,20 +675,28 @@ , divFunc = divF , negateFunc = negF , modFunc = modF + , fromIntegerFunc = fromIntegerF , toIntegerFunc = toIntegerF + , toRatioFunc = toRatioF + , fromRationalFunc = fromRationalF + , geFunc = geF , gtFunc = gtF , ltFunc = ltF , leFunc = leF - , structEqTC = seT - , structEqFunc = seF + , impliesFunc = impF + , iffFunc = iffF , andFunc = andF , orFunc = orF + , notFunc = notF + , errorFunc = errF + , errorEmptyListFunc = errEmpListF + , errorWithoutStackTraceFunc = errWOST , patErrorFunc = patE }) = (KnownValues { @@ -598,15 +715,32 @@ , tyBool = rename old new tB , dcTrue = rename old new dcT , dcFalse = rename old new dcF + + , tyRational = rename old new tR + , tyList = rename old new tList , dcCons = rename old new tCons , dcEmpty = rename old new tEmp + , tyMaybe = rename old new tMaybe + , dcJust = rename old new dJust + , dcNothing = rename old new dNothing + + , tyUnit = rename old new tUnit + , dcUnit = rename old new dUnit + , eqTC = rename old new eqT , numTC = rename old new numT , ordTC = rename old new ordT , integralTC = rename old new integralT + , realTC = rename old new realT + , fractionalTC = rename old new fractionalT + , integralExtactReal = rename old new integralEReal + , realExtractNum = rename old new realENum + , realExtractOrd = rename old new realEOrd + , ordExtractEq = rename old new ordEEq + , eqFunc = rename old new eqF , neqFunc = rename old new neqF @@ -616,20 +750,28 @@ , divFunc = rename old new divF , negateFunc = rename old new negF , modFunc = rename old new modF + , fromIntegerFunc = rename old new fromIntegerF , toIntegerFunc = rename old new toIntegerF + , toRatioFunc = rename old new toRatioF + , fromRationalFunc = rename old new fromRationalF + , geFunc = rename old new geF , gtFunc = rename old new gtF , ltFunc = rename old new ltF , leFunc = rename old new leF - - , structEqTC = rename old new seT - , structEqFunc = rename old new seF + + , impliesFunc = rename old new impF + , iffFunc = rename old new iffF , andFunc = rename old new andF , orFunc = rename old new orF + , notFunc = rename old new notF + , errorFunc = rename old new errF + , errorEmptyListFunc = rename old new errEmpListF + , errorWithoutStackTraceFunc = rename old new errWOST , patErrorFunc = rename old new patE }) @@ -641,7 +783,15 @@ {-# INLINE renames #-} renames hm = fmap (renames hm) +instance Named a => Named (S.Seq a) where + {-# INLINE names #-} + names = foldMap names + {-# INLINE rename #-} + rename old new = fmap (rename old new) + {-# INLINE renames #-} + renames hm = fmap (renames hm) + instance Named a => Named (Maybe a) where {-# INLINE names #-} names = foldMap names @@ -668,7 +818,7 @@ instance Named () where {-# INLINE names #-} - names _ = [] + names _ = S.empty {-# INLINE rename #-} rename _ _ = id {-# INLINE renames #-} @@ -683,37 +833,55 @@ renames hm = HS.map (renames hm) instance (Named a, Named b) => Named (a, b) where - names (a, b) = names a ++ names b + names (a, b) = names a <> names b rename old new (a, b) = (rename old new a, rename old new b) renames hm (a, b) = (renames hm a, renames hm b) instance (Named a, Named b, Named c) => Named (a, b, c) where - names (a, b, c) = names a ++ names b ++ names c + names (a, b, c) = names a <> names b <> names c rename old new (a, b, c) = (rename old new a, rename old new b, rename old new c) renames hm (a, b, c) = (renames hm a, renames hm b, renames hm c) instance (Named a, Named b, Named c, Named d) => Named (a, b, c, d) where - names (a, b, c, d) = names a ++ names b ++ names c ++ names d + names (a, b, c, d) = names a <> names b <> names c <> names d rename old new (a, b, c, d) = (rename old new a, rename old new b, rename old new c, rename old new d) renames hm (a, b, c, d) = (renames hm a, renames hm b, renames hm c, renames hm d) instance (Named a, Named b, Named c, Named d, Named e) => Named (a, b, c, d, e) where - names (a, b, c, d, e) = names a ++ names b ++ names c ++ names d ++ names e + names (a, b, c, d, e) = names a <> names b <> names c <> names d <> names e rename old new (a, b, c, d, e) = (rename old new a, rename old new b, rename old new c, rename old new d, rename old new e) renames hm (a, b, c, d, e) = (renames hm a, renames hm b, renames hm c, renames hm d, renames hm e) +instance Named Bool where + {-# INLINE names #-} + names _ = S.empty + {-# INLINE rename #-} + rename _ _ = id + instance Named Int where {-# INLINE names #-} - names _ = [] + names _ = S.empty {-# INLINE rename #-} rename _ _ = id +instance Named Integer where + {-# INLINE names #-} + names _ = S.empty + {-# INLINE rename #-} + rename _ _ = id + instance Named T.Text where {-# INLINE names #-} - names _ = [] + names _ = S.empty {-# INLINE rename #-} rename _ _ = id +instance (Named k, Named v, Eq k, Hashable k) => Named (UF.UFMap k v) where + names = names . UF.toList + rename old new = UF.fromList . rename old new . UF.toList + renames hm = UF.fromList . renames hm . UF.toList + + freshSeededString :: T.Text -> NameGen -> (Name, NameGen) freshSeededString t = freshSeededName (Name t Nothing 0 Nothing) @@ -721,28 +889,25 @@ freshSeededStrings t = freshSeededNames (map (\t' -> Name t' Nothing 0 Nothing) t) freshSeededName :: Name -> NameGen -> (Name, NameGen) -freshSeededName (Name n m _ l) (NameGen { max_uniq = hm, dc_children = chm }) = - (Name n m i' l, NameGen hm' chm) +freshSeededName (Name n m _ l) (NameGen hm) = + (Name n m i' l, NameGen hm') where i' = HM.lookupDefault 0 (n, m) hm hm' = HM.insert (n, m) (i' + 1) hm freshSeededNames :: [Name] -> NameGen -> ([Name], NameGen) -freshSeededNames [] r = ([], r) -freshSeededNames (n:ns) r = (n':ns', ngen'') - where (n', ngen') = freshSeededName n r - (ns', ngen'') = freshSeededNames ns ngen' +freshSeededNames ns ng = swap $ mapAccumR (\ng' n -> swap $ freshSeededName n ng') ng ns freshName :: NameGen -> (Name, NameGen) freshName ngen = freshSeededName seed ngen where - seed = Name "fs?" Nothing 0 Nothing + seed = Name "fs" Nothing 0 Nothing freshNames :: Int -> NameGen -> ([Name], NameGen) -freshNames i ngen = freshSeededNames (replicate i (Name "fs?" Nothing 0 Nothing)) ngen +freshNames i ngen = freshSeededNames (replicate i (Name "fs" Nothing 0 Nothing)) ngen freshId :: Type -> NameGen -> (Id, NameGen) -freshId = freshSeededId (Name "fs?" Nothing 0 Nothing) +freshId = freshSeededId (Name "fs" Nothing 0 Nothing) freshIds :: [Type] -> NameGen -> ([Id], NameGen) freshIds ts ngen = @@ -754,7 +919,9 @@ freshSeededId :: Named a => a -> Type -> NameGen -> (Id, NameGen) freshSeededId x t ngen = let - (n, ngen') = freshSeededName (head $ names x) ngen + (n, ngen') = case S.viewl (names x) of + S.EmptyL -> error "freshSeededId: no names available" + x' S.:< _ -> freshSeededName x' ngen in (Id n t, ngen') @@ -765,48 +932,7 @@ in (Var i, ngen') --- | Given the name n of a datacon, and some names for it's children, --- returns new names ns for the children --- Returns a new NameGen that will always return the same ns for that n --- If this is called with different length ns's, the shorter will be the prefix --- of the longer -childrenNames :: Name -> [Name] -> NameGen -> ([Name], NameGen) -childrenNames n ns ng@(NameGen { dc_children = chm }) = - case HM.lookup n chm of - Just ens' -> childrenNamesExisting n ns ens' ng - Nothing -> childrenNamesNew n ns ng-- [] - -childrenNamesExisting :: Name -> [Name] -> [Name] -> NameGen -> ([Name], NameGen) -childrenNamesExisting n ns ens ng = - let - (fns, NameGen hm chm) = freshSeededNames (drop (length ens) ns) ng - ns' = ens ++ fns - - chm' = HM.insert n ns' chm - in - case length ns `compare` length ens of - LT -> (take (length ns) ens, ng) - EQ -> (ens, ng) - GT -> (ns', NameGen hm chm') - -childrenNamesNew :: Name -> [Name] -> NameGen -> ([Name], NameGen) -childrenNamesNew n ns ng = - let - (fns, NameGen hm chm) = freshSeededNames ns ng - chm' = HM.insert n fns chm - in - (fns, NameGen hm chm') - - -- | Allows mapping, while passing a NameGen along mapNG :: (a -> NameGen -> (b, NameGen)) -> [a] -> NameGen -> ([b], NameGen) -mapNG f xs ng = swap $ mapAccumR (\xs' ng' -> swap $ f ng' xs') ng xs -- mapNG' f (reverse xs) ng [] +mapNG f xs ng = swap $ mapAccumR (\xs' ng' -> swap $ f ng' xs') ng xs {-# INLINE mapNG #-} - --- mapNG' :: (a -> NameGen -> (b, NameGen)) -> [a] -> NameGen -> [b] -> ([b], NameGen) --- mapNG' _ [] ng xs = (xs, ng) --- mapNG' f (x:xs) ng xs' = --- let --- (x', ng') = f x ng --- in --- mapNG' f xs ng' (x':xs') diff --git a/src/G2/Language/PathConds.hs b/src/G2/Language/PathConds.hs --- a/src/G2/Language/PathConds.hs +++ b/src/G2/Language/PathConds.hs @@ -4,114 +4,194 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} -module G2.Language.PathConds ( PathCond (..) - , Constraint - , Assertion - , PathConds - , empty - , fromList - , map - , filter - , insert - , null - , number - , relevant - , relatedSets - , scc - , varIdsInPC - , toList - , isPCExists) where +module G2.Language.PathConds ( PathConds + , PCGroup (..) + , PathCond (..) + , HashedPathCond + , Constraint + , Assertion + , mkAssumePC + , mkSingletonAssumePC + , toUFMap + , toUFList + , empty + , fromList + , fromHashedList + , map + , mapHashedPCs + , map' + , filter + , alter + , alterHashed + , unionAlterHashed + , insert + , null + , number + , relatedSets + , scc + , varIdsInPC + , varNamesInPC + , allIds + , toList + , toHashedList + , toHashSet + , union + -- , intersection + -- , difference + , mergeWithAssumePCs + + , hashedPC + , unhashedPC + , mapHashedPC) where + +import qualified G2.Data.UFMap as UF import G2.Language.AST import G2.Language.Ids -import qualified G2.Language.KnownValues as KV import G2.Language.Naming import G2.Language.Syntax import Data.Coerce import Data.Data (Data, Typeable) +import qualified Data.Foldable as F import GHC.Generics (Generic) import Data.Hashable import qualified Data.HashSet as HS +import qualified Data.HashMap.Lazy as HM import qualified Data.List as L -import qualified Data.Map as M import Data.Maybe +import Data.Monoid (Monoid (..)) import Prelude hiding (map, filter, null) import qualified Prelude as P (map) +import Data.Semigroup (Semigroup (..)) --- In the implementation: --- Each name (Just n) maps to some (but not neccessarily all) of the PathCond's that --- contain n, and a list of all names that appear in some PathCond alongside --- the name n --- PathConds that contain no names are stored in Nothing --- --- You can visualize this as a graph, with Names and Nothing as Nodes. --- Edges exist in a PathConds pcs netween a name n, and any names in --- snd $ M.lookup n (toMap pcs) +-- Conceptually, the path constraints are a graph, with (Maybe Name)'s Nodes. +-- Edges exist between any names that are in the same path constraint. +-- Strongly connected components in the graph must be checked and solved together. --- | You can visualize a PathConds as [PathCond] (accessible via toList) -newtype PathConds = PathConds (M.Map (Maybe Name) (HS.HashSet PathCond, [Name])) - deriving (Show, Eq, Read, Typeable, Data) +-- A collection of path constraints- requirements on symbolic variables. +newtype PathConds = PathConds (UF.UFMap (Maybe Name) PCGroup) + deriving (Show, Eq, Read, Generic, Typeable, Data) +instance Hashable PathConds + +data PCGroup = PCGroup { pcs_contains :: HS.HashSet Id, pcs :: HS.HashSet HashedPathCond} + deriving (Show, Eq, Read, Generic, Typeable, Data) + +instance Hashable PCGroup + +instance Semigroup PCGroup where + pcg1 <> pcg2 = + PCGroup { pcs_contains = pcs_contains pcg1 `HS.union` pcs_contains pcg2 + , pcs = pcs pcg1 `HS.union` pcs pcg2 } + +instance Monoid PCGroup where + mempty = PCGroup HS.empty HS.empty + mappend = (<>) + +mapMaybePCGroup :: (HashedPathCond -> Maybe HashedPathCond) -> PCGroup -> PCGroup +mapMaybePCGroup f pcg = + let + pcs' = HS.map fromJust . HS.filter isJust $ HS.map f (pcs pcg) + in + PCGroup { pcs_contains = HS.fromList (concatMap (varIdsInPC . unhashedPC) pcs'), pcs = pcs' } + +unionMapMaybePCGroup :: (HashedPathCond -> HS.HashSet HashedPathCond) -> PCGroup -> PCGroup +unionMapMaybePCGroup f pcg = + let + pcs' = F.foldl' HS.union HS.empty $ HS.map f (pcs pcg) + in + PCGroup { pcs_contains = HS.fromList (concatMap (varIdsInPC . unhashedPC) pcs'), pcs = pcs' } + + -- | Path conditions represent logical constraints on our current execution -- path. We can have path constraints enforced due to case/alt branching, due -- to assertion / assumptions made, or some externally coded factors. data PathCond = AltCond Lit Expr Bool -- ^ The expression and Lit must match | ExtCond Expr Bool -- ^ The expression must be a (true) boolean - | ConsCond DataCon Expr Bool -- ^ The expression and datacon must match - | PCExists Id -- ^ Makes sure we find some value for the given name, of the correct type + | SoftPC PathCond -- ^ A `PathCond` to satisfy if possible, but which is not absolutely required. + | MinimizePC Expr -- ^ An expression to minimize + | AssumePC Id Integer (HS.HashSet HashedPathCond) -- ^ An implication- if the `Id` equals the integer, that implies the `HashedPathCond` in the `HS.HashSet` deriving (Show, Eq, Read, Generic, Typeable, Data) type Constraint = PathCond type Assertion = PathCond -instance Hashable PathCond +instance Hashable PathCond where + hashWithSalt s pc = s `hashWithSalt` hash pc -{-# INLINE toMap #-} -toMap :: PathConds -> M.Map (Maybe Name) (HS.HashSet PathCond, [Name]) -toMap = coerce + hash (AltCond l e b) = (1 :: Int) `hashWithSalt` l `hashWithSalt` e `hashWithSalt` b + hash (ExtCond e b) = (2 :: Int) `hashWithSalt` e `hashWithSalt` b + hash (SoftPC pc) = (3 :: Int) `hashWithSalt` pc + hash (MinimizePC e) = (4 :: Int) `hashWithSalt` e + hash (AssumePC i n pc) = (5 :: Int) `hashWithSalt` i `hashWithSalt` n `hashWithSalt` pc -- hashAssumePC i n pc +{-# INLINE toUFMap #-} +toUFMap :: PathConds -> UF.UFMap (Maybe Name) PCGroup +toUFMap = coerce + +fromUFMap :: UF.UFMap (Maybe Name) PCGroup -> PathConds +fromUFMap = coerce + +toUFList :: PathConds -> [([Maybe Name], PCGroup)] +toUFList = mapMaybe (\(ns, pc) -> case pc of Just pc' -> Just (ns, pc'); Nothing -> Nothing) . UF.toList . toUFMap + {-# INLINE empty #-} -- | Constructs an empty `PathConds`. empty :: PathConds -empty = PathConds M.empty +empty = PathConds UF.empty -fromList :: KV.KnownValues -> [PathCond] -> PathConds -fromList kv = coerce . foldr (insert kv) empty +fromList :: [PathCond] -> PathConds +fromList = coerce . foldr insert empty -map :: (PathCond -> a) -> PathConds -> [a] -map f = L.map f . toList +fromHashedList :: [HashedPathCond] -> PathConds +fromHashedList = coerce . foldr insertHashed empty +map :: (PathCond -> PathCond) -> PathConds -> PathConds +map f = fromList . L.map f . toList + +mapHashedPCs :: (HashedPathCond -> HashedPathCond) -> PathConds -> PathConds +mapHashedPCs f = fromHashedList . L.map f . toHashedList + +map' :: (PathCond -> a) -> PathConds -> [a] +map' f = L.map f . toList + filter :: (PathCond -> Bool) -> PathConds -> PathConds -filter f = PathConds - . M.filter (not . HS.null . fst) - . M.map (\(pc, ns) -> (HS.filter f pc, ns)) - . toMap +filter f = fromHashedList + . L.filter (f . unhashedPC) + . toHashedList +alter :: (PathCond -> Maybe PathCond) -> PathConds -> PathConds +alter f = fromList . mapMaybe f . toList + +alterHashed :: (HashedPathCond -> Maybe HashedPathCond) -> PathConds -> PathConds +alterHashed f = fromUFMap . UF.map (mapMaybePCGroup f) . toUFMap + +unionAlterHashed :: (HashedPathCond -> HS.HashSet HashedPathCond) -> PathConds -> PathConds +unionAlterHashed f = fromUFMap . UF.map (unionMapMaybePCGroup f) . toUFMap + -- Each name n maps to all other names that are in any PathCond containing n -- However, each n does NOT neccessarily map to all PCs containing n- instead each -- PC is associated with only one name. -- This is ok, because the PCs can only be externally accessed by toList (which -- returns all PCs anyway) or scc (which forces exploration over all shared names) {-# INLINE insert #-} -insert :: KV.KnownValues -> PathCond -> PathConds -> PathConds -insert = insert' varNamesInPC +insert :: PathCond -> PathConds -> PathConds +insert pc = insertHashed (hashedPC pc) -insert' :: (KV.KnownValues -> PathCond -> [Name]) -> KV.KnownValues -> PathCond -> PathConds -> PathConds -insert' f kv p (PathConds pcs) = +insertHashed :: HashedPathCond -> PathConds -> PathConds +insertHashed pc (PathConds pcc) = let - ns = f kv p - - (hd, insertAt) = case ns of - [] -> (Nothing, [Nothing]) - (h:_) -> (Just h, P.map Just ns) + var_ids = varIdsInPC (unhashedPC pc) + sing_pc = PCGroup (HS.fromList var_ids) (HS.singleton pc) in - PathConds $ M.adjust (\(p', ns') -> (HS.insert p p', ns')) hd - $ foldr (M.alter (insert'' ns)) pcs insertAt - -insert'' :: [Name] -> Maybe (HS.HashSet PathCond, [Name]) -> Maybe (HS.HashSet PathCond, [Name]) -insert'' ns Nothing = Just (HS.empty, ns) -insert'' ns (Just (p', ns')) = Just (p', ns ++ ns') + case var_ids of + [] -> PathConds $ UF.insertWith (<>) Nothing sing_pc pcc + vs@(v:_) -> + let + ins_pcs = UF.insertWith (<>) (Just (idName v)) sing_pc pcc + in + PathConds $ UF.joinAll (<>) (P.map (Just . idName) vs) ins_pcs {-# INLINE number #-} number :: PathConds -> Int @@ -119,156 +199,251 @@ {-# INLINE null #-} null :: PathConds -> Bool -null = M.null . toMap - --- | Filters a PathConds to only those PathCond's that potentially impact the --- given PathCond's satisfiability (i.e. they are somehow linked by variable names) -relevant :: KV.KnownValues -> [PathCond] -> PathConds -> PathConds -relevant kv pc pcs = - case concatMap (varNamesInPC kv) pc of - [] -> fromList kv pc - rel -> scc rel pcs +null = UF.null . toUFMap -- Returns a list of PathConds, where the union of the output PathConds -- is the input PathConds, and the PathCond are seperated into there SCCs -relatedSets :: KV.KnownValues -> PathConds -> [PathConds] -relatedSets kv pc@(PathConds pcm) = +relatedSets :: PathConds -> [PathConds] +relatedSets (PathConds ufm) = let - epc = case M.lookup Nothing pcm of - Just v -> PathConds $ M.singleton Nothing v - Nothing -> PathConds M.empty - - ns = catMaybes $ M.keys pcm + c_ufm = UF.clear ufm in - if null epc then relatedSets' kv pc ns else epc:relatedSets' kv pc ns - -relatedSets' :: KV.KnownValues -> PathConds -> [Name] -> [PathConds] -relatedSets' kv pc ns = - case ns of - k:_ -> - let - s = scc [k] pc - ns' = concat $ map (varNamesInPC kv) s - in - s:relatedSets' kv pc (ns L.\\ (k:ns')) - [] -> [] + P.map (\(k, v) -> PathConds $ UF.insert k v c_ufm) $ HM.toList (UF.toSimpleMap ufm) +varIdsInPC :: PathCond -> [Id] +varIdsInPC (AltCond _ e _) = varIds e +varIdsInPC (ExtCond e _) = varIds e +varIdsInPC (MinimizePC e) = varIds e +varIdsInPC (SoftPC pc) = varIdsInPC pc +varIdsInPC (AssumePC i _ pc) = i:concatMap (varIdsInPC . unhashedPC) pc -varIdsInPC :: KV.KnownValues -> PathCond -> [Id] --- [AltCond] --- Optimization --- When we have an AltCond with a Var expr, we only have to look at --- other PC's with that Var's name. This is because we assign all --- DCs from the same part in a DC tree the same name, and a DC's --- parents/children can't impose restrictions on it. We are completely --- guided by pattern matching from case statements. --- See note [ChildrenNames] in Execution/Rules.hs -varIdsInPC _ (AltCond _ e _) = varIds e -varIdsInPC _ (ExtCond e _) = varIds e -varIdsInPC _ (ConsCond _ e _) = varIds e -varIdsInPC _ (PCExists i) = [i] +varNamesInPC :: PathCond -> [Name] +varNamesInPC = P.map idName . varIdsInPC -varNamesInPC :: KV.KnownValues -> PathCond -> [Name] -varNamesInPC kv = P.map idName . varIdsInPC kv +allIds :: PathConds -> HS.HashSet Id +allIds (PathConds pc) = HS.unions . P.map pcs_contains $ UF.elems pc -{-# INLINE scc #-} +-- | Computes the path constraints that relate to the `Names` in the passed list. scc :: [Name] -> PathConds -> PathConds -scc ns (PathConds pc) = PathConds $ scc' ns pc M.empty - -scc' :: [Name] - -> (M.Map (Maybe Name) (HS.HashSet PathCond, [Name])) - -> (M.Map (Maybe Name) (HS.HashSet PathCond, [Name])) - -> (M.Map (Maybe Name) (HS.HashSet PathCond, [Name])) -scc' [] _ pc = pc -scc' (n:ns) pc newpc = - -- Check if we already inserted the name information - case M.lookup (Just n) newpc of - Just _ -> scc' ns pc newpc - Nothing -> - -- If we didn't, lookup info to insert, - -- and add names to the list of names to search - case M.lookup (Just n) pc of - Just pcn@(_, ns') -> scc' (ns ++ ns') pc (M.insert (Just n) pcn newpc) - Nothing -> scc' ns pc newpc +scc ns (PathConds pcc) = + let + ns' = P.map (flip UF.find pcc . Just) ns + in + PathConds $ UF.filterWithKey (\k _ -> k `L.elem` ns') pcc {-# INLINE toList #-} toList :: PathConds -> [PathCond] -toList = concatMap (HS.toList . fst) . M.elems . toMap +toList = P.map unhashedPC . toHashedList -isPCExists :: PathCond -> Bool -isPCExists (PCExists _) = True -isPCExists _ = False +{-# INLINE toHashedList #-} +toHashedList :: PathConds -> [HashedPathCond] +toHashedList = HS.toList . toHashSet +{-# INLINE toHashSet #-} +toHashSet :: PathConds -> HS.HashSet HashedPathCond +toHashSet = HS.unions . UF.elems . UF.map pcs . toUFMap + +union :: PathConds -> PathConds -> PathConds +union (PathConds pc1) (PathConds pc2) = PathConds $ UF.unionWith (<>) pc1 pc2 + +mergeWithAssumePCs :: Id -> PathConds -> PathConds -> PathConds +mergeWithAssumePCs i (PathConds pc1) (PathConds pc2) = + let + mrg = UF.mergeJoiningWithKey + (mergeMatched i) + (mergeOnlyIn i 1) + (mergeOnlyIn i 2) + (<>) + (<>) + (<>) + pc1 pc2 + pc = PathConds $ adjustNothing (idName i) mrg + in + pc + +mergeOnlyIn :: Id -> Integer -> Maybe Name -> PCGroup -> (PCGroup, [(Maybe Name, Maybe Name)]) +mergeOnlyIn i n k (PCGroup { pcs_contains = contains, pcs = hpc }) = + let + n_hpc = HS.singleton . hashedPC $ mkAssumePC i n hpc -- HS.map (hashedAssumePC i n) hpc + in + ( PCGroup { pcs_contains = HS.insert i contains, pcs = n_hpc } + , if not (HS.null hpc) then [(Just $ idName i, k)] else []) + +mergeMatched :: Id + -> Maybe Name + -> PCGroup + -> PCGroup + -> (PCGroup, [(Maybe Name, Maybe Name)]) +mergeMatched i k (PCGroup { pcs_contains = contains1, pcs = hpc1 }) (PCGroup { pcs_contains = contains2, pcs = hpc2 }) = + let + both = HS.intersection hpc1 hpc2 + onlyIn1 = HS.difference hpc1 hpc2 -- HS.map (hashedAssumePC i 1) $ HS.difference hpc1 hpc2 + onlyIn2 = HS.difference hpc2 hpc1-- HS.map (hashedAssumePC i 2) $ HS.difference hpc2 hpc1 + onlyIn1_pc = if not (HS.null onlyIn1) then HS.singleton . hashedPC $ mkAssumePC i 1 onlyIn1 else HS.empty + onlyIn2_pc = if not (HS.null onlyIn2) then HS.singleton . hashedPC $ mkAssumePC i 2 onlyIn2 else HS.empty + + hpc = HS.union both (HS.union onlyIn1_pc onlyIn2_pc) + ks = if not (HS.null onlyIn1) || not (HS.null onlyIn2) + then [(Just $ idName i, k)] + else [] + in + ( PCGroup { pcs_contains = HS.insert i (contains1 `HS.union` contains2) , pcs = hpc } + , ks) + +adjustNothing :: Name + -> UF.UFMap (Maybe Name) PCGroup + -> UF.UFMap (Maybe Name) PCGroup +adjustNothing n hs + | Just v <- UF.lookup Nothing hs = UF.insertWith (<>) (Just n) v hs + | otherwise = hs + instance ASTContainer PathConds Expr where - containedASTs = containedASTs . toMap + containedASTs = containedASTs . toUFMap - modifyContainedASTs f = coerce . modifyContainedASTs f . toMap + modifyContainedASTs f = fromList . modifyContainedASTs f . toList instance ASTContainer PathConds Type where - containedASTs = containedASTs . toMap + containedASTs = containedASTs . toUFMap - modifyContainedASTs f = coerce . modifyContainedASTs f . toMap + modifyContainedASTs f = fromList . modifyContainedASTs f . toList instance ASTContainer PathCond Expr where containedASTs (ExtCond e _ ) = [e] containedASTs (AltCond _ e _) = [e] - containedASTs (ConsCond _ e _) = [e] - containedASTs (PCExists _) = [] + containedASTs (MinimizePC e) = containedASTs e + containedASTs (SoftPC pc) = containedASTs pc + containedASTs (AssumePC _ _ pc) = containedASTs pc modifyContainedASTs f (ExtCond e b) = ExtCond (modifyContainedASTs f e) b modifyContainedASTs f (AltCond a e b) = AltCond (modifyContainedASTs f a) (modifyContainedASTs f e) b - modifyContainedASTs f (ConsCond dc e b) = - ConsCond (modifyContainedASTs f dc) (modifyContainedASTs f e) b - modifyContainedASTs _ pc = pc + modifyContainedASTs f (MinimizePC e) = MinimizePC $ modifyContainedASTs f e + modifyContainedASTs f (SoftPC pc) = SoftPC $ modifyContainedASTs f pc + modifyContainedASTs f (AssumePC i num pc) = AssumePC i num (modifyContainedASTs f pc) instance ASTContainer PathCond Type where containedASTs (ExtCond e _) = containedASTs e containedASTs (AltCond e a _) = containedASTs e ++ containedASTs a - containedASTs (ConsCond dcl e _) = containedASTs dcl ++ containedASTs e - containedASTs (PCExists i) = containedASTs i + containedASTs (MinimizePC pc) = containedASTs pc + containedASTs (SoftPC pc) = containedASTs pc + containedASTs (AssumePC i _ pc) = containedASTs i ++ containedASTs pc modifyContainedASTs f (ExtCond e b) = ExtCond e' b where e' = modifyContainedASTs f e modifyContainedASTs f (AltCond e a b) = AltCond e' a' b where e' = modifyContainedASTs f e a' = modifyContainedASTs f a - modifyContainedASTs f (ConsCond dc e b) = - ConsCond (modifyContainedASTs f dc) (modifyContainedASTs f e) b - modifyContainedASTs f (PCExists i) = PCExists (modifyContainedASTs f i) + modifyContainedASTs f (MinimizePC pc) = MinimizePC $ modifyContainedASTs f pc + modifyContainedASTs f (SoftPC pc) = SoftPC $ modifyContainedASTs f pc + modifyContainedASTs f (AssumePC i num pc) = AssumePC (modifyContainedASTs f i) num (modifyContainedASTs f pc) instance Named PathConds where - names (PathConds pc) = (catMaybes $ M.keys pc) ++ concatMap (\(p, n) -> names p ++ n) pc + -- In rename and renames, we loopup and rename individual keys, to avoid rehashing everything in the PathConds - rename old new (PathConds pc) = - PathConds . M.mapKeys (\k -> if k == (Just old) then (Just new) else k) - $ rename old new pc + names = names . UF.toList . toUFMap - renames hm (PathConds pc) = - PathConds . M.mapKeys (renames hm) - $ renames hm pc + rename old new (PathConds pcc) = + let + pcc' = UF.join (<>) (Just old) (Just new) pcc + in + case UF.lookup (Just old) pcc' of + Just pc -> PathConds $ UF.insert (Just new) (rename old new pc) pcc' + Nothing -> PathConds pcc' + renames hm (PathConds pcc) = + let + rep_ns = L.foldr (\k -> HS.insert (UF.find (Just k) pcc)) HS.empty $ HM.keys hm + pcc' = L.foldr (\(k1, k2) -> UF.join (<>) (Just k1) (Just k2)) pcc $ HM.toList hm + in + PathConds $ L.foldr (\k pcs_ -> + case UF.lookup k pcs_ of + Just pc -> UF.insert k (renames hm pc) pcs_ + Nothing -> pcs_) pcc' rep_ns + +instance ASTContainer PCGroup Expr where + containedASTs = containedASTs . pcs + modifyContainedASTs f pcg = pcg { pcs = modifyContainedASTs f $ pcs pcg } + +instance ASTContainer PCGroup Type where + containedASTs = containedASTs . pcs + modifyContainedASTs f pcg = pcg { pcs = modifyContainedASTs f $ pcs pcg } + +instance Named PCGroup where + names = names . pcs + rename old new pcg = pcg { pcs_contains = rename old new (pcs_contains pcg) + , pcs = rename old new (pcs pcg) } + renames hm pcg = pcg { pcs_contains = renames hm (pcs_contains pcg) + , pcs = renames hm (pcs pcg) } + +instance Ided PCGroup where + ids = ids . pcs + instance Named PathCond where names (AltCond _ e _) = names e names (ExtCond e _) = names e - names (ConsCond d e _) = names d ++ names e - names (PCExists i) = names i + names (MinimizePC pc) = names pc + names (SoftPC pc) = names pc + names (AssumePC i _ pc) = names i <> names pc rename old new (AltCond l e b) = AltCond l (rename old new e) b rename old new (ExtCond e b) = ExtCond (rename old new e) b - rename old new (ConsCond d e b) = ConsCond (rename old new d) (rename old new e) b - rename old new (PCExists i) = PCExists (rename old new i) + rename old new (MinimizePC pc) = MinimizePC (rename old new pc) + rename old new (SoftPC pc) = SoftPC (rename old new pc) + rename old new (AssumePC i num pc) = AssumePC (rename old new i) num (rename old new pc) renames hm (AltCond l e b) = AltCond l (renames hm e) b renames hm (ExtCond e b) = ExtCond (renames hm e) b - renames hm (ConsCond d e b) = ConsCond (renames hm d) (renames hm e) b - renames hm (PCExists i) = PCExists (renames hm i) + renames hm (MinimizePC pc) = MinimizePC (renames hm pc) + renames hm (SoftPC pc) = SoftPC (renames hm pc) + renames hm (AssumePC i num pc) = AssumePC (renames hm i) num (renames hm pc) instance Ided PathConds where - ids = ids . toMap + ids = ids . toUFMap instance Ided PathCond where ids (AltCond _ e _) = ids e ids (ExtCond e _) = ids e - ids (ConsCond d e _) = ids d ++ ids e - ids (PCExists i) = [i] + ids (MinimizePC pc) = ids pc + ids (SoftPC pc) = ids pc + ids (AssumePC i _ pc) = ids i ++ ids pc + +data HashedPathCond = HashedPC PathCond {-# UNPACK #-} !Int + deriving (Show, Read, Typeable, Data) + +hashedPC :: PathCond -> HashedPathCond +hashedPC pc = HashedPC pc (hash pc) + +unhashedPC :: HashedPathCond -> PathCond +unhashedPC (HashedPC pc _) = pc + +mapHashedPC :: (PathCond -> PathCond) -> HashedPathCond -> HashedPathCond +mapHashedPC f (HashedPC pc _) = hashedPC (f pc) + +instance Eq HashedPathCond where + HashedPC pc h == HashedPC pc' h' = if h /= h' then False else pc == pc' + +instance Hashable HashedPathCond where + hashWithSalt s (HashedPC _ h) = s `hashWithSalt` h + hash (HashedPC _ h) = h + +instance ASTContainer HashedPathCond Expr where + containedASTs = containedASTs . unhashedPC + modifyContainedASTs f = mapHashedPC (modifyContainedASTs f) + +instance ASTContainer HashedPathCond Type where + containedASTs = containedASTs . unhashedPC + modifyContainedASTs f = mapHashedPC (modifyContainedASTs f) + +instance Named HashedPathCond where + names = names . unhashedPC + rename old new = mapHashedPC (rename old new) + renames hm = mapHashedPC (renames hm) + +instance Ided HashedPathCond where + ids = ids . unhashedPC + +mkAssumePC :: Id -> Integer -> HS.HashSet HashedPathCond -> PathCond +mkAssumePC i n = AssumePC i n + +mkSingletonAssumePC :: Id -> Integer -> PathCond -> PathCond +mkSingletonAssumePC i n = AssumePC i n . HS.singleton . hashedPC diff --git a/src/G2/Language/Primitives.hs b/src/G2/Language/Primitives.hs --- a/src/G2/Language/Primitives.hs +++ b/src/G2/Language/Primitives.hs @@ -1,177 +1,99 @@ -{-# LANGUAGE OverloadedStrings #-} +module G2.Language.Primitives ( mkGe + , mkGt + , mkEq + , mkNeq + , mkLt + , mkLe + , mkAnd + , mkOr + , mkNot + , mkPlus + , mkMinus + , mkMult + , mkDiv + , mkMod + , mkNegate + , mkImplies + , mkIff + , mkFromInteger + , mkToInteger + , mkEqPrimInt + , mkEqPrimFloat + , mkEqPrimDouble + , mkEqPrimChar + , mkAndPrim + , mkGePrimInt + , mkLePrimInt -module G2.Language.Primitives where + , mkEqPrimType + , mkOrPrim + , mkImpliesPrim + , mkNotPrim + + , mkStringAppend + , mkStringLen) where import qualified G2.Language.ExprEnv as E import G2.Language.KnownValues as KV import G2.Language.Syntax -import G2.Language.Typing - -import Data.Foldable -import qualified Data.Text as T - -primStr :: Primitive -> T.Text -primStr Ge = ">=" -primStr Gt = ">" -primStr Eq = "==" -primStr Neq = "/=" -primStr Lt = "<" -primStr Le = "<=" -primStr And = "&&" -primStr Or = "||" -primStr Not = "not" -primStr Implies = "implies" -primStr Iff = "iff" -primStr Plus = "+" -primStr Minus = "-" -primStr Mult = "*" -primStr Div = "/" -primStr DivInt = "/" -primStr Quot = "quot" -primStr Mod = "mod" -primStr Negate = "negate" -primStr SqRt = "sqrt" -primStr IntToFloat = "fromIntegral" -primStr IntToDouble = "fromIntegral" -primStr FromInteger = "fromInteger" -primStr ToInteger = "toInteger" -primStr ToInt = "toInt" -primStr Error = "error" -primStr Undefined = "undefined" -primStr BindFunc = "BindFunc" - -strToPrim :: T.Text -> Maybe Primitive -strToPrim "not" = Just Not -strToPrim "&&" = Just And -strToPrim "||" = Just Or -strToPrim ">=" = Just Ge -strToPrim ">" = Just Gt -strToPrim "==" = Just Eq -strToPrim "/=" = Just Neq -strToPrim "<=" = Just Le -strToPrim "<" = Just Lt -strToPrim "+" = Just Plus -strToPrim "-" = Just Minus -strToPrim "*" = Just Mult -strToPrim "quot" = Just Quot -strToPrim "/" = Just Div -strToPrim "mod" = Just Mod -strToPrim "negate" = Just Negate -strToPrim "sqrt" = Just SqRt -strToPrim "error" = Just Error -strToPrim "implies" = Just Implies -strToPrim "iff" = Just Iff -strToPrim _ = Nothing - -findPrim :: Primitive -> [(Name, Type)] -> (Name, Type) -findPrim prim [] = error $ "findPrim: not found: " ++ (T.unpack $ primStr prim) -findPrim prim (p@(Name occ _ _ _, _):ps) = - if primStr prim == occ then p else findPrim prim ps - -mkRawPrim :: [(Name, Type)] -> Name -> Expr -mkRawPrim primtys name@(Name occ _ _ _) = - case prim of - Just _ -> foldr (Lam TypeL) cases ids - Nothing -> Prim Undefined TyBottom - where - prim = strToPrim occ - - ty = snd . head $ filter (\p -> name == fst p) primtys - (forall_ids, ty') = splitTyForAlls ty - fun_tys = splitTyFuns ty' - - tys = (map typeOf forall_ids) ++ fun_tys - - ids = map (\(i, t) -> Id (Name "a" Nothing i Nothing) t) $ zip [1..] (init tys) - binds = map (\(i, t) -> Id (Name "b" Nothing i Nothing) t) $ zip [1..] (init tys) - - varIds = map Var ids - varBinds = map Var binds - - apps = foldl' App (Prim (case prim of - Just p -> p - Nothing -> error $ "PRIM = " ++ show prim) ty) varBinds - - cases = foldr (\(i, b) e -> Case i b [Alt Default e]) apps (zip varIds binds) - --- | Primitive lookup helpers - -mkPrim :: Primitive -> E.ExprEnv -> Expr -mkPrim p eenv = case (inClasses, inNum, inPrelude, inClasses2, inBase2, inReal) of - (Just e, _, _, _, _, _) -> e - (_, Just e, _, _, _, _) -> e - (_, _, Just e, _, _, _) -> e - (_, _, _, Just e, _, _) -> e - (_, _, _, _, Just e, _) -> e - (_, _, _, _, _, Just e) -> e - _ -> error $ "Unrecognized prim " ++ show p ++ " " ++ show (primStr p) - where - inClasses = E.occLookup (primStr p) (Just "GHC.Classes") eenv - inNum = E.occLookup (primStr p) (Just "GHC.Num") eenv - inPrelude = E.occLookup (primStr p) (Just "Prelude") eenv - inClasses2 = E.occLookup (primStr p) (Just "GHC.Classes2") eenv - inBase2 = E.occLookup (primStr p) (Just "GHC.Base2") eenv - inReal = E.occLookup (primStr p) (Just "GHC.Real") eenv - -mkGe :: E.ExprEnv -> Expr -mkGe = mkPrim Ge +import qualified G2.Language.Typing as T -mkGt :: E.ExprEnv -> Expr -mkGt = mkPrim Gt +mkGe :: KnownValues -> E.ExprEnv -> Expr +mkGe kv eenv = eenv E.! (geFunc kv) -mkEq :: E.ExprEnv -> Expr -mkEq = mkPrim Eq +mkGt :: KnownValues -> E.ExprEnv -> Expr +mkGt kv eenv = eenv E.! (gtFunc kv) -mkEq' :: KnownValues -> Expr -mkEq' kv = Var (Id (eqFunc kv) TyBottom) +mkEq :: KnownValues -> E.ExprEnv -> Expr +mkEq kv eenv = eenv E.! (eqFunc kv) -mkNeq :: E.ExprEnv -> Expr -mkNeq = mkPrim Neq +mkNeq :: KnownValues -> E.ExprEnv -> Expr +mkNeq kv eenv = eenv E.! (neqFunc kv) -mkLt :: E.ExprEnv -> Expr -mkLt = mkPrim Lt +mkLt :: KnownValues -> E.ExprEnv -> Expr +mkLt kv eenv = eenv E.! (ltFunc kv) -mkLe :: E.ExprEnv -> Expr -mkLe = mkPrim Le +mkLe :: KnownValues -> E.ExprEnv -> Expr +mkLe kv eenv = eenv E.! (leFunc kv) -mkAnd :: E.ExprEnv -> Expr -mkAnd = mkPrim And +mkAnd :: KnownValues -> E.ExprEnv -> Expr +mkAnd kv eenv = eenv E.! (andFunc kv) -mkOr :: E.ExprEnv -> Expr -mkOr = mkPrim Or +mkOr :: KnownValues -> E.ExprEnv -> Expr +mkOr kv eenv = eenv E.! (orFunc kv) -mkNot :: E.ExprEnv -> Expr -mkNot = mkPrim Not +mkNot :: KnownValues -> E.ExprEnv -> Expr +mkNot kv eenv = eenv E.! (notFunc kv) -mkPlus :: E.ExprEnv -> Expr -mkPlus = mkPrim Plus +mkPlus :: KnownValues -> E.ExprEnv -> Expr +mkPlus kv eenv = eenv E.! (plusFunc kv) -mkMinus :: E.ExprEnv -> Expr -mkMinus = mkPrim Minus +mkMinus :: KnownValues -> E.ExprEnv -> Expr +mkMinus kv eenv = eenv E.! (minusFunc kv) -mkMult :: E.ExprEnv -> Expr -mkMult = mkPrim Mult +mkMult :: KnownValues -> E.ExprEnv -> Expr +mkMult kv eenv = eenv E.! (timesFunc kv) -mkDiv :: E.ExprEnv -> Expr -mkDiv = mkPrim Div +mkDiv :: KnownValues -> E.ExprEnv -> Expr +mkDiv kv eenv = eenv E.! (divFunc kv) -mkMod :: E.ExprEnv -> Expr -mkMod = mkPrim Mod +mkMod :: KnownValues -> E.ExprEnv -> Expr +mkMod kv eenv = eenv E.! (modFunc kv) -mkNegate :: E.ExprEnv -> Expr -mkNegate = mkPrim Negate +mkNegate :: KnownValues -> E.ExprEnv -> Expr +mkNegate kv eenv = eenv E.! (negateFunc kv) -mkImplies :: E.ExprEnv -> Expr -mkImplies = mkPrim Implies +mkImplies :: KnownValues -> E.ExprEnv -> Expr +mkImplies kv eenv = eenv E.! (impliesFunc kv) -mkIff :: E.ExprEnv -> Expr -mkIff = mkPrim Iff +mkIff :: KnownValues -> E.ExprEnv -> Expr +mkIff kv eenv = eenv E.! (iffFunc kv) -mkFromInteger :: E.ExprEnv -> Expr -mkFromInteger = mkPrim FromInteger +mkFromInteger :: KnownValues -> E.ExprEnv -> Expr +mkFromInteger kv eenv = eenv E.! (fromIntegerFunc kv) -mkToInteger :: E.ExprEnv -> Expr -mkToInteger = mkPrim ToInteger +mkToInteger :: KnownValues -> E.ExprEnv -> Expr +mkToInteger kv eenv = eenv E.! (toIntegerFunc kv) -- Primitives on primitive types mkEqPrimType :: Type -> KnownValues -> Expr @@ -189,3 +111,37 @@ mkEqPrimChar :: KnownValues -> Expr mkEqPrimChar = mkEqPrimType TyLitChar + +mkGePrimInt :: KnownValues -> Expr +mkGePrimInt kv = Prim Ge $ TyFun t (TyFun t (TyCon (KV.tyBool kv) TYPE)) + where + t = TyLitInt + +mkLePrimInt :: KnownValues -> Expr +mkLePrimInt kv = Prim Le $ TyFun t (TyFun t (TyCon (KV.tyBool kv) TYPE)) + where + t = TyLitInt + +mkAndPrim :: KnownValues -> Expr +mkAndPrim kv = Prim And $ TyFun t (TyFun t (TyCon (KV.tyBool kv) TYPE)) + where t = (TyCon (KV.tyBool kv) TYPE) + +mkOrPrim :: KnownValues -> Expr +mkOrPrim kv = Prim Or $ TyFun t (TyFun t (TyCon (KV.tyBool kv) TYPE)) + where t = (TyCon (KV.tyBool kv) TYPE) + +mkNotPrim :: KnownValues -> Expr +mkNotPrim kv = Prim Not $ TyFun t (TyCon (KV.tyBool kv) TYPE) + where t = (TyCon (KV.tyBool kv) TYPE) + +mkImpliesPrim :: KnownValues -> Expr +mkImpliesPrim kv = Prim Implies $ TyFun t (TyFun t t) + where t = (TyCon (KV.tyBool kv) TYPE) + +mkStringAppend :: KnownValues -> Expr +mkStringAppend kv = Prim StrAppend $ TyFun t (TyFun t t) + where t = TyApp (T.tyList kv) (T.tyChar kv) + +mkStringLen :: KnownValues -> Expr +mkStringLen kv = Prim StrLen $ TyFun t TyLitInt + where t = TyApp (T.tyList kv) (T.tyChar kv) diff --git a/src/G2/Language/Simplification.hs b/src/G2/Language/Simplification.hs new file mode 100644 --- /dev/null +++ b/src/G2/Language/Simplification.hs @@ -0,0 +1,97 @@ +-- Semantics-preserving syntactic transformations + +{-# LANGUAGE FlexibleContexts #-} + +module G2.Language.Simplification ( simplifyExprs + , simplifyAppLambdas + , inlineFunc + , inlineFuncInCase) where + +import G2.Language.AST +import G2.Language.Expr +import qualified G2.Language.ExprEnv as E +import G2.Language.Syntax +import G2.Language.Typing + +import Data.List + +simplifyExprs :: ASTContainer t Expr => E.ExprEnv -> E.ExprEnv -> t -> t +simplifyExprs eenv c_eenv = modifyContainedASTs (simplifyExpr eenv c_eenv) + +simplifyExpr :: E.ExprEnv -> E.ExprEnv -> Expr -> Expr +simplifyExpr eenv c_eenv e = + let + e' = simplifyAppLambdas $ e + -- e' = caseOfKnownCons + -- . inlineFuncInCase c_eenv + -- . inlineFunc eenv + -- . simplifyAppLambdas $ e + in + if e == e' then e else simplifyExpr eenv c_eenv e' + +-- | Reduce Lambdas that are being passed variables or values in SWHNF. +-- This AVOIDS reducing a lamba if it could cause us to miss an opportunity for sharing. +simplifyAppLambdas :: Expr -> Expr +simplifyAppLambdas (App (Lam TermL i e) e') + | safeToInline e' = simplifyAppLambdas $ replaceVar (idName i) e' e +simplifyAppLambdas (App (Lam TypeL i e) (Var i')) = + simplifyAppLambdas $ retype i (TyVar i') e +simplifyAppLambdas (App (Lam TypeL i e) (Type t)) = + simplifyAppLambdas $ retype i t e +simplifyAppLambdas e@(App (App _ _) _) = + let + e' = modifyChildren simplifyAppLambdas e + in + if e == e' then e else simplifyAppLambdas e' +simplifyAppLambdas e = modifyChildren simplifyAppLambdas e + +safeToInline :: Expr -> Bool +safeToInline (Var _) = True +safeToInline (Lit _) = True +safeToInline e@(App _ _) | Data _:_ <- unApp e = True +safeToInline e@(App _ _) | Prim _ _:_ <- unApp e = True +safeToInline _ = False + +-- | Inline the functions in the ExprEnv +inlineFunc :: E.ExprEnv -> Expr -> Expr +inlineFunc eenv v@(Var (Id n _)) + | Just e <- E.lookup n eenv = inlineFunc eenv e + | otherwise = v +inlineFunc eenv e = + modifyChildren (inlineFunc eenv) e + +-- | Inline the functions in the ExprEnv, if they are the bindee in a Case expression +inlineFuncInCase :: E.ExprEnv -> Expr -> Expr +inlineFuncInCase eenv c@(Case (Var (Id n _)) i t as) + | Just e <- E.lookup n eenv = + inlineFuncInCase eenv $ Case e i t as + | otherwise = c +inlineFuncInCase eenv e = + modifyChildren (inlineFuncInCase eenv) e + +caseOfKnownCons :: Expr -> Expr +caseOfKnownCons (Case e i _ as) + | Data (DataCon n t):es <- unApp e + , Just (Alt (DataAlt _ is) ae) <- find (matchingDataAlt n) as = + let + tfa_count = length (leadingTyForAllBindings $ PresType t) + es' = drop tfa_count es + in + foldr (uncurry replaceVar) (replaceVar (idName i) e ae) (zip (map idName is) es') + | Lit l:_ <- unApp e + , Just (Alt (LitAlt _) ae) <- find (matchingLitAlt l) as = replaceVar (idName i) e ae + + | Data _:_ <- unApp e + , Just (Alt Default ae) <- find (\(Alt am _) -> am == Default) as = replaceVar (idName i) e ae + | Lit l:_ <- unApp e + , Just (Alt Default ae) <- find (\(Alt am _) -> am == Default) as = replaceVar (idName i) e ae + +caseOfKnownCons e = modifyChildren caseOfKnownCons e + +matchingDataAlt :: Name -> Alt -> Bool +matchingDataAlt n (Alt (DataAlt (DataCon n' _) _) _) = n == n' +matchingDataAlt _ _ = False + +matchingLitAlt :: Lit -> Alt -> Bool +matchingLitAlt l (Alt (LitAlt l') _) = l == l' +matchingLitAlt _ _ = False diff --git a/src/G2/Language/Stack.hs b/src/G2/Language/Stack.hs --- a/src/G2/Language/Stack.hs +++ b/src/G2/Language/Stack.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-} @@ -8,19 +9,23 @@ , null , push , pop - , popN - , toList) where + , toList + , filter) where -import Prelude hiding (null) +import Prelude hiding (null, filter) +import GHC.Generics (Generic) import Data.Data (Data, Typeable) +import Data.Hashable import qualified Data.List as L import G2.Language.AST import G2.Language.Naming import G2.Language.Syntax -newtype Stack a = Stack [a] deriving (Show, Eq, Read, Typeable, Data) +newtype Stack a = Stack [a] deriving (Show, Eq, Read, Generic, Typeable, Data) +instance Hashable a => Hashable (Stack a) + -- | Get an empty `Stack`. empty :: Stack a empty = Stack [] @@ -29,30 +34,21 @@ null :: Stack a -> Bool null = L.null . toList --- | Push a `Frame` onto the `Stack`. +-- | Push a value onto the `Stack`. push :: a -> Stack a -> Stack a push x (Stack xs) = Stack (x : xs) --- | Pop a `Frame` from the `Stack`, should it exist. +-- | Pop a value from the `Stack`, should it exist. pop :: Stack a -> Maybe (a, Stack a) pop (Stack []) = Nothing pop (Stack (x:xs)) = Just (x, Stack xs) --- | Pop @n@ frames from the `Stack`, or, if the `Stack` has less than @n@ --- frames, empty the `Stack`. -popN :: Stack a -> Int -> ([a], Stack a) -popN s 0 = ([], s) -popN s n = case pop s of - Just (x, s') -> - let - (xs, s'') = popN s' (n - 1) - in - (x:xs, s'') - Nothing -> ([], s) - -- | Convert a `Stack` to a list. toList :: Stack a -> [a] toList (Stack xs) = xs + +filter :: (a -> Bool) -> Stack a -> Stack a +filter p (Stack stck) = Stack (L.filter p stck) instance ASTContainer a Expr => ASTContainer (Stack a) Expr where containedASTs (Stack s) = containedASTs s diff --git a/src/G2/Language/Support.hs b/src/G2/Language/Support.hs --- a/src/G2/Language/Support.hs +++ b/src/G2/Language/Support.hs @@ -1,5 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} @@ -20,7 +21,7 @@ import qualified G2.Language.ExprEnv as E import G2.Language.KnownValues import G2.Language.Naming -import G2.Language.Stack +import G2.Language.Stack hiding (filter) import G2.Language.Syntax import G2.Language.TypeClasses import G2.Language.TypeEnv @@ -28,41 +29,50 @@ import G2.Language.PathConds hiding (map, filter) import G2.Execution.RuleTypes +import GHC.Generics (Generic) import Data.Data (Data, Typeable) +import Data.Hashable import qualified Data.Map as M import qualified Data.HashMap.Lazy as HM import qualified Data.HashSet as S +import Data.Monoid ((<>)) +import qualified Data.Sequence as S import qualified Data.Text as T --- | The State is passed around in G2. It can be utilized to --- perform defunctionalization, execution, and SMT solving. +-- | `State`s represent an execution state of some (symbolic) Haskell code. +-- A state can be utilized to perform execution and SMT solving. -- The t parameter can be used to track extra information during the execution. -data State t = State { expr_env :: E.ExprEnv - , type_env :: TypeEnv - , curr_expr :: CurrExpr +data State t = State { expr_env :: E.ExprEnv -- ^ Mapping of `Name`s to `Expr`s + , type_env :: TypeEnv -- ^ Type information + , curr_expr :: CurrExpr -- ^ The expression represented by the state , path_conds :: PathConds -- ^ Path conditions, in SWHNF - , non_red_path_conds :: [Expr] -- ^ Path conditions that still need further reduction + , non_red_path_conds :: [(Expr, Expr)] -- ^ Path conditions, in the form of (possibly non-reduced) + -- expression pairs that must be proved equivalent , true_assert :: Bool -- ^ Have we violated an assertion? , assert_ids :: Maybe FuncCall , type_classes :: TypeClasses - , symbolic_ids :: SymbolicIds , exec_stack :: Stack Frame , model :: Model , known_values :: KnownValues , rules :: ![Rule] , num_steps :: !Int -- Invariant: The length of the rules list , tags :: S.HashSet Name -- ^ Allows attaching tags to a State, to identify it later + , sym_gens :: S.Seq Name -- ^ Variable names generated by logging `SymGen`s , track :: t - } deriving (Show, Eq, Read, Typeable, Data) + } deriving (Show, Eq, Read, Generic, Typeable, Data) +instance Hashable t => Hashable (State t) + +-- | Global information, shared between all `State`s. data Bindings = Bindings { deepseq_walkers :: Walkers , fixed_inputs :: [Expr] , arb_value_gen :: ArbValueGen , cleaned_names :: CleanedNames - , higher_order_inst :: [Name] -- ^ Functions to try instantiating higher order functions with + , higher_order_inst :: S.HashSet Name -- ^ Functions to try instantiating higher order functions with , input_names :: [Name] , rewrite_rules :: ![RewriteRule] , name_gen :: NameGen + , exported_funcs :: [Name] } deriving (Show, Eq, Read, Typeable, Data) -- | The `InputIds` are a list of the variable names passed as input to the @@ -75,14 +85,16 @@ Just e -> Id n (typeOf e) Nothing -> error "inputIds: Name not found in ExprEnv") ns --- | The `SymbolicIds` are a list of the variable names that we should ensure are --- inserted in the model, after we solve the path constraints -type SymbolicIds = [Id] - -- | `CurrExpr` is the current expression we have. data CurrExpr = CurrExpr EvalOrReturn Expr - deriving (Show, Eq, Read, Typeable, Data) + deriving (Show, Eq, Read, Generic, Typeable, Data) +instance Hashable CurrExpr + +-- | Gets the `Expr` represented by a state. +getExpr :: State t -> Expr +getExpr (State { curr_expr = CurrExpr _ e }) = e + -- | Tracks whether the `CurrExpr` is being evaluated, or if -- it is in some terminal form that is simply returned. Technically we do not -- need to make this distinction, and could simply call a `isTerm` function @@ -90,9 +102,12 @@ -- evaluation code. data EvalOrReturn = Evaluate | Return - deriving (Show, Eq, Read, Typeable, Data) + deriving (Show, Eq, Read, Generic, Typeable, Data) --- Used to map names (typically of ADTs) to corresponding autogenerated function names +instance Hashable EvalOrReturn + +-- | Used to map names of `Type`s to corresponding autogenerated functions +-- that force that `Type` to be evaluated. type Walkers = M.Map Name Id -- Map new names to old ones @@ -105,65 +120,47 @@ , boolGen :: Bool } deriving (Show, Eq, Read, Typeable, Data) --- | Naive expression lookup by only the occurrence name string. -naiveLookup :: T.Text -> E.ExprEnv -> [(Name, Expr)] -naiveLookup key = filter (\(Name occ _ _ _, _) -> occ == key) . E.toExprList - --- | These are stack frames. They are used to guide evaluation. -data Frame = CaseFrame Id [Alt] +-- | These are stack frames that are used to guide evaluation. +data Frame = CaseFrame Id Type [Alt] | ApplyFrame Expr | UpdateFrame Name | CastFrame Coercion - | CurrExprFrame CurrExpr + | CurrExprFrame CEAction CurrExpr | AssumeFrame Expr | AssertFrame (Maybe FuncCall) Expr - deriving (Show, Eq, Read, Typeable, Data) + deriving (Show, Eq, Read, Generic, Typeable, Data) +instance Hashable Frame + +-- | What to do with the current expression when a @CurrExprFrame@ reaches the +-- top of the stack and it is time to replace the `curr_expr`. +data CEAction = EnsureEq Expr -- ^ `EnsureEq e1` means that we should check if the `curr_expr` is equal to `e1` + | NoAction -- ^ Just replace the curr_expr, no other actions are needed + deriving (Show, Eq, Read, Generic, Typeable, Data) + +instance Hashable CEAction + -- | A model is a mapping of symbolic variable names to `Expr`@s@, -- typically produced by a solver. -type Model = M.Map Name Expr - --- | Replaces all of the names old in state with a name seeded by new_seed -renameState :: Named t => Name -> Name -> State t -> Bindings -> (State t, Bindings) -renameState old new_seed s b = - let (new, ng') = freshSeededName new_seed (name_gen b) - in (State { expr_env = rename old new (expr_env s) - , type_env = - M.mapKeys (\k -> if k == old then new else k) - $ rename old new (type_env s) - , curr_expr = rename old new (curr_expr s) - , path_conds = rename old new (path_conds s) - , non_red_path_conds = rename old new (non_red_path_conds s) - , true_assert = true_assert s - , assert_ids = rename old new (assert_ids s) - , type_classes = rename old new (type_classes s) - , symbolic_ids = rename old new (symbolic_ids s) - , exec_stack = exec_stack s - , model = model s - , known_values = rename old new (known_values s) - , rules = rules s - , num_steps = num_steps s - , track = rename old new (track s) - , tags = tags s } - , b { name_gen = ng'}) +type Model = HM.HashMap Name Expr instance Named t => Named (State t) where names s = names (expr_env s) - ++ names (type_env s) - ++ names (curr_expr s) - ++ names (path_conds s) - ++ names (assert_ids s) - ++ names (type_classes s) - ++ names (symbolic_ids s) - ++ names (exec_stack s) - ++ names (model s) - ++ names (known_values s) - ++ names (track s) + <> names (type_env s) + <> names (curr_expr s) + <> names (path_conds s) + <> names (assert_ids s) + <> names (type_classes s) + <> names (exec_stack s) + <> names (model s) + <> names (known_values s) + <> names (track s) + <> names (sym_gens s) rename old new s = State { expr_env = rename old new (expr_env s) , type_env = - M.mapKeys (\k -> if k == old then new else k) + HM.mapKeys (\k -> if k == old then new else k) $ rename old new (type_env s) , curr_expr = rename old new (curr_expr s) , path_conds = rename old new (path_conds s) @@ -171,19 +168,19 @@ , true_assert = true_assert s , assert_ids = rename old new (assert_ids s) , type_classes = rename old new (type_classes s) - , symbolic_ids = rename old new (symbolic_ids s) , exec_stack = rename old new (exec_stack s) , model = rename old new (model s) , known_values = rename old new (known_values s) , rules = rules s , num_steps = num_steps s , track = rename old new (track s) + , sym_gens = rename old new (sym_gens s) , tags = tags s } renames hm s = State { expr_env = renames hm (expr_env s) , type_env = - M.mapKeys (renames hm) + HM.mapKeys (renames hm) $ renames hm (type_env s) , curr_expr = renames hm (curr_expr s) , path_conds = renames hm (path_conds s) @@ -191,13 +188,13 @@ , true_assert = true_assert s , assert_ids = renames hm (assert_ids s) , type_classes = renames hm (type_classes s) - , symbolic_ids = renames hm (symbolic_ids s) , exec_stack = renames hm (exec_stack s) , model = renames hm (model s) , known_values = renames hm (known_values s) , rules = rules s , num_steps = num_steps s , track = renames hm (track s) + , sym_gens = renames hm (sym_gens s) , tags = tags s } instance ASTContainer t Expr => ASTContainer (State t) Expr where @@ -206,18 +203,20 @@ (containedASTs $ curr_expr s) ++ (containedASTs $ path_conds s) ++ (containedASTs $ assert_ids s) ++ - (containedASTs $ symbolic_ids s) ++ (containedASTs $ exec_stack s) ++ - (containedASTs $ track s) + (containedASTs $ track s) ++ + (containedASTs $ sym_gens s) ++ + (containedASTs $ rules s) modifyContainedASTs f s = s { type_env = modifyContainedASTs f $ type_env s , expr_env = modifyContainedASTs f $ expr_env s , curr_expr = modifyContainedASTs f $ curr_expr s , path_conds = modifyContainedASTs f $ path_conds s , assert_ids = modifyContainedASTs f $ assert_ids s - , symbolic_ids = modifyContainedASTs f $ symbolic_ids s , exec_stack = modifyContainedASTs f $ exec_stack s - , track = modifyContainedASTs f $ track s } + , track = modifyContainedASTs f $ track s + , sym_gens = modifyContainedASTs f $ sym_gens s + , rules = modifyContainedASTs f $ rules s } instance ASTContainer t Type => ASTContainer (State t) Type where containedASTs s = ((containedASTs . expr_env) s) ++ @@ -226,9 +225,10 @@ ((containedASTs . path_conds) s) ++ ((containedASTs . assert_ids) s) ++ ((containedASTs . type_classes) s) ++ - ((containedASTs . symbolic_ids) s) ++ ((containedASTs . exec_stack) s) ++ - (containedASTs $ track s) + (containedASTs $ track s) ++ + (containedASTs $ sym_gens s) ++ + (containedASTs $ rules s) modifyContainedASTs f s = s { type_env = (modifyContainedASTs f . type_env) s , expr_env = (modifyContainedASTs f . expr_env) s @@ -236,16 +236,19 @@ , path_conds = (modifyContainedASTs f . path_conds) s , assert_ids = (modifyContainedASTs f . assert_ids) s , type_classes = (modifyContainedASTs f . type_classes) s - , symbolic_ids = (modifyContainedASTs f . symbolic_ids) s , exec_stack = (modifyContainedASTs f . exec_stack) s - , track = modifyContainedASTs f $ track s } + , track = modifyContainedASTs f $ track s + , sym_gens = modifyContainedASTs f $ sym_gens s + , rules = modifyContainedASTs f $ rules s } instance Named Bindings where names b = names (fixed_inputs b) - ++ names (deepseq_walkers b) - ++ names (cleaned_names b) - ++ names (higher_order_inst b) - ++ names (input_names b) + <> names (deepseq_walkers b) + <> names (cleaned_names b) + <> names (higher_order_inst b) + <> names (input_names b) + <> names (exported_funcs b) + <> names (rewrite_rules b) rename old new b = Bindings { fixed_inputs = rename old new (fixed_inputs b) @@ -256,6 +259,7 @@ , input_names = rename old new (input_names b) , rewrite_rules = rename old new (rewrite_rules b) , name_gen = name_gen b + , exported_funcs = rename old new (exported_funcs b) } renames hm b = @@ -267,6 +271,7 @@ , input_names = renames hm (input_names b) , rewrite_rules = renames hm (rewrite_rules b) , name_gen = name_gen b + , exported_funcs = renames hm (exported_funcs b) } instance ASTContainer Bindings Expr where @@ -290,32 +295,32 @@ modifyContainedASTs f (CurrExpr er e) = CurrExpr er (modifyContainedASTs f e) instance ASTContainer Frame Expr where - containedASTs (CaseFrame _ a) = containedASTs a + containedASTs (CaseFrame _ _ a) = containedASTs a containedASTs (ApplyFrame e) = [e] - containedASTs (CurrExprFrame e) = containedASTs e + containedASTs (CurrExprFrame _ e) = containedASTs e containedASTs (AssumeFrame e) = [e] containedASTs (AssertFrame _ e) = [e] containedASTs _ = [] - modifyContainedASTs f (CaseFrame i a) = CaseFrame i (modifyContainedASTs f a) + modifyContainedASTs f (CaseFrame i t a) = CaseFrame i t (modifyContainedASTs f a) modifyContainedASTs f (ApplyFrame e) = ApplyFrame (f e) - modifyContainedASTs f (CurrExprFrame e) = CurrExprFrame (modifyContainedASTs f e) + modifyContainedASTs f (CurrExprFrame act e) = CurrExprFrame act (modifyContainedASTs f e) modifyContainedASTs f (AssumeFrame e) = AssumeFrame (f e) modifyContainedASTs f (AssertFrame is e) = AssertFrame is (f e) modifyContainedASTs _ fr = fr instance ASTContainer Frame Type where - containedASTs (CaseFrame i a) = containedASTs i ++ containedASTs a + containedASTs (CaseFrame i t a) = containedASTs i ++ containedASTs t ++ containedASTs a containedASTs (ApplyFrame e) = containedASTs e - containedASTs (CurrExprFrame e) = containedASTs e + containedASTs (CurrExprFrame _ e) = containedASTs e containedASTs (AssumeFrame e) = containedASTs e containedASTs (AssertFrame _ e) = containedASTs e containedASTs _ = [] - modifyContainedASTs f (CaseFrame i a) = - CaseFrame (modifyContainedASTs f i) (modifyContainedASTs f a) + modifyContainedASTs f (CaseFrame i t a) = + CaseFrame (modifyContainedASTs f i) (f t) (modifyContainedASTs f a) modifyContainedASTs f (ApplyFrame e) = ApplyFrame (modifyContainedASTs f e) - modifyContainedASTs f (CurrExprFrame e) = CurrExprFrame (modifyContainedASTs f e) + modifyContainedASTs f (CurrExprFrame act e) = CurrExprFrame act (modifyContainedASTs f e) modifyContainedASTs f (AssumeFrame e) = AssumeFrame (modifyContainedASTs f e) modifyContainedASTs f (AssertFrame is e) = AssertFrame (modifyContainedASTs f is) (modifyContainedASTs f e) modifyContainedASTs _ fr = fr @@ -326,26 +331,26 @@ renames hm (CurrExpr er e) = CurrExpr er $ renames hm e instance Named Frame where - names (CaseFrame i a) = names i ++ names a + names (CaseFrame i t a) = names i <> names t <> names a names (ApplyFrame e) = names e - names (UpdateFrame n) = [n] + names (UpdateFrame n) = names n names (CastFrame c) = names c - names (CurrExprFrame e) = names e + names (CurrExprFrame _ e) = names e names (AssumeFrame e) = names e - names (AssertFrame is e) = names is ++ names e + names (AssertFrame is e) = names is <> names e - rename old new (CaseFrame i a) = CaseFrame (rename old new i) (rename old new a) + rename old new (CaseFrame i t a) = CaseFrame (rename old new i) (rename old new t) (rename old new a) rename old new (ApplyFrame e) = ApplyFrame (rename old new e) rename old new (UpdateFrame n) = UpdateFrame (rename old new n) rename old new (CastFrame c) = CastFrame (rename old new c) - rename old new (CurrExprFrame e) = CurrExprFrame (rename old new e) + rename old new (CurrExprFrame act e) = CurrExprFrame act (rename old new e) rename old new (AssumeFrame e) = AssumeFrame (rename old new e) rename old new (AssertFrame is e) = AssertFrame (rename old new is) (rename old new e) - renames hm (CaseFrame i a) = CaseFrame (renames hm i) (renames hm a) + renames hm (CaseFrame i t a) = CaseFrame (renames hm i) (renames hm t) (renames hm a) renames hm (ApplyFrame e) = ApplyFrame (renames hm e) renames hm (UpdateFrame n) = UpdateFrame (renames hm n) renames hm (CastFrame c) = CastFrame (renames hm c) - renames hm (CurrExprFrame e) = CurrExprFrame (renames hm e) + renames hm (CurrExprFrame act e) = CurrExprFrame act (renames hm e) renames hm (AssumeFrame e) = AssumeFrame (renames hm e) renames hm (AssertFrame is e) = AssertFrame (renames hm is) (renames hm e) diff --git a/src/G2/Language/Syntax.hs b/src/G2/Language/Syntax.hs --- a/src/G2/Language/Syntax.hs +++ b/src/G2/Language/Syntax.hs @@ -1,8 +1,9 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} --- Defines most of the central language in G2. This language closely resembles Core Haskell. --- The central datatypes are `Expr` and `Type`. +-- | Defines most of the central language in G2. This language closely resembles Core Haskell. +-- The central datatypes are `Expr` and t`Type`. + module G2.Language.Syntax ( module G2.Language.Syntax ) where @@ -11,11 +12,7 @@ import Data.Data import Data.Hashable import qualified Data.Text as T - --- | The native GHC definition states that a `Program` is a list of `Binds`. --- This is used only in the initial stages of the translation from GHC Core. --- We quickly shift to using a `State`. -type Program = [Binds] +import qualified GHC.Generics as GHC -- | Binds `Id`s to `Expr`s, primarily in @let@ `Expr`s type Binds = [(Id, Expr)] @@ -56,8 +53,8 @@ n `hashWithSalt` m `hashWithSalt` i --- | Pairing of a `Name` with a `Type` -data Id = Id Name Type deriving (Show, Eq, Read, Generic, Typeable, Data) +-- | Pairing of a `Name` with a t`Type` +data Id = Id Name Type deriving (Show, Eq, Read, Generic, Typeable, Data, Ord) instance Hashable Id @@ -68,80 +65,84 @@ instance Hashable LamUse +-- | Extract the `Name` from an `Id`. idName :: Id -> Name idName (Id name _) = name - -{-| This is the main data type for our expression language. - 1. @`Var` `Id`@ is a variable. Variables may be bound by a `Lam`, `Let` - or `Case` `Expr`, or be bound in the `ExprEnv`. A variable may also be - free (unbound), in which case it is symbolic - - 2. @`Lit` `Lit`@ denotes a literal. - - 3. @`Data` `DataCon`@ denotes a Data Constructor - - 4. @`App` `Expr` `Expr`@ denotes function application. - For example, the function call: - - @ f x y @ - would be represented as - - @ `App` - (`App` - (`Var` (`Id` (`Name` "f" Nothing 0 Nothing) (`TyFun` t (`TyFun` t t)))) - (`Var` (`Id` (`Name` "x" Nothing 0 Nothing) t)) - ) - (`Var` (`Id` (`Name` "y" Nothing 0 Nothing) t)) @ - - 5. @`Lam` `LamUse` `Id` `Expr`@ denotes a lambda function. - The `Id` is bound in the `Expr`. - This binding may be on the type type or term level, depending on the `LamUse`. - - 6. @`Case` e i as@ splits into multiple `Alt`s (Alternatives), - Depending on the value of @e@. In each Alt, the `Id` @i@ is bound to @e@. - The `Alt`s must always be exhaustive- there should never be a case where no `Alt` - can match a given `Expr`. - - 7. @`Type` `Type`@ gives a `Expr` level representation of a `Type`. - These only ever appear as the arguments to polymorphic functions, - to determine the `Type` bound to type level variables. - - 8. @`Cast` e (t1 `:~` t2)@ casts @e@ from the type @t1@ to @t2@ - This requires that @t1@ and @t2@ have the same representation. - - 9. @`Coercion` `Coercion`@ allows runtime passing of `Coercion`s to `Cast`s. - - 10. @`Tick` `Tickish` `Expr`@ records some extra information into an `Expr`. - - 11. @`NonDet` [`Expr`] gives a nondeterministic choice between multiple options - to continue execution with. - - 12. @`SymGen` `Type`@ evaluates to a fresh symbolic variable of the given type. +-- | The `sym_gens` field of a `State` is used to record the values generated by certain `SymGen`s. +-- This allows us to track, and eventually print to display to the user, values generated by (certain) `SymGen`s. +-- `SymGen`s tagged with `SLog` are logged, i.e. will be recorded in the `sym_gens` field. Those tagged by `SNoLog` are not logged. +data SymLog = SLog | SNoLog + deriving (Show, Eq, Read, Generic, Typeable, Data) - 13. @`Assume` b e@ takes a boolean typed expression @b@, - and an expression of arbitrary type @e@. - During exectuion, @b@ is reduced to SWHNF, and assumed. - Then, execution continues with @b@. +instance Hashable SymLog - 14. @`Assert` fc b e@ is similar to `Assume`, but asserts the @b@ holds. - The `Maybe` `FuncCall` allows us to optionally indicate that the - assertion is related to a specific function. -} -data Expr = Var Id +-- | Expressions, representing G2's intermediate language. +data Expr = + -- | @`Var` `Id`@ is a variable. Variables may be bound by a `Lam`, `Let` + -- or `Case` `Expr`, or be bound in the `G2.Language.ExprEnv.ExprEnv`. A variable may also be + -- free (unbound), in which case it is symbolic + Var Id + -- | @v`Lit` t`Lit`@ denotes a literal. | Lit Lit + -- | Primitive functions. Should be wrapped in `App`s. | Prim Primitive Type + -- | @v`Data` `DataCon`@ denotes a Data Constructor | Data DataCon + {-| @`App` `Expr` `Expr`@ denotes function application. + For example, the function call: + + @ f x y @ + would be represented as + + @ `App` + (`App` + (`Var` (`Id` (`Name` "f" Nothing 0 Nothing) (`TyFun` t (`TyFun` t t)))) + (`Var` (`Id` (`Name` "x" Nothing 0 Nothing) t)) + ) + (`Var` (`Id` (`Name` "y" Nothing 0 Nothing) t)) @ + -} | App Expr Expr + -- | @`Lam` `LamUse` `Id` `Expr`@ denotes a lambda function. + -- The `Id` is bound in the `Expr`. + -- This binding may be on the type or term level, depending on the `LamUse`. | Lam LamUse Id Expr + -- | @`Let` b e@ gives a mapping of `Name`s to `Expr`s in `b`, allowing those names + -- to be used in `e`. | Let Binds Expr - | Case Expr Id [Alt] + -- | @`Case` e i as@ splits into multiple `Alt`s (Alternatives), + -- Depending on the value of @e@. In each Alt, the `Id` @i@ is bound to @e@. + -- The `Alt`s must always be exhaustive- there should never be a case where no `Alt` + -- can match a given `Expr`. + | Case Expr -- ^ Scrutinee + Id -- ^ Bindee + Type -- ^ Type of the case expression + [Alt] -- ^ Alternatives + + -- | @v`Type` t`Type`@ gives a `Expr` level representation of a t`Type`. + -- These only ever appear as the arguments to polymorphic functions, + -- to determine the t`Type` bound to type level variables. | Type Type + -- | @`Cast` e (t1 `:~` t2)@ casts @e@ from the t`Type` @t1@ to @t2@ + -- This requires that @t1@ and @t2@ have the same representation. | Cast Expr Coercion + -- | @v`Coercion` t`Coercion`@ allows runtime passing of t`Coercion`s to `Cast`s. | Coercion Coercion + -- | @`Tick` `Tickish` `Expr`@ records some extra information into an `Expr`. | Tick Tickish Expr + -- | @`NonDet` [`Expr`]@ gives a nondeterministic choice between multiple options + -- to continue execution with. | NonDet [Expr] - | SymGen Type + -- | @`SymGen` t`Type`@ evaluates to a fresh symbolic variable of the given type. + -- The `SymLog` determines whether the SymGen logs its generated value in the `State`s `sym_gens` field. + | SymGen SymLog Type + -- | @`Assume` b e@ takes a boolean typed expression @b@, and an expression of + -- arbitrary type @e@. During exectuion, @b@ is reduced to SWHNF, and assumed. + -- Then, execution continues with @b@. | Assume (Maybe FuncCall) Expr Expr + -- | @`Assert` fc b e@ is similar to `Assume`, but asserts the @b@ holds. + -- The `Maybe` `FuncCall` allows us to optionally indicate that the + -- assertion is related to a specific function. | Assert (Maybe FuncCall) Expr Expr deriving (Show, Eq, Read, Generic, Typeable, Data) @@ -156,7 +157,8 @@ -- And evaluation over literals can be peformed with the functions in: -- -- "G2.Execution.PrimitiveEval" -data Primitive = Ge +data Primitive = -- Mathematical and logical operators + Ge | Gt | Eq | Neq @@ -174,16 +176,36 @@ | DivInt | Quot | Mod + | Rem | Negate + | Abs | SqRt + + -- GHC conversions from data constructors to Int#, and vice versa + | DataToTag + | TagToEnum + + -- Numeric conversion | IntToFloat | IntToDouble + | RationalToDouble | FromInteger | ToInteger | ToInt + + -- String Handling + | StrLen + | StrAppend + | Chr + | OrdChar + | WGenCat + + -- Convert a positive Int to a String. (This matches the SMT Str.from_int function, which supports only positive Ints.) + | IntToString + + -- Errors | Error | Undefined - | BindFunc deriving (Show, Eq, Read, Generic, Typeable, Data) instance Hashable Primitive @@ -200,11 +222,15 @@ instance Hashable Lit -- | Data constructor. -data DataCon = DataCon Name Type deriving (Show, Eq, Read, Generic, Typeable, Data) +data DataCon = DataCon Name Type deriving (Show, Eq, Read, Generic, Typeable, Data, Ord) instance Hashable DataCon --- | AltMatches. +-- | Extract the `Name` of a `DataCon`. +dcName :: DataCon -> Name +dcName (DataCon n _) = n + +-- | Describe the conditions to match on a particular `Alt`. data AltMatch = DataAlt DataCon [Id] -- ^ Match a datacon. The number of `Id`s -- must match the number of term arguments -- for the datacon. @@ -217,62 +243,52 @@ -- | `Alt`s consist of the `AltMatch` that is used to match -- them, and the `Expr` that is evaluated provided that the `AltMatch` -- successfully matches. -data Alt = Alt AltMatch Expr deriving (Show, Eq, Read, Generic, Typeable, Data) +data Alt = Alt { altMatch :: AltMatch, altExpr :: Expr } deriving (Show, Eq, Read, Generic, Typeable, Data) instance Hashable Alt -altMatch :: Alt -> AltMatch -altMatch (Alt am _) = am - --- | Used in the `TyForAll`, to bind an `Id` to a `Type` -data TyBinder = AnonTyBndr Type - | NamedTyBndr Id - deriving (Show, Eq, Read, Generic, Typeable, Data) - -instance Hashable TyBinder - +-- | Concrete evidence of the equality or compatibility of two types. data Coercion = Type :~ Type deriving (Eq, Show, Read, Generic, Typeable, Data) instance Hashable Coercion --- | Types are decomposed as follows: --- * Type variables correspond to the aliasing of a type --- * TyLitInt, TyLitFloat etc denote unwrapped primitive types. --- * Function type. For instance (assume Int): \x -> x + 1 :: TyFun TyInt TyInt --- * Application, often reducible: (TyApp (TyFun TyInt TyInt) TyInt) :: TyInt --- * Type constructor (see below) application creates an actual type --- * For all types --- * BOTTOM -data Type = TyVar Id - | TyLitInt - | TyLitFloat - | TyLitDouble - | TyLitChar - | TyLitString - | TyFun Type Type - | TyApp Type Type - | TyCon Name Kind - | TyForAll TyBinder Type - | TyBottom +-- | Types information. +data Type = TyVar Id -- ^ Polymorphic type variable. + | TyLitInt -- ^ Unwrapped primitive Int type. + | TyLitFloat -- ^ Unwrapped primitive Float type. + | TyLitDouble -- ^ Unwrapped primitive Int type. + | TyLitChar -- ^ Unwrapped primitive Int type. + | TyLitString -- ^ Unwrapped primitive String type. + | TyFun Type Type -- ^ Function type. For instance (assume Int): \x -> x + 1 :: TyFun TyInt TyInt + | TyApp Type Type -- ^ Application of a type. + | TyCon Name Kind -- ^ Type constructor for a concrete type + | TyForAll Id Type -- ^ Introduces a type variable. + | TyBottom -- ^ Type for erroring/non-terminating expressions. | TYPE | TyUnknown - deriving (Show, Eq, Read, Generic, Typeable, Data) + deriving (Show, Eq, Read, Generic, Typeable, Data, Ord) +-- | A `Kind` is a t`Type` of a t`Type`. type Kind = Type instance Hashable Type +-- | A `Tickish` allows storing extra information in a `Tick`. data Tickish = Breakpoint Span -- ^ A breakpoint for the GHC Debugger + | HpcTick !Int T.Text -- ^ A tick used by HPC to track each subexpression in the original source code. + -- + -- Together, the `Int` identifier and the Module Name indicate a unique location. | NamedLoc Name -- ^ A G2 specific tick, intended to allow, - -- in concert with a @`Reducer`@, for domain + -- in concert with a @`G2.Execution.Reducer.Reducer`@, for domain -- specific modifications to a - -- @`State`@'s tracking field. + -- @`G2.Language.Support.State`@'s tracking field. deriving (Show, Eq, Read, Generic, Typeable, Data) instance Hashable Tickish -- | Represents a rewrite rule data RewriteRule = RewriteRule { ru_name :: T.Text + , ru_module :: T.Text , ru_head :: Name , ru_rough :: [Maybe Name] , ru_bndrs :: [Id] diff --git a/src/G2/Language/TypeClasses/Extra.hs b/src/G2/Language/TypeClasses/Extra.hs --- a/src/G2/Language/TypeClasses/Extra.hs +++ b/src/G2/Language/TypeClasses/Extra.hs @@ -1,12 +1,7 @@ module G2.Language.TypeClasses.Extra ( eqTCDict , numTCDict , ordTCDict - , integralTCDict - , structEqTCDict - , lookupStructEqDicts - , concreteSatEq - , concreteSatStructEq - , concreteSatTC ) where + , integralTCDict ) where import G2.Language.KnownValues import G2.Language.Syntax @@ -27,26 +22,3 @@ integralTCDict :: KnownValues -> TypeClasses -> Type -> Maybe Id integralTCDict kv tc t = lookupTCDict tc (integralTC kv) t - -structEqTCDict :: KnownValues -> TypeClasses -> Type -> Maybe Id -structEqTCDict kv tc t = lookupTCDict tc (structEqTC kv) t - -lookupStructEqDicts :: KnownValues -> TypeClasses -> Maybe [(Type, Id)] -lookupStructEqDicts kv = lookupTCDicts (structEqTC kv) - -concreteSatEq :: KnownValues -> TypeClasses -> Type -> Maybe Expr -concreteSatEq kv tc t = concreteSatTC tc (eqTC kv) t - -concreteSatStructEq :: KnownValues -> TypeClasses -> Type -> Maybe Expr -concreteSatStructEq kv tc t = concreteSatTC tc (structEqTC kv) t - -concreteSatTC :: TypeClasses -> Name -> Type -> Maybe Expr -concreteSatTC tc tcn t - | TyCon _ _ <- tyAppCenter t - , ts <- tyAppArgs t - , tcs <- map (concreteSatTC tc tcn) ts - , all (isJust) tcs = - case lookupTCDict tc tcn t of - Just i -> Just (foldl' App (Var i) $ map Type ts ++ map fromJust tcs) - Nothing -> Nothing -concreteSatTC tc tcn t = fmap Var (lookupTCDict tc tcn t) diff --git a/src/G2/Language/TypeClasses/TypeClasses.hs b/src/G2/Language/TypeClasses/TypeClasses.hs --- a/src/G2/Language/TypeClasses/TypeClasses.hs +++ b/src/G2/Language/TypeClasses/TypeClasses.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} @@ -12,10 +13,11 @@ , isTypeClass , lookupTCDict , lookupTCDicts + , lookupTCClass + , tcWithNameMap , tcDicts , typeClassInst , satisfyingTCTypes - , satisfyingTC , toMap) where import G2.Language.AST @@ -26,23 +28,35 @@ import Data.Coerce import Data.Data (Data, Typeable) +import Data.Hashable import Data.List -import qualified Data.Map as M +import qualified Data.Map.Lazy as MM +import qualified Data.HashMap.Lazy as M import Data.Maybe +import Data.Monoid ((<>)) +import qualified Data.Sequence as S +import GHC.Generics (Generic) -data Class = Class { insts :: [(Type, Id)], typ_ids :: [Id]} - deriving (Show, Eq, Read, Typeable, Data) +data Class = Class { insts :: [(Type, Id)], typ_ids :: [Id], superclasses :: [(Type, Id)]} + deriving (Show, Eq, Read, Typeable, Data, Generic) -type TCType = M.Map Name Class +instance Hashable Class + +type TCType = M.HashMap Name Class newtype TypeClasses = TypeClasses TCType - deriving (Show, Eq, Read, Typeable, Data) + deriving (Show, Eq, Read, Typeable, Data, Generic) -initTypeClasses :: [(Name, Id, [Id])] -> TypeClasses +instance Hashable TypeClasses + +initTypeClasses :: [(Name, Id, [Id], [(Type, Id)])] -> TypeClasses initTypeClasses nsi = let - ns = map (\(n, _, i) -> (n, i)) nsi + ns = map (\(n, _, i, sc) -> (n, i, sc)) nsi nsi' = filter (not . null . insts . snd) - $ map (\(n, i) -> (n, Class { insts = mapMaybe (nameIdToTypeId n) nsi, typ_ids = i } )) ns + $ map (\(n, i, sc) -> + (n, Class { insts = nub $ mapMaybe (nameIdToTypeId n) nsi + , typ_ids = i + , superclasses = sc } )) ns in coerce $ M.fromList nsi' @@ -52,39 +66,62 @@ unionTypeClasses :: TypeClasses -> TypeClasses -> TypeClasses unionTypeClasses (TypeClasses tc) (TypeClasses tc') = TypeClasses (M.union tc tc') -nameIdToTypeId :: Name -> (Name, Id, [Id]) -> Maybe (Type, Id) -nameIdToTypeId nm (n, i, _) = +nameIdToTypeId :: Name -> (Name, Id, [Id], [(Type, Id)]) -> Maybe (Type, Id) +nameIdToTypeId nm (n, i, _, _) = let t = affectedType $ returnType i in if n == nm then fmap (, i) t else Nothing affectedType :: Type -> Maybe Type -affectedType (TyApp (TyCon _ _) t) = Just t +affectedType (TyApp _ t) = Just t affectedType _ = Nothing +-- | Is there a typeclass with the given `Name`? isTypeClassNamed :: Name -> TypeClasses -> Bool isTypeClassNamed n = M.member n . (coerce :: TypeClasses -> TCType) +-- | Is the given type a type class? isTypeClass :: TypeClasses -> Type -> Bool isTypeClass tc (TyCon n _) = isTypeClassNamed n tc isTypeClass tc (TyApp t _) = isTypeClass tc t isTypeClass _ _ = False --- Returns the dictionary for the given typeclass and Type, --- if one exists -lookupTCDict :: TypeClasses -> Name -> Type -> Maybe Id +-- | Returns the dictionary for the given typeclass and Type, +-- if one exists. +lookupTCDict :: TypeClasses + -> Name -- ^ `Name` of the typeclass to look for + -> Type -- ^ The `Type` you want a dictionary for + -> Maybe Id lookupTCDict tc n t = case fmap insts $ M.lookup n (toMap tc) of Just c -> fmap snd $ find (\(t', _) -> PresType t .:: t') c Nothing -> Nothing +-- | Given a typeclass `Name`, gives an association list of +-- `Type`s that have instances of that typeclass, and the +-- typeclass dictionaries. lookupTCDicts :: Name -> TypeClasses -> Maybe [(Type, Id)] lookupTCDicts n = fmap insts . M.lookup n . coerce -lookupTCDictsTypes :: TypeClasses -> Name -> Maybe [Type] -lookupTCDictsTypes tc = fmap (map fst) . flip lookupTCDicts tc +lookupTCClass :: Name -> TypeClasses -> Maybe Class +lookupTCClass n = M.lookup n . coerce +tcWithNameMap :: Name -> [Id] -> M.HashMap Name Id +tcWithNameMap n = + M.fromList + . map (\i -> (forType $ typeOf i, i)) + . filter (isTC . typeOf) + where + forType :: Type -> Name + forType (TyApp _ (TyVar (Id n' _))) = n' + forType _ = error "Bad type in forType" + + isTC :: Type -> Bool + isTC t = case tyAppCenter t of + TyCon n' _ -> n == n' + _ -> False + -- tcDicts tcDicts :: TypeClasses -> [Id] tcDicts = map snd . concatMap insts . M.elems . coerce @@ -96,12 +133,12 @@ -- Given a TypeClass name, a type that you want an instance of that typeclass -- for, and a mapping of TyVar name's to Id's for those types instances of -- the typeclass, returns an instance of the typeclass, if possible -typeClassInst :: TypeClasses -> M.Map Name Id -> Name -> Type -> Maybe Expr +typeClassInst :: TypeClasses -> M.HashMap Name Id -> Name -> Type -> Maybe Expr typeClassInst tc m tcn t | tca@(TyCon _ _) <- tyAppCenter t , ts <- tyAppArgs t , tcs <- map (typeClassInst tc m tcn) ts - , all (isJust) tcs = + , all isJust tcs = case lookupTCDict tc tcn tca of Just i -> Just (foldl' App (Var i) $ map Type ts ++ map fromJust tcs) Nothing -> Nothing @@ -114,19 +151,27 @@ Nothing -> Nothing typeClassInst _ _ _ _ = Nothing --- satisfyingTCTypes --- Finds types/dict pairs that satisfy the given TC requirements for the given polymorphic argument --- returns a list of acceptable types -satisfyingTCTypes :: KnownValues -> TypeClasses -> Id -> [Type] -> [Type] +-- | Finds `Type`s that satisfy the given typeclass requirements for the given polymorphic argument. +-- Returns "Int" by default if there are no typeclass requirements. +satisfyingTCTypes :: KnownValues + -> TypeClasses + -> Id -- ^ The type variable to look for possible instantiations of + -> [Type] -- ^ Function arguments to satisfy typeclass requirements for + -> [Type] satisfyingTCTypes kv tc i ts = let tcReq = satisfyTCReq tc i ts in - substKind i . inter kv $ mapMaybe (lookupTCDictsTypes tc) tcReq - -inter :: KnownValues -> [[Type]] -> [Type] -inter kv [] = [tyInt kv] -inter _ xs = foldr1 intersect xs + case mapMaybe lookupTCDictsTypes tcReq of + [] -> [tyInt kv] + xs -> substKind i $ foldr1 intersect xs + where + lookupTCDictsTypes (TyApp t1 t2) = + fmap (mapMaybe (\t' -> MM.lookup (idName i) =<< specializes t' t2)) + . fmap (map fst) + . flip lookupTCDicts tc + =<< (tyConAppName . tyAppCenter $ t1) + lookupTCDictsTypes _ = Nothing substKind :: Id -> [Type] -> [Type] substKind (Id _ t) ts = map (\t' -> case t' of @@ -137,29 +182,16 @@ tyFunToTyApp (TyFun t1 (TyFun t2 t3)) = TyApp (TyApp (tyFunToTyApp t1) (tyFunToTyApp t2)) (tyFunToTyApp t3) tyFunToTyApp t = modifyChildren tyFunToTyApp t --- satisfyingTCReq --- Finds the names of the required typeclasses for a TyVar Id --- See satisfyingTCTypes -satisfyTCReq :: TypeClasses -> Id -> [Type] -> [Name] -satisfyTCReq tc i = - mapMaybe (tyConAppName . tyAppCenter) . filter (isFor i) . filter (isTypeClass tc) +-- | Finds the names of the required typeclasses for a TyVar Id +satisfyTCReq :: TypeClasses -> Id -> [Type] -> [Type] +satisfyTCReq tc (Id n _) = filter isFor . filter (isTypeClass tc) where - isFor :: Id -> Type -> Bool - isFor ii (TyApp (TyCon _ _) a) = ii `elem` tyVarIds a - isFor _ _ = False - --- Given a list of type arguments and a mapping of TyVar Ids to actual Types --- Gives the required TC's to pass to any TC arguments -satisfyingTC :: TypeClasses -> [Type] -> Id -> Type -> [Expr] -satisfyingTC tc ts i t = - let - tcReq = satisfyTCReq tc i ts - in - map (\n -> case lookupTCDict tc n t of - Just i' -> Var i' - Nothing -> error "No typeclass found.") tcReq + isFor :: Type -> Bool + isFor (TyVar (Id n' _)) = n == n' + isFor (TyApp a1 a2) = isFor a1 || isFor a2 + isFor _ = False -toMap :: TypeClasses -> M.Map Name Class +toMap :: TypeClasses -> M.HashMap Name Class toMap = coerce instance ASTContainer TypeClasses Expr where @@ -176,20 +208,23 @@ modifyContainedASTs _ = id instance ASTContainer Class Type where - containedASTs = containedASTs . insts + containedASTs c = (containedASTs . insts $ c) ++ containedASTs (superclasses c) modifyContainedASTs f c = Class { insts = modifyContainedASTs f $ insts c - , typ_ids = modifyContainedASTs f $ typ_ids c} + , typ_ids = modifyContainedASTs f $ typ_ids c + , superclasses = modifyContainedASTs f $ superclasses c} instance Named TypeClasses where - names = names . (coerce :: TypeClasses -> TCType) + names (TypeClasses tc) = S.fromList (M.keys tc) <> names tc rename old new (TypeClasses m) = coerce $ M.mapKeys (rename old new) $ rename old new m renames hm (TypeClasses m) = coerce $ M.mapKeys (renames hm) $ renames hm m instance Named Class where - names = names . insts + names (Class { insts = i, typ_ids = tids, superclasses = sc }) = names i <> names tids <> names sc rename old new c = Class { insts = rename old new $ insts c - , typ_ids = rename old new $ typ_ids c } + , typ_ids = rename old new $ typ_ids c + , superclasses = rename old new $ superclasses c } renames hm c = Class { insts = renames hm $ insts c - , typ_ids = renames hm $ typ_ids c } + , typ_ids = renames hm $ typ_ids c + , superclasses = renames hm $ superclasses c } diff --git a/src/G2/Language/TypeEnv.hs b/src/G2/Language/TypeEnv.hs --- a/src/G2/Language/TypeEnv.hs +++ b/src/G2/Language/TypeEnv.hs @@ -6,25 +6,11 @@ , nameModMatch , argTypesTEnv - , dataCon - , boundIds - , isPolyAlgDataTy - , isDataTyCon - , isNewTyCon - , newTyConRepType - , typeStripCastType , getDataCons - , baseDataCons , getCastedAlgDataTy , getAlgDataTy , getDataCon - , getDataConNoType , getDataConNameMod - , getDataConNameMod' - , dataConArgs - , dataConWithName - , dcName - , retypeAlgDataTy , module G2.Language.AlgDataTy ) where @@ -34,18 +20,17 @@ import G2.Language.AlgDataTy import Data.List -import qualified Data.Map as M -import Data.Maybe +import qualified Data.HashMap.Lazy as M -- | The type environment maps names of types to their appropriate types. However -- our primary interest with these is for dealing with algebraic data types, -- and we only store those information accordingly. -type TypeEnv = M.Map Name AlgDataTy +type TypeEnv = M.HashMap Name AlgDataTy nameModMatch :: Name -> TypeEnv -> Maybe Name nameModMatch (Name n m _ _) = find (\(Name n' m' _ _) -> n == n' && m == m' ) . M.keys --- Returns a list of all argument function types in the type env +-- | Returns a list of all argument function types in the `TypeEnv` argTypesTEnv :: TypeEnv -> [Type] argTypesTEnv = concatMap (evalASTs argTypesTEnv') . M.elems @@ -53,53 +38,10 @@ argTypesTEnv' (TyFun t@(TyFun _ _) _) = [t] argTypesTEnv' _ = [] -dataCon :: AlgDataTy -> [DataCon] -dataCon (DataTyCon {data_cons = dc}) = dc -dataCon (NewTyCon {data_con = dc}) = [dc] -dataCon (TypeSynonym {}) = [] - -boundIds :: AlgDataTy -> [Id] -boundIds = bound_ids - -dcName :: DataCon -> Name -dcName (DataCon n _) = n - -isPolyAlgDataTy :: AlgDataTy -> Bool -isPolyAlgDataTy = not . null . bound_ids - -isDataTyCon :: AlgDataTy -> Bool -isDataTyCon (DataTyCon {}) = True -isDataTyCon _ = False - -isNewTyCon :: AlgDataTy -> Bool -isNewTyCon (NewTyCon {}) = True -isNewTyCon _ = False - -newTyConRepType :: AlgDataTy -> Maybe Type -newTyConRepType (NewTyCon {rep_type = t}) = Just t -newTyConRepType _ = Nothing - -typeStripCastType :: TypeEnv -> Type -> Type -typeStripCastType tenv t - | Just (adt, _) <- getCastedAlgDataTy t tenv - , Just rt <- newTyConRepType adt = rt -typeStripCastType _ t = t - getDataCons :: Name -> TypeEnv -> Maybe [DataCon] -getDataCons n tenv = - case M.lookup n tenv of - Just (DataTyCon _ dc) -> Just dc - Just (NewTyCon _ dc _) -> Just [dc] - Just (TypeSynonym _ (TyCon n' _)) -> getDataCons n' tenv - _ -> Nothing - -baseDataCons :: [DataCon] -> [DataCon] -baseDataCons = filter baseDataCon - -baseDataCon :: DataCon -> Bool -baseDataCon (DataCon _ t) = not $ hasTyFuns t +getDataCons n tenv = dataCon <$> M.lookup n tenv --- If the Type is a TyCon, (optionally) wrapped with TyApps, +-- | If the Type is a TyCon, (optionally) wrapped with TyApps, -- returns the AlgDataTy of the Cast type, along with mappings from -- the bound names of the cast type, to the types bound by the TyApps. getCastedAlgDataTy :: Type -> TypeEnv -> Maybe (AlgDataTy, [(Id, Type)]) @@ -131,42 +73,18 @@ _ -> Nothing getDataCon :: TypeEnv -> Name -> Name -> Maybe DataCon -getDataCon tenv adt dc = - let - adt' = M.lookup adt tenv - in - maybe Nothing (flip dataConWithName dc) adt' - -getDataConNoType :: TypeEnv -> Name -> Maybe DataCon -getDataConNoType tenv n = find (\dc -> dcName dc == n) . concatMap dataCon $ M.elems tenv +getDataCon tenv adt dc = flip dataConWithName dc =<< M.lookup adt tenv getDataConNameMod :: TypeEnv -> Name -> Name -> Maybe DataCon getDataConNameMod tenv (Name n m _ _) dc = let adt' = fmap snd $ find (\(Name n' m' _ _, _) -> n == n' && m == m') $ M.toList tenv in - maybe Nothing (flip dataConWithNameMod dc) adt' - -getDataConNameMod' :: TypeEnv -> Name -> Maybe DataCon -getDataConNameMod' tenv n = find (flip dataConHasNameMod n) $ concatMap dataCon $ M.elems tenv - -dataConArgs :: DataCon -> [Type] -dataConArgs dc = anonArgumentTypes dc - -dataConWithName :: AlgDataTy -> Name -> Maybe DataCon -dataConWithName (DataTyCon _ dcs) n = listToMaybe $ filter (flip dataConHasName n) dcs -dataConWithName _ _ = Nothing - -dataConHasName :: DataCon -> Name -> Bool -dataConHasName (DataCon n _) n' = n == n' + flip dataConWithNameMod dc =<< adt' dataConWithNameMod :: AlgDataTy -> Name -> Maybe DataCon -dataConWithNameMod (DataTyCon _ dcs) n = listToMaybe $ filter (flip dataConHasNameMod n) dcs +dataConWithNameMod (DataTyCon _ dcs) n = find (`dataConHasNameMod` n) dcs dataConWithNameMod _ _ = Nothing dataConHasNameMod :: DataCon -> Name -> Bool dataConHasNameMod (DataCon (Name n m _ _) _) (Name n' m' _ _) = n == n' && m == m' - -retypeAlgDataTy :: [Type] -> AlgDataTy -> AlgDataTy -retypeAlgDataTy ts adt = - foldr (uncurry retype) adt $ zip (bound_ids adt) ts diff --git a/src/G2/Language/Typing.hs b/src/G2/Language/Typing.hs --- a/src/G2/Language/Typing.hs +++ b/src/G2/Language/Typing.hs @@ -7,11 +7,19 @@ module G2.Language.Typing ( Typed (..) , PresType (..) + + , checkType + , tyInt , tyInteger , tyDouble , tyFloat , tyBool + , tyChar + , tyRational + , tyList + , tyMaybe + , tyUnit , mkTyApp , mkTyFun , tyAppCenter @@ -22,20 +30,21 @@ , (.::) , (.::.) , specializes + , specializes' , hasFuncType - , appendType , higherOrderFuncs , isTYPE , isTyFun , hasTYPE , isTyVar - , hasTyBottom - , tyVars , tyVarIds , tyVarNames - , hasTyFuns - , isPolyFunc , numArgs + + , replaceTyVar + , applyTypeMap + , applyTypeHashMap + , ArgType (..) , argumentTypes , argTypeToType @@ -45,25 +54,31 @@ , tyForAllBindings , anonArgumentTypes , returnType - , polyIds , splitTyForAlls , splitTyFuns , retype + , retypeRespectingTyForAll , mapInTyForAlls , inTyForAlls , numTypeArgs , typeToExpr , getTyApps , tyAppsToExpr + , isADTType + , isPrimType ) where +import qualified G2.Data.UFMap as UF import G2.Language.AST import qualified G2.Language.KnownValues as KV import G2.Language.Syntax +import qualified Data.HashMap.Lazy as HM import qualified Data.Map as M +import Data.Maybe import qualified Data.List as L import Data.Monoid hiding (Alt) +import Control.Monad tyInt :: KV.KnownValues -> Type tyInt kv = TyCon (KV.tyInt kv) (tyTYPE kv) @@ -80,11 +95,25 @@ tyBool :: KV.KnownValues -> Type tyBool kv = TyCon (KV.tyBool kv) (tyTYPE kv) +tyChar :: KV.KnownValues -> Type +tyChar kv = TyCon (KV.tyChar kv) (tyTYPE kv) + +tyRational :: KV.KnownValues -> Type +tyRational kv = TyCon (KV.tyRational kv) (tyTYPE kv) + +tyList :: KV.KnownValues -> Type +tyList kv = TyCon (KV.tyList kv) (TyFun TYPE TYPE) + +tyMaybe :: KV.KnownValues -> Type +tyMaybe kv = TyCon (KV.tyMaybe kv) (TyFun TYPE TYPE) + +tyUnit :: KV.KnownValues -> Type +tyUnit kv = TyCon (KV.tyUnit kv) (TyFun TYPE TYPE) + tyTYPE :: KV.KnownValues -> Type tyTYPE _ = TYPE --- | mkTyFun --- Turns the Expr list into an application spine +-- | Turns the Expr list into an application spine mkTyFun :: [Type] -> Type mkTyFun [] = error "mkTyFun: empty list" mkTyFun [t] = t @@ -122,13 +151,12 @@ in mkTyApp $ TyCon n tsk:ts --- | unTyApp --- Unravels the application spine. +-- | Unravels the application spine of (nested) `TyApp`s. unTyApp :: Type -> [Type] unTyApp (TyApp t t') = unTyApp t ++ [t'] unTyApp t = [t] --- | Typed typeclass. +-- | Typeclass for things that have type information. class Typed a where typeOf :: a -> Type typeOf = typeOf' M.empty @@ -167,18 +195,17 @@ appTypeOf M.empty t as typeOf' m (Lam u b e) = case u of - TypeL -> TyForAll (NamedTyBndr b) (typeOf' m e) + TypeL -> TyForAll b (typeOf' m e) TermL -> TyFun (typeOf' m b) (typeOf' m e) typeOf' m (Let _ expr) = typeOf' m expr - typeOf' m (Case _ _ (a:_)) = typeOf' m a - typeOf' _ (Case _ _ []) = TyBottom + typeOf' _ (Case _ _ t _) = t typeOf' _ (Type _) = TYPE typeOf' m (Cast _ (_ :~ t')) = tyVarRename m t' typeOf' m (Coercion (_ :~ t')) = tyVarRename m t' typeOf' m (Tick _ e) = typeOf' m e typeOf' m (NonDet (e:_)) = typeOf' m e typeOf' _ (NonDet []) = TyBottom - typeOf' _ (SymGen t) = t + typeOf' _ (SymGen _ t) = t typeOf' m (Assert _ _ e) = typeOf' m e typeOf' m (Assume _ _ e) = typeOf' m e @@ -194,20 +221,83 @@ appCenter e = e appTypeOf :: M.Map Name Type -> Type -> [Expr] -> Type -appTypeOf m (TyForAll (NamedTyBndr i) t) (Type t':es) = +appTypeOf m (TyForAll i t) (Type t':es) = let m' = M.insert (idName i) (tyVarRename m t') m in appTypeOf m' t es -appTypeOf m (TyForAll (NamedTyBndr _) t) (_:es) = appTypeOf m t es +appTypeOf m (TyForAll _ t) (_:es) = appTypeOf m t es appTypeOf m (TyFun _ t) (_:es) = appTypeOf m t es appTypeOf m t [] = tyVarRename m t appTypeOf m (TyVar (Id n _)) es = case M.lookup n m of Just t -> appTypeOf m t es Nothing -> error ("appTypeOf: Unknown TyVar") +appTypeOf _ TyBottom _ = TyBottom +appTypeOf _ TyUnknown _ = TyUnknown appTypeOf _ t es = error ("appTypeOf\n" ++ show t ++ "\n" ++ show es ++ "\n\n") +checkType :: Expr -> Maybe (UF.UFMap Name Type) +checkType = check' UF.empty + +check' :: UF.UFMap Name Type -> Expr -> Maybe (UF.UFMap Name Type) +check' uf (Var (Id _ _)) = Just uf +check' uf (Lit _) = Just uf +check' uf (Prim _ _) = Just uf +check' uf (Data _) = Just uf +check' uf (App e1 e2) = + let + t1 = case typeOf e1 of + TyFun t _ -> t + TyForAll (Id _ t) _ -> t + _ -> error "check: Unexpected type in App" + t2 = typeOf e2 + in + fmap snd (unify t1 t2 uf) >>= flip check' e1 >>= flip check' e2 +check' uf (Lam u b e) = check' uf e +check' uf (Let b e) = foldM check' uf (map snd b) >>= flip check' e +check' uf (Case e _ _ alts) = foldM check' uf (map altExpr alts) >>= flip check' e +check' uf (Type t) = Just uf +check' uf (Cast e (t :~ t')) = check' uf e +check' uf (Coercion (t :~ t')) = Just uf +check' uf (Tick _ t) = check' uf t +check' uf (NonDet es) = foldM check' uf es +check' uf (SymGen _ _) = Just uf +check' uf (Assert _ e1 e2) = check' uf e1 >>= flip check' e2 +check' uf (Assume _ e1 e2) = check' uf e1 >>= flip check' e2 +check' _ _ = error "check'" + +unify :: Type -> Type -> UF.UFMap Name Type -> Maybe (Type, UF.UFMap Name Type) +unify t@(TyVar (Id n1 _)) (TyVar (Id n2 _)) uf + | Just t1 <- UF.lookup n1 uf + , Just t2 <- UF.lookup n2 uf = + case unify t1 t2 uf of + Just (t, uf') -> Just (t, UF.join (\_ _ -> t) n1 n2 uf') + Nothing -> Nothing + | otherwise = Just (t, UF.join (error "unify: impossible, no need to join") n1 n2 uf) +unify (TyVar (Id n _)) t uf + | Just t1 <- UF.lookup n uf = unify t1 t uf + | otherwise = Just (t, UF.insert n t uf) +unify t (TyVar (Id n _)) uf + | Just t2 <- UF.lookup n uf = unify t t2 uf + | otherwise = Just (t, UF.insert n t uf) +unify (TyFun t1 t2) (TyFun t1' t2') uf = do + (ft1, uf') <- unify t1 t1' uf + (ft2, uf'') <- unify t2 t2' uf' + return (TyFun ft1 ft2, uf'') +unify (TyApp t1 t2) (TyApp t1' t2') uf = do + (ft1, uf') <- unify t1 t1' uf + (ft2, uf'') <- unify t2 t2' uf' + return (TyApp ft1 ft2, uf'') +unify (TyCon n1 k1) (TyCon n2 k2) uf | n1 == n2 = do + (fk, uf') <- unify k1 k2 uf + return (TyCon n1 fk, uf') +unify (TyForAll i t1) (TyForAll i2 t2) uf = do + (t, uf') <- unify t1 t2 uf + return (TyForAll i t, uf') +unify t1 t2 uf | t1 == t2 = return (t1, uf) + | otherwise = Nothing + instance Typed Type where typeOf' _ (TyVar (Id _ t)) = t typeOf' _ (TyFun _ _) = TYPE @@ -217,12 +307,12 @@ at = typeOf' m t2 in case (ft, at) of + ((TyForAll _ t2'), _) -> t2' ((TyFun _ t2'), _) -> t2' ((TyApp t1' _), _) -> t1' _ -> error $ "Overapplied Type\n" ++ show t1 ++ "\n" ++ show t2 ++ "\n\n" ++ show ft ++ "\n" ++ show at typeOf' _ (TyCon _ t) = t - typeOf' m (TyForAll (NamedTyBndr b) t) = TyApp (typeOf b) (typeOf' m t) - typeOf' m (TyForAll _ t) = typeOf' m t + typeOf' m (TyForAll b t) = TyApp (typeOf b) (typeOf' m t) typeOf' _ TyLitInt = TYPE typeOf' _ TyLitFloat = TYPE typeOf' _ TyLitDouble = TYPE @@ -245,12 +335,16 @@ retype' :: Id -> Type -> Type -> Type retype' key new (TyVar test) = if key == test then new else TyVar test -retype' key new (TyForAll (NamedTyBndr nid) ty) = - if key == nid - then modifyChildren (retype' key new) ty - else TyForAll (NamedTyBndr nid) (modifyChildren (retype' key new) ty) retype' key new ty = modifyChildren (retype' key new) ty +retypeRespectingTyForAll :: (ASTContainer m Type, Show m) => Id -> Type -> m -> m +retypeRespectingTyForAll key new = modifyContainedASTs (retypeRespectingTyForAll' key new) + +retypeRespectingTyForAll' :: Id -> Type -> Type -> Type +retypeRespectingTyForAll' i _ t@(TyForAll ni _) | i == ni = t +retypeRespectingTyForAll' key new (TyVar test) = if idName key == idName test then new else TyVar test +retypeRespectingTyForAll' key new ty = modifyChildren (retypeRespectingTyForAll' key new) ty + tyVarRename :: (ASTContainer t Type) => M.Map Name Type -> t -> t tyVarRename m = modifyASTs (tyVarRename' m) @@ -261,7 +355,7 @@ -- | Returns if the first type given is a specialization of the second, -- i.e. if given t1, t2, returns true iff t1 :: t2 (.::) :: Typed t => t -> Type -> Bool -t1 .:: t2 = fst $ specializes M.empty (typeOf t1) t2 +t1 .:: t2 = isJust $ specializes (typeOf t1) t2 {-# INLINE (.::) #-} -- | Checks if the first type is equivalent to the second type. @@ -270,58 +364,58 @@ t1 .::. t2 = PresType t1 .:: t2 && PresType t2 .:: t1 {-# INLINE (.::.) #-} -specializes :: M.Map Name Type -> Type -> Type -> (Bool, M.Map Name Type) -specializes m _ TYPE = (True, m) -specializes m t (TyVar (Id n _)) = +specializes :: Type -> Type -> Maybe (M.Map Name Type) +specializes = specializes' M.empty + +specializes' :: M.Map Name Type -> Type -> Type -> Maybe (M.Map Name Type) +specializes' m _ TYPE = Just m +specializes' m t (TyVar (Id n vt)) = case M.lookup n m of - Just (TyVar _) -> (True, m) - Just t' -> specializes m t t' - Nothing -> (True, M.insert n t m) -specializes m (TyFun t1 t2) (TyFun t1' t2') = - let - (b1, m') = specializes m t1 t1' - (b2, m'') = specializes m' t2 t2' - in - (b1 && b2, m'') -specializes m (TyApp t1 t2) (TyApp t1' t2') = - let - (b1, m') = specializes m t1 t1' - (b2, m'') = specializes m' t2 t2' - in - (b1 && b2, m'') -specializes m (TyCon n _) (TyCon n' _) = (n == n', m) -specializes m (TyFun t1 t2) (TyForAll (AnonTyBndr t1') t2') = - let - (b1, m') = specializes m t1 t1' - (b2, m'') = specializes m' t2 t2' - in (b1 && b2, m'') -specializes m (TyFun t1 t2) (TyForAll (NamedTyBndr _) t2') = - specializes m (TyFun t1 t2) t2' -specializes m (TyForAll (AnonTyBndr t1) t2) (TyFun t1' t2') = - let - (b1, m') = specializes m t1 t1' - (b2, m'') = specializes m' t2 t2' - in (b1 && b2, m'') -specializes m (TyForAll (AnonTyBndr t1) t2) (TyForAll (AnonTyBndr t1') t2') = - let - (b1, m') = specializes m t1 t1' - (b2, m'') = specializes m' t2 t2' - in (b1 && b2, m'') -specializes m (TyForAll (AnonTyBndr t1) t2) (TyForAll (NamedTyBndr _) t2') = - specializes m (TyForAll (AnonTyBndr t1) t2) t2' -specializes m (TyForAll (NamedTyBndr (Id _ t1)) t2) (TyForAll (NamedTyBndr (Id _ t1')) t2') = - let - (b1, m') = specializes m t1 t1' - (b2, m'') = specializes m' t2 t2' - in (b1 && b2, m'') -specializes m t (TyForAll _ t') = - specializes m t t' -specializes m TyUnknown _ = (True, m) -specializes m _ TyUnknown = (True, m) -specializes m TyBottom _ = (True, m) -specializes m _ TyBottom = (False, m) -specializes m t1 t2 = (t1 == t2, m) + Just t' | t == t' -> Just m + | otherwise -> Nothing + Nothing -> M.insert n t <$> specializes' m (typeOf t) vt +specializes' m (TyFun t1 t2) (TyFun t1' t2') = do + m' <- specializes' m t1 t1' + specializes' m' t2 t2' +specializes' m (TyApp t1 t2) (TyApp t1' t2') = do + m' <- specializes' m t1 t1' + specializes' m' t2 t2' +specializes' m (TyCon n _) (TyCon n' _) = if n == n' then Just m else Nothing +specializes' m (TyForAll (Id _ t1) t2) (TyForAll (Id _ t1') t2') = do + m' <- specializes' m t1 t1' + specializes' m' t2 t2' +specializes' m t (TyForAll _ t') = + specializes' m t t' +specializes' m TyUnknown _ = Just m +specializes' m _ TyUnknown = Just m +specializes' m TyBottom _ = Just m +specializes' _ _ TyBottom = Nothing +specializes' m t1 t2 = if t1 == t2 then Just m else Nothing +replaceTyVar :: ASTContainer e Type => Name -> Type -> e -> e +replaceTyVar n t = modifyASTs (replaceTyVar' n t) + +replaceTyVar' :: Name -> Type -> Type -> Type +replaceTyVar' n t (TyVar (Id n' _)) | n == n' = t +replaceTyVar' _ _ t = t + +applyTypeMap :: ASTContainer e Type => M.Map Name Type -> e -> e +applyTypeMap m = modifyASTs (applyTypeMap' m) + +applyTypeMap' :: M.Map Name Type -> Type -> Type +applyTypeMap' m (TyVar (Id n _)) + | Just t <- M.lookup n m = t +applyTypeMap' _ t = t + +applyTypeHashMap :: ASTContainer e Type => HM.HashMap Name Type -> e -> e +applyTypeHashMap m = modifyASTs (applyTypeHashMap' m) + +applyTypeHashMap' :: HM.HashMap Name Type -> Type -> Type +applyTypeHashMap' m (TyVar (Id n _)) + | Just t <- HM.lookup n m = t +applyTypeHashMap' _ t = t + + hasFuncType :: (Typed t) => t -> Bool hasFuncType t = case typeOf t of @@ -329,13 +423,6 @@ (TyForAll _ _) -> True _ -> False --- | appendType --- Converts the (function) type t1 to return t2 --- appendType (a -> b) c = (a -> b -> c) -appendType :: Type -> Type -> Type -appendType (TyFun t t1) t2 = TyFun t (appendType t1 t2) -appendType t1 t2 = TyFun t1 t2 - -- | higherOrderFuncs -- Returns all internal higher order function types higherOrderFuncs :: Typed t => t -> [Type] @@ -368,24 +455,6 @@ isTyFun (TyFun _ _) = True isTyFun _ = False --- | isPolyFunc --- Checks if the given function is a polymorphic function -isPolyFunc :: Typed t => t -> Bool -isPolyFunc = isPolyFunc' . typeOf - -isPolyFunc' :: Type -> Bool -isPolyFunc' (TyForAll _ _) = True -isPolyFunc' _ = False - --- tyVars --- Returns a list of all tyVars -tyVars :: ASTContainer m Type => m -> [Type] -tyVars = evalASTs tyVars' - -tyVars' :: Type -> [Type] -tyVars' t@(TyVar _) = [t] -tyVars' _ = [] - -- | Returns a list of all tyVars Ids tyVarIds :: ASTContainer m Type => m -> [Id] tyVarIds = evalASTs tyVarIds' @@ -398,35 +467,18 @@ tyVarNames :: ASTContainer m Type => m -> [Name] tyVarNames = map idName . tyVarIds --- | hasTyFuns -hasTyFuns :: ASTContainer m Type => m -> Bool -hasTyFuns = getAny . evalASTs hasTyFuns' - -hasTyFuns' :: Type -> Any -hasTyFuns' (TyFun _ _) = Any True -hasTyFuns' _ = Any False - --- hasTyBottom -hasTyBottom :: ASTContainer m Type => m -> Bool -hasTyBottom = getAny . evalASTs hasTyBottom' - -hasTyBottom' :: Type -> Any -hasTyBottom' TyBottom = Any True -hasTyBottom' _ = Any False - --- | numArgs +-- | Computes the number of type and value level arguments numArgs :: Typed t => t -> Int numArgs = length . argumentTypes -data ArgType = AnonType Type | NamedType Id +data ArgType = AnonType Type | NamedType Id deriving (Show, Read) -- | Gives the types of the arguments of the functions argumentTypes :: Typed t => t -> [Type] argumentTypes = argumentTypes' . typeOf argumentTypes' :: Type -> [Type] -argumentTypes' (TyForAll (AnonTyBndr t1) t2) = t1:argumentTypes' t2 -argumentTypes' (TyForAll (NamedTyBndr _) t2) = TYPE:argumentTypes' t2 +argumentTypes' (TyForAll _ t2) = TYPE:argumentTypes' t2 argumentTypes' (TyFun t1 t2) = t1:argumentTypes' t2 argumentTypes' _ = [] @@ -442,8 +494,7 @@ spArgumentTypes = spArgumentTypes' . typeOf spArgumentTypes' :: Type -> [ArgType] -spArgumentTypes' (TyForAll (AnonTyBndr t1) t2) = AnonType t1:spArgumentTypes' t2 -spArgumentTypes' (TyForAll (NamedTyBndr i) t2) = NamedType i:spArgumentTypes' t2 +spArgumentTypes' (TyForAll i t2) = NamedType i:spArgumentTypes' t2 spArgumentTypes' (TyFun t1 t2) = AnonType t1:spArgumentTypes' t2 spArgumentTypes' _ = [] @@ -451,15 +502,14 @@ leadingTyForAllBindings = leadingTyForAllBindings' . typeOf leadingTyForAllBindings' :: Type -> [Id] -leadingTyForAllBindings' (TyForAll (NamedTyBndr i) t) = i:leadingTyForAllBindings' t +leadingTyForAllBindings' (TyForAll i t) = i:leadingTyForAllBindings' t leadingTyForAllBindings' _ = [] tyForAllBindings :: Typed t => t -> [Id] tyForAllBindings = tyForAllBindings' . typeOf tyForAllBindings' :: Type -> [Id] -tyForAllBindings' (TyForAll (NamedTyBndr i) t) = i:tyForAllBindings' t -tyForAllBindings' (TyForAll _ t) = tyForAllBindings' t +tyForAllBindings' (TyForAll i t) = i:tyForAllBindings' t tyForAllBindings' (TyFun t t') = tyForAllBindings' t ++ tyForAllBindings t' tyForAllBindings' _ = [] @@ -480,20 +530,15 @@ returnType' (TyFun _ t) = returnType' t returnType' t = t --- | Returns all polymorphic Ids in the given type -polyIds :: Type -> [Id] -polyIds = fst . splitTyForAlls - -- | Turns TyForAll types into a list of type ids splitTyForAlls :: Type -> ([Id], Type) -splitTyForAlls (TyForAll (NamedTyBndr i) t) = +splitTyForAlls (TyForAll i t) = let (i', t') = splitTyForAlls t in (i:i', t') splitTyForAlls t = ([], t) - -- | Turns TyFun types into a list of types splitTyFuns :: Type -> [Type] splitTyFuns (TyFun t t') = t:splitTyFuns t' @@ -513,7 +558,7 @@ numTypeArgs = numTypeArgs' . typeOf numTypeArgs' :: Type -> Int -numTypeArgs' (TyForAll (NamedTyBndr _) t) = 1 + numTypeArgs' t +numTypeArgs' (TyForAll _ t) = 1 + numTypeArgs' t numTypeArgs' _ = 0 -- | Converts nested TyApps into a list of Expr-level Types @@ -543,4 +588,18 @@ exprs = tyAppsToExpr t1 bindings tyAppsToExpr _ _ = [] +-- | Returns True if Type represents an ADT +isADTType :: Type -> Bool +isADTType t = + let tCenter = tyAppCenter t + in case tCenter of + (TyCon _ _) -> True + _ -> False +isPrimType :: Type -> Bool +isPrimType TyLitInt = True +isPrimType TyLitFloat = True +isPrimType TyLitDouble = True +isPrimType TyLitChar = True +isPrimType TyLitString = True +isPrimType _ = False diff --git a/src/G2/Lib/Printers.hs b/src/G2/Lib/Printers.hs --- a/src/G2/Lib/Printers.hs +++ b/src/G2/Lib/Printers.hs @@ -1,16 +1,24 @@ {-# LANGUAGE OverloadedStrings #-} -module G2.Lib.Printers ( mkCleanExprHaskell +module G2.Lib.Printers ( PrettyGuide + , mkPrettyGuide + , updatePrettyGuide + + , printName + + , printHaskell + , printHaskellDirty + , printHaskellDirtyPG + , printHaskellPG , mkUnsugaredExprHaskell - , ppExprEnv - , ppRelExprEnv - , ppCurrExpr - , ppPathConds - , ppPathCond + , mkTypeHaskell + , mkTypeHaskellPG , pprExecStateStr - , pprExecEEnvStr) where + , printFuncCall + , prettyState -import G2.Execution.Memory + , prettyGuideStr) where + import G2.Language.Expr import qualified G2.Language.ExprEnv as E import G2.Language.KnownValues @@ -23,136 +31,287 @@ import G2.Language.Support import Data.Char -import Data.List +import Data.List as L import qualified Data.HashMap.Lazy as HM -import qualified Data.Map as M +import qualified Data.HashSet as HS +import Data.Monoid ((<>)) import qualified Data.Text as T -mkIdHaskell :: Id -> String -mkIdHaskell (Id n _) = mkNameHaskell n +data Clean = Cleaned | Dirty deriving Eq -mkNameHaskell :: Name -> String -mkNameHaskell = T.unpack . nameOcc +mkIdHaskell :: PrettyGuide -> Id -> T.Text +mkIdHaskell pg (Id n _) = mkNameHaskell pg n -mkUnsugaredExprHaskell :: State t -> Expr -> String +printName :: PrettyGuide -> Name -> T.Text +printName = mkNameHaskell + +mkNameHaskell :: PrettyGuide -> Name -> T.Text +mkNameHaskell pg n + | Just s <- lookupPG n pg = s + | otherwise = nameOcc n + +mkUnsugaredExprHaskell :: State t -> Expr -> T.Text mkUnsugaredExprHaskell (State {known_values = kv, type_classes = tc}) = - mkExprHaskell False kv . modifyFix (mkCleanExprHaskell' kv tc) + mkExprHaskell Cleaned (mkPrettyGuide ()) . modifyMaybe (mkCleanExprHaskell' kv tc) -mkCleanExprHaskell :: State t -> Expr -> String -mkCleanExprHaskell (State {known_values = kv, type_classes = tc}) = - mkExprHaskell True kv . modifyFix (mkCleanExprHaskell' kv tc) +printHaskell :: State t -> Expr -> T.Text +printHaskell = mkCleanExprHaskell (mkPrettyGuide ()) -mkCleanExprHaskell' :: KnownValues -> TypeClasses -> Expr -> Expr +printHaskellDirty :: Expr -> T.Text +printHaskellDirty = mkExprHaskell Dirty (mkPrettyGuide ()) + +printHaskellDirtyPG :: PrettyGuide -> Expr -> T.Text +printHaskellDirtyPG = mkExprHaskell Dirty + +printHaskellPG :: PrettyGuide -> State t -> Expr -> T.Text +printHaskellPG = mkCleanExprHaskell + +mkCleanExprHaskell :: PrettyGuide -> State t -> Expr -> T.Text +mkCleanExprHaskell pg (State {known_values = kv, type_classes = tc}) = + mkExprHaskell Cleaned pg . modifyMaybe (mkCleanExprHaskell' kv tc) + +mkCleanExprHaskell' :: KnownValues -> TypeClasses -> Expr -> Maybe Expr mkCleanExprHaskell' kv tc e | (App (Data (DataCon n _)) e') <- e - , n == dcInt kv || n == dcFloat kv || n == dcDouble kv || n == dcInteger kv || n == dcChar kv = e' + , n == dcInt kv || n == dcFloat kv || n == dcDouble kv || n == dcInteger kv || n == dcChar kv = Just e' + | Case scrut i t [a] <- e = Case scrut i t . (:[]) <$> elimPrimDC a + | (App e' e'') <- e , t <- typeOf e' - , isTypeClass tc t = e'' + , isTypeClass tc t = Just e'' | (App e' e'') <- e , t <- typeOf e'' - , isTypeClass tc t = e' + , isTypeClass tc t = Just e' - | App e' (Type _) <- e = e' + | (App e' e'') <- e + , isTypeClass tc (returnType e'') = Just e' - | otherwise = e + | App e' (Type _) <- e = Just e' -mkExprHaskell :: Bool -> KnownValues -> Expr -> String -mkExprHaskell sugar kv ex = mkExprHaskell' ex 0 + | otherwise = Nothing + +elimPrimDC :: Alt -> Maybe Alt +elimPrimDC (Alt (DataAlt (DataCon (Name n _ _ _) t) is) e) + | n == "I#" || n == "F#" || n == "D#" || n == "Z#" || n == "C#" = + Just $ Alt (DataAlt (DataCon (Name "" Nothing 0 Nothing) t) is) e +elimPrimDC _ = Nothing + +mkDirtyExprHaskell :: PrettyGuide -> Expr -> T.Text +mkDirtyExprHaskell = mkExprHaskell Dirty + +mkExprHaskell :: Clean -> PrettyGuide -> Expr -> T.Text +mkExprHaskell = mkExprHaskell' 0 + +mkExprHaskell' :: Int -> Clean -> PrettyGuide -> Expr -> T.Text +mkExprHaskell' off_init cleaned pg ex = mkExprHaskell'' off_init ex where - mkExprHaskell' :: Expr -> Int -> String - mkExprHaskell' (Var ids) _ = mkIdHaskell ids - mkExprHaskell' (Lit c) _ = mkLitHaskell c - mkExprHaskell' (Prim p _) _ = mkPrimHaskell p - mkExprHaskell' (Lam _ ids e) i = "\\" ++ mkIdHaskell ids ++ " -> " ++ mkExprHaskell' e i + isCleaned = cleaned == Cleaned - mkExprHaskell' a@(App ea@(App e1 e2) e3) i + mkExprHaskell'' :: Int -- ^ How much should a new line be indented? + -> Expr + -> T.Text + mkExprHaskell'' _ (Var ids) = mkIdHaskell pg ids + mkExprHaskell'' _ (Lit c) = mkLitHaskell c + mkExprHaskell'' _ (Prim p _) = mkPrimHaskell p + mkExprHaskell'' off (Lam _ ids e) = + "(\\" <> mkIdHaskell pg ids <> " -> " <> mkExprHaskell'' off e <> ")" + + mkExprHaskell'' off a@(App ea@(App e1 e2) e3) | Data (DataCon n _) <- appCenter a , isTuple n - , sugar = printTuple kv a + , isCleaned = printTuple pg a + | Data (DataCon n _) <- appCenter a + , isPrimTuple n + , isCleaned = printPrimTuple pg a | Data (DataCon n1 _) <- e1 , nameOcc n1 == ":" - , sugar = - if isLitChar e2 then printString a else printList kv a + , isCleaned = + if isLitChar e2 then printString pg a else printList pg a - | isInfixable e1 = + | isInfixable e1 + , isCleaned = let - e2P = if isApp e2 then "(" ++ mkExprHaskell' e2 i ++ ")" else mkExprHaskell' e2 i - e3P = if isApp e3 then "(" ++ mkExprHaskell' e3 i ++ ")" else mkExprHaskell' e3 i + e2P = if isApp e2 then "(" <> mkExprHaskell'' off e2 <> ")" else mkExprHaskell'' off e2 + e3P = if isApp e3 then "(" <> mkExprHaskell'' off e3 <> ")" else mkExprHaskell'' off e3 in - e2P ++ " " ++ mkExprHaskell' e1 i ++ " " ++ e3P + e2P <> " " <> mkExprHaskell'' off e1 <> " " <> e3P - | App _ _ <- e3 = mkExprHaskell' ea i ++ " (" ++ mkExprHaskell' e3 i ++ ")" - | otherwise = mkExprHaskell' ea i ++ " " ++ mkExprHaskell' e3 i + | App _ _ <- e3 = mkExprHaskell'' off ea <> " (" <> mkExprHaskell'' off e3 <> ")" + | otherwise = mkExprHaskell'' off ea <> " " <> mkExprHaskell'' off e3 - mkExprHaskell' (App e1 ea@(App _ _)) i = mkExprHaskell' e1 i ++ " (" ++ mkExprHaskell' ea i ++ ")" - mkExprHaskell' (App e1 e2) i = mkExprHaskell' e1 i ++ " " ++ mkExprHaskell' e2 i - mkExprHaskell' (Data d) _ = mkDataConHaskell d - mkExprHaskell' (Case e _ ae) i = "\n" ++ off (i + 1) ++ "case " ++ (mkExprHaskell' e i) ++ " of\n" - ++ intercalate "\n" (map (mkAltHaskell (i + 2)) ae) - mkExprHaskell' (Type _) _ = "" - mkExprHaskell' (Cast e (_ :~ t)) i = "((coerce " ++ mkExprHaskell' e i ++ ") :: " ++ mkTypeHaskell t ++ ")" - mkExprHaskell' e _ = "e = " ++ show e ++ " NOT SUPPORTED" + mkExprHaskell'' off (App e1 ea@(App _ _)) = mkExprHaskell'' off e1 <> " (" <> mkExprHaskell'' off ea <> ")" + mkExprHaskell'' off (App e1 e2) = + parenWrap e1 (mkExprHaskell'' off e1) <> " " <> mkExprHaskell'' off e2 + mkExprHaskell'' _ (Data d) = mkDataConHaskell pg d + mkExprHaskell'' off (Case e bndr _ ae) = + "case " <> parenWrap e (mkExprHaskell'' off e) <> " of\n" + <> T.intercalate "\n" (map (mkAltHaskell (off + 2) cleaned pg bndr) ae) + mkExprHaskell'' _ (Type t) = "@" <> mkTypeHaskellPG pg t + mkExprHaskell'' off (Cast e (t1 :~ t2)) = + let + e_str = mkExprHaskell'' off e + t1_str = mkTypeHaskellPG pg t1 + t2_str = mkTypeHaskellPG pg t2 + in + "((coerce (" <> e_str <> " :: " <> t1_str <> ")) :: " <> t2_str <> ")" + mkExprHaskell'' off (Coercion (t1 :~ t2)) = + let + t1_str = mkTypeHaskellPG pg t1 + t2_str = mkTypeHaskellPG pg t2 + in + "(" <> t1_str <> " :~ " <> t2_str <> ")" + mkExprHaskell'' off (Let binds e) = + let + binds' = T.intercalate (offset off <> "\n") + $ map (\(i, be) -> mkIdHaskell pg i <> " = " <> mkExprHaskell'' off be) binds + in + "let " <> binds' <> " in " <> mkExprHaskell'' off e + mkExprHaskell'' off (Tick nl e) = "TICK[" <> printTickish pg nl <> "]{" <> mkExprHaskell'' off e <> "}" + mkExprHaskell'' off (Assume m_fc e1 e2) = + let + print_fc = maybe "" (\fc -> "(" <> printFuncCallPG pg fc <> ") ") m_fc + in + "assume " <> print_fc + <> "(" <> mkExprHaskell'' off e1 + <> ") (" <> mkExprHaskell'' off e2 <> ")" + mkExprHaskell'' off (Assert m_fc e1 e2) = + let + print_fc = maybe "" (\fc -> "(" <> printFuncCallPG pg fc <> ") ") m_fc + in + "assert " <> print_fc + <> "(" <> mkExprHaskell'' off e1 + <> ") (" <> mkExprHaskell'' off e2 <> ")" + mkExprHaskell'' off (NonDet es) = + let + print_es = map (mkExprHaskell'' off) es + in + T.intercalate ("\n" <> offset off <> "[NonDet]\n") print_es + mkExprHaskell'' _ (SymGen SLog t) = "(symgen log " <> mkTypeHaskellPG pg t <> ")" + mkExprHaskell'' _ (SymGen SNoLog t) = "(symgen no_log " <> mkTypeHaskellPG pg t <> ")" + mkExprHaskell'' _ e = "e = " <> T.pack (show e) <> " NOT SUPPORTED" - mkAltHaskell :: Int -> Alt -> String - mkAltHaskell i (Alt am e) = - off i ++ mkAltMatchHaskell am ++ " -> " ++ mkExprHaskell' e i + parenWrap :: Expr -> T.Text -> T.Text + parenWrap (Case _ _ _ _) s = "(" <> s <> ")" + parenWrap (Let _ _) s = "(" <> s <> ")" + parenWrap (Tick _ e) s = parenWrap e s + parenWrap _ s = s -mkAltMatchHaskell :: AltMatch -> String -mkAltMatchHaskell (DataAlt dc ids) = mkDataConHaskell dc ++ " " ++ intercalate " " (map mkIdHaskell ids) -mkAltMatchHaskell (LitAlt l) = mkLitHaskell l -mkAltMatchHaskell Default = "_" +mkAltHaskell :: Int -> Clean -> PrettyGuide -> Id -> Alt -> T.Text +mkAltHaskell off cleaned pg i_bndr@(Id bndr_name _) (Alt am e) = + let + needs_bndr = bndr_name `elem` names e + in + offset off <> mkAltMatchHaskell (if needs_bndr then Just i_bndr else Nothing) am <> " -> " <> mkExprHaskell' off cleaned pg e + where + mkAltMatchHaskell :: Maybe Id -> AltMatch -> T.Text + mkAltMatchHaskell m_bndr (DataAlt dc@(DataCon n _) ids) | isTuple n = + let + pr_am = printTuple pg $ mkApp (Data dc:map Var ids) + in + case m_bndr of + Just bndr | not (L.null ids) -> mkIdHaskell pg bndr <> "@" <> pr_am <> "" + | otherwise -> mkIdHaskell pg bndr + Nothing -> pr_am + mkAltMatchHaskell m_bndr (DataAlt dc@(DataCon n _) [id1, id2]) | isInfixableName n = + let + pr_am = mkIdHaskell pg id1 <> " " <> mkDataConHaskell pg dc <> " " <> mkIdHaskell pg id2 + in + case m_bndr of + Just bndr -> mkIdHaskell pg bndr <> "@(" <> pr_am <> ")" + Nothing -> pr_am + mkAltMatchHaskell m_bndr (DataAlt dc ids) = + let + pr_am = mkDataConHaskell pg dc <> " " <> T.intercalate " " (map (mkIdHaskell pg) ids) + in + case m_bndr of + Just bndr | not (L.null ids) -> mkIdHaskell pg bndr <> "@(" <> pr_am <> ")" + | otherwise -> mkIdHaskell pg bndr + Nothing -> pr_am + mkAltMatchHaskell m_bndr (LitAlt l) = + case m_bndr of + Just bndr -> mkIdHaskell pg bndr <> "@" <> mkLitHaskell l + Nothing -> mkLitHaskell l + mkAltMatchHaskell (Just bndr) Default = mkIdHaskell pg bndr + mkAltMatchHaskell _ Default = "_" -mkDataConHaskell :: DataCon -> String +mkDataConHaskell :: PrettyGuide -> DataCon -> T.Text -- Special casing for Data.Map in the modified base -mkDataConHaskell (DataCon (Name "Assocs" _ _ _) _) = "fromList" -mkDataConHaskell (DataCon n _) = mkNameHaskell n +mkDataConHaskell _ (DataCon (Name "Assocs" _ _ _) _) = "fromList" +mkDataConHaskell pg (DataCon n _) = mkNameHaskell pg n -off :: Int -> String -off i = duplicate " " i +offset :: Int -> T.Text +offset i = duplicate " " i -printList :: KnownValues -> Expr -> String -printList kv a = "[" ++ intercalate ", " (printList' kv a) ++ "]" +printList :: PrettyGuide -> Expr -> T.Text +printList pg a = + let (strs, b) = printList' pg a + in case b of + False -> "(" <> T.intercalate ":" strs <> ")" + _ -> "[" <> T.intercalate ", " strs <> "]" -printList' :: KnownValues -> Expr -> [String] -printList' kv (App (App _ e) e') = mkExprHaskell True kv e:printList' kv e' -printList' _ _ = [] +printList' :: PrettyGuide -> Expr -> ([T.Text], Bool) +printList' pg (App (App e1 e) e') | Data (DataCon n1 _) <- e1 + , nameOcc n1 == ":" = + let (strs, b) = printList' pg e' + in (mkExprHaskell Cleaned pg e:strs, b) +printList' pg e | Data (DataCon n _) <- appCenter e + , nameOcc n == "[]" = ([], True) + | otherwise = ([mkExprHaskell Cleaned pg e], False) -printString :: Expr -> String -printString a = +printString :: PrettyGuide -> Expr -> T.Text +printString pg a = let - str = printString' a - in - if all isPrint str then "\"" ++ str ++ "\"" - else "[" ++ intercalate ", " (map stringToEnum str) ++ "]" + maybe_str = printString' a + in case maybe_str of + Just str -> if T.all isPrint str then "\"" <> str <> "\"" + else "[" <> T.intercalate ", " (map (T.pack . stringToEnum) $ T.unpack str) <> "]" + Nothing -> printList pg a where stringToEnum c | isPrint c = '\'':c:'\'':[] | otherwise = "toEnum " ++ show (ord c) -printString' :: Expr -> String -printString' (App (App _ (Lit (LitChar c))) e') = c:printString' e' -printString' _ = [] +printString' :: Expr -> Maybe T.Text +printString' (App (App _ (Lit (LitChar c))) e') = + case printString' e' of + Nothing -> Nothing + Just str -> Just (T.cons c str) +printString' e | Data (DataCon n _) <- appCenter e + , nameOcc n == "[]" = Just "" + | otherwise = Nothing isTuple :: Name -> Bool -isTuple (Name n _ _ _) = T.head n == '(' && T.last n == ')' +isTuple (Name n _ _ _) = fmap fst (T.uncons n) == Just '(' && fmap snd (T.unsnoc n) == Just ')' && T.all (\c -> c == '(' || c == ')' || c == ',') n -printTuple :: KnownValues -> Expr -> String -printTuple kv a = "(" ++ intercalate ", " (reverse $ printTuple' kv a) ++ ")" +isPrimTuple :: Name -> Bool +isPrimTuple (Name n _ _ _) = fmap fst (T.uncons n) == Just '(' && fmap snd (T.unsnoc n) == Just ')' + && T.all (\c -> c == '(' || c == ')' || c == ',' || c == '#') n + && T.any (\c -> c == '#') n -printTuple' :: KnownValues -> Expr -> [String] -printTuple' kv (App e e') = mkExprHaskell True kv e':printTuple' kv e +printTuple :: PrettyGuide -> Expr -> T.Text +printTuple pg a = "(" <> T.intercalate ", " (reverse $ printTuple' pg a) <> ")" + +printPrimTuple :: PrettyGuide -> Expr -> T.Text +printPrimTuple pg a = "(#" <> T.intercalate ", " (reverse $ printTuple' pg a) <> "#)" + +printTuple' :: PrettyGuide -> Expr -> [T.Text] +printTuple' pg (App e e') = mkExprHaskell Cleaned pg e':printTuple' pg e printTuple' _ _ = [] isInfixable :: Expr -> Bool -isInfixable (Data (DataCon n _)) = not $ T.any isAlphaNum $ nameOcc n +isInfixable (Var (Id n _)) = isInfixableName n +isInfixable (Data (DataCon n _)) = isInfixableName n +isInfixable (Prim p _) = not . T.any isAlphaNum $ mkPrimHaskell p isInfixable _ = False +isInfixableName :: Name -> Bool +isInfixableName = not . T.any isAlphaNum . nameOcc + isApp :: Expr -> Bool isApp (App _ _) = True isApp _ = False @@ -161,15 +320,16 @@ isLitChar (Lit (LitChar _)) = True isLitChar _ = False -mkLitHaskell :: Lit -> String -mkLitHaskell (LitInt i) = if i < 0 then "(" ++ show i ++ ")" else show i -mkLitHaskell (LitInteger i) = if i < 0 then "(" ++ show i ++ ")" else show i -mkLitHaskell (LitFloat r) = "(" ++ show ((fromRational r) :: Float) ++ ")" -mkLitHaskell (LitDouble r) = "(" ++ show ((fromRational r) :: Double) ++ ")" -mkLitHaskell (LitChar c) = ['\'', c, '\''] -mkLitHaskell (LitString s) = s +mkLitHaskell :: Lit -> T.Text +mkLitHaskell (LitInt i) = T.pack $ if i < 0 then "(" <> show i <> ")" else show i +mkLitHaskell (LitInteger i) = T.pack $ if i < 0 then "(" <> show i <> ")" else show i +mkLitHaskell (LitFloat r) = "(" <> T.pack (show ((fromRational r) :: Float)) <> ")" +mkLitHaskell (LitDouble r) = "(" <> T.pack (show ((fromRational r) :: Double)) <> ")" +mkLitHaskell (LitChar c) | isPrint c = T.pack ['\'', c, '\''] + | otherwise = "(chr " <> T.pack (show $ ord c) <> ")" +mkLitHaskell (LitString s) = T.pack s -mkPrimHaskell :: Primitive -> String +mkPrimHaskell :: Primitive -> T.Text mkPrimHaskell Ge = ">=" mkPrimHaskell Gt = ">" mkPrimHaskell Eq = "==" @@ -186,77 +346,227 @@ mkPrimHaskell DivInt = "/" mkPrimHaskell Quot = "quot" mkPrimHaskell Mod = "mod" +mkPrimHaskell Rem = "rem" mkPrimHaskell Negate = "-" +mkPrimHaskell Abs = "abs" mkPrimHaskell SqRt = "sqrt" + +mkPrimHaskell DataToTag = "prim_dataToTag#" +mkPrimHaskell TagToEnum = "prim_tagToEnum#" + + mkPrimHaskell IntToFloat = "fromIntegral" mkPrimHaskell IntToDouble = "fromIntegral" +mkPrimHaskell RationalToDouble = "fromRational" mkPrimHaskell FromInteger = "fromInteger" mkPrimHaskell ToInteger = "toInteger" + +mkPrimHaskell StrLen = "StrLen" +mkPrimHaskell StrAppend = "StrAppend" +mkPrimHaskell Chr = "chr" +mkPrimHaskell OrdChar = "ord" + +mkPrimHaskell WGenCat = "wgencat" + +mkPrimHaskell IntToString = "intToString" + mkPrimHaskell ToInt = "toInt" + mkPrimHaskell Error = "error" mkPrimHaskell Undefined = "undefined" mkPrimHaskell Implies = "undefined" mkPrimHaskell Iff = "undefined" -mkPrimHaskell BindFunc = "undefined" -mkTypeHaskell :: Type -> String -mkTypeHaskell (TyVar i) = mkIdHaskell i -mkTypeHaskell (TyFun t1 t2) = mkTypeHaskell t1 ++ " -> " ++ mkTypeHaskell t2 -mkTypeHaskell (TyCon n _) = mkNameHaskell n -mkTypeHaskell (TyApp t1 t2) = "(" ++ mkTypeHaskell t1 ++ " " ++ mkTypeHaskell t2 ++ ")" -mkTypeHaskell _ = "Unsupported type in printer." +mkTypeHaskell :: Type -> T.Text +mkTypeHaskell = mkTypeHaskellPG (mkPrettyGuide ()) -duplicate :: String -> Int -> String +mkTypeHaskellPG :: PrettyGuide -> Type -> T.Text +mkTypeHaskellPG pg (TyVar i) = mkIdHaskell pg i +mkTypeHaskellPG _ TyLitInt = "Int#" +mkTypeHaskellPG _ TyLitFloat = "Float#" +mkTypeHaskellPG _ TyLitDouble = "Double#" +mkTypeHaskellPG _ TyLitChar = "Char#" +mkTypeHaskellPG _ TyLitString = "String#" +mkTypeHaskellPG pg (TyFun t1 t2) + | isTyFun t1 = "(" <> mkTypeHaskellPG pg t1 <> ") -> " <> mkTypeHaskellPG pg t2 + | otherwise = mkTypeHaskellPG pg t1 <> " -> " <> mkTypeHaskellPG pg t2 +mkTypeHaskellPG pg (TyCon n _) | nameOcc n == "List" + , nameModule n == Just "GHC.Types" = "[]" + | otherwise = mkNameHaskell pg n +mkTypeHaskellPG pg (TyApp t1 t2) = "(" <> mkTypeHaskellPG pg t1 <> " " <> mkTypeHaskellPG pg t2 <> ")" +mkTypeHaskellPG pg (TyForAll i t) = "forall " <> mkIdHaskell pg i <> " . " <> mkTypeHaskellPG pg t +mkTypeHaskellPG _ TyBottom = "Bottom" +mkTypeHaskellPG _ TYPE = "Type" +mkTypeHaskellPG _ (TyUnknown) = "Unknown" + +duplicate :: T.Text -> Int -> T.Text duplicate _ 0 = "" -duplicate s n = s ++ duplicate s (n - 1) +duplicate s n = s <> duplicate s (n - 1) -ppExprEnv :: State t -> String -ppExprEnv s@(State {expr_env = eenv}) = +printTickish :: PrettyGuide -> Tickish -> T.Text +printTickish _ (Breakpoint sp) = printLoc (start sp) <> " - " <> printLoc (end sp) +printTickish _ (HpcTick i m) = "(hpc " <> T.pack (show i) <> " " <> m <> ")" +printTickish pg (NamedLoc n) = mkNameHaskell pg n + +printLoc :: Loc -> T.Text +printLoc (Loc ln cl fl) = "(line " <> T.pack (show ln) <> " column " <> T.pack (show cl) <> " in " <> T.pack fl <> ")" + +------------------------------------------------------------------------------- + +prettyState :: Show t => PrettyGuide -> State t -> T.Text +prettyState pg s = + T.intercalate "\n" + [ ">>>>> [State] >>>>>>>>>>>>>>>>>>>>>" + , "----- [Code] ----------------------" + , pretty_curr_expr + , "----- [Stack] ----------------------" + , pretty_stack + , "----- [Env] -----------------------" + , pretty_eenv + , "----- [Paths] -----------------------" + , pretty_paths + , "----- [Non Red Paths] ---------------------" + , pretty_non_red_paths + , "----- [Types] ---------------------" + , pretty_tenv + , "----- [Typeclasses] ---------------------" + , pretty_tc + , "----- [True Assert] ---------------------" + , T.pack (show (true_assert s)) + , "----- [Assert FC] ---------------------" + , pretty_assert_fcs + , "----- [Tracker] ---------------------" + , T.pack (show (track s)) + , "----- [Pretty] ---------------------" + , pretty_names + ] + where + pretty_curr_expr = prettyCurrExpr pg (curr_expr s) + pretty_stack = prettyStack pg (exec_stack s) + pretty_eenv = prettyEEnv pg (expr_env s) + pretty_paths = prettyPathConds pg (path_conds s) + pretty_non_red_paths = prettyNonRedPaths pg (non_red_path_conds s) + pretty_tenv = prettyTypeEnv pg (type_env s) + pretty_tc = prettyTypeClasses pg (type_classes s) + pretty_assert_fcs = maybe "None" (printFuncCallPG pg) (assert_ids s) + pretty_names = prettyGuideStr pg + + +prettyCurrExpr :: PrettyGuide -> CurrExpr -> T.Text +prettyCurrExpr pg (CurrExpr er e) = let - eenvs = M.toList $ E.map' (mkUnsugaredExprHaskell s) eenv + e_str = mkDirtyExprHaskell pg e in - intercalate "\n" $ map (\(n, es) -> mkNameHaskell n ++ " = " ++ es) eenvs + case er of + Evaluate -> "evaluate: " <> e_str + Return -> "return: " <> e_str --- | ppRelExprEnv --- Prints all variable definitions from the expression environment, --- that are required to understand the curr expr and path constraints -ppRelExprEnv :: State t -> Bindings -> String -ppRelExprEnv s b = +prettyStack :: PrettyGuide -> Stack Frame -> T.Text +prettyStack pg = T.intercalate "\n" . map (prettyFrame pg) . toList + +prettyFrame :: PrettyGuide -> Frame -> T.Text +prettyFrame pg (CaseFrame i _ as) = + "case frame: bindee:" <> mkIdHaskell pg i <> "\n" <> T.intercalate "\n" (map (mkAltHaskell 1 Dirty pg i) as) +prettyFrame pg (ApplyFrame e) = "apply frame: " <> mkDirtyExprHaskell pg e +prettyFrame pg (UpdateFrame n) = "update frame: " <> mkNameHaskell pg n +prettyFrame pg (CastFrame (t1 :~ t2)) = "cast frame: " <> mkTypeHaskellPG pg t1 <> " ~ " <> mkTypeHaskellPG pg t2 +prettyFrame pg (CurrExprFrame act ce) = "curr_expr frame: " <> prettyCEAction pg act <> prettyCurrExpr pg ce +prettyFrame pg (AssumeFrame e) = "assume frame: " <> mkDirtyExprHaskell pg e +prettyFrame pg (AssertFrame m_fc e) = let - (s', _) = markAndSweep s b + fc = case m_fc of + Just fc_ -> "(from call " <> printFuncCallPG pg fc_ <> ")" + Nothing -> "" in - ppExprEnv s' + "assert frame: " <> fc <> mkDirtyExprHaskell pg e -ppCurrExpr :: State t -> String -ppCurrExpr s@(State {curr_expr = CurrExpr _ e}) = mkUnsugaredExprHaskell s e +prettyCEAction :: PrettyGuide -> CEAction -> T.Text +prettyCEAction pg (EnsureEq e) = "EnsureEq " <> mkDirtyExprHaskell pg e +prettyCEAction _ NoAction = "NoAction" -ppPathConds :: State t -> String -ppPathConds s@(State {path_conds = pc}) = intercalate "\n" $ PC.map (ppPathCond s) pc +prettyEEnv :: PrettyGuide -> ExprEnv -> T.Text +prettyEEnv pg eenv = T.intercalate "\n\n" + . map (uncurry printFunc) + . E.toList $ eenv + where + printFunc n e = mkNameHaskell pg n <> " :: " <> mkTypeHaskellPG pg (envObjType eenv e) + <> "\n" <> mkNameHaskell pg n <> " = " <> printEnvObj pg e -ppPathCond :: State t -> PathCond -> String -ppPathCond s (AltCond l e b) = - mkLitHaskell l ++ (if b then " == " else " /= ") ++ mkUnsugaredExprHaskell s e -ppPathCond s (ExtCond e b) = +printEnvObj :: PrettyGuide -> E.EnvObj -> T.Text +printEnvObj pg (E.ExprObj e) = mkDirtyExprHaskell pg e +printEnvObj pg (E.SymbObj (Id _ t)) = "symbolic " <> mkTypeHaskellPG pg t +printEnvObj pg (E.RedirObj n) = "redir to " <> mkNameHaskell pg n + +envObjType :: ExprEnv -> E.EnvObj -> Type +envObjType _ (E.ExprObj e) = typeOf e +envObjType _ (E.SymbObj (Id _ t)) = t +envObjType eenv (E.RedirObj n) = maybe (TyCon (Name "???" Nothing 0 Nothing) TYPE) typeOf $ E.lookup n eenv + +prettyPathConds :: PrettyGuide -> PathConds -> T.Text +prettyPathConds pg = T.intercalate "\n" . map (prettyPathCond pg) . PC.toList + +prettyPathCond :: PrettyGuide -> PathCond -> T.Text +prettyPathCond pg (AltCond l e b) = let - es = mkUnsugaredExprHaskell s e + eq = mkLitHaskell l <> " = " <> mkDirtyExprHaskell pg e in - if b then es else "not (" ++ es ++ ")" -ppPathCond s (ConsCond dc e b) = + if b then eq else "not (" <> eq <> ")" +prettyPathCond pg (ExtCond e b) = + if b then mkDirtyExprHaskell pg e else "not (" <> mkDirtyExprHaskell pg e <> ")" +prettyPathCond pg (SoftPC pc) = + "soft (" <> prettyPathCond pg pc <> ")" +prettyPathCond pg (MinimizePC e) = + "minimize (" <> mkDirtyExprHaskell pg e <> ")" +prettyPathCond pg (AssumePC i l pc) = let - dcs = mkDataConHaskell dc - es = mkUnsugaredExprHaskell s e + pc' = map PC.unhashedPC $ HS.toList pc in - if b then es ++ " is " ++ dcs else es ++ " is not " ++ dcs -ppPathCond _ (PCExists i) = "Exists " ++ mkIdHaskell i + mkIdHaskell pg i <> " = " <> T.pack (show l) <> "=> (" <> T.intercalate "\nand " (map (prettyPathCond pg) pc') <> ")" +prettyNonRedPaths :: PrettyGuide -> [(Expr, Expr)] -> T.Text +prettyNonRedPaths pg = T.intercalate "\n" . map (\(e1, e2) -> mkDirtyExprHaskell pg e1 <> " == " <> mkDirtyExprHaskell pg e2) + +prettyTypeEnv :: PrettyGuide -> TypeEnv -> T.Text +prettyTypeEnv pg = T.intercalate "\n" . map (uncurry (prettyADT pg)) . HM.toList + +prettyADT :: PrettyGuide -> Name -> AlgDataTy -> T.Text +prettyADT pg n DataTyCon { bound_ids = bids, data_cons = dcs } = + "data " <> mkNameHaskell pg n <> " " + <> T.intercalate " " (map (mkIdHaskell pg) bids) + <> " = " <> T.intercalate " | " (map (prettyDCWithType pg) dcs) +prettyADT pg n NewTyCon { bound_ids = bids, data_con = dc } = + "newtype " <> mkNameHaskell pg n <> " " + <> T.intercalate " " (map (mkIdHaskell pg) bids) + <> " = " <> prettyDCWithType pg dc +prettyADT pg n TypeSynonym { bound_ids = bids, synonym_of = t } = + "type " <> mkNameHaskell pg n <> " " + <> T.intercalate " " (map (mkIdHaskell pg) bids) + <> " = " <> mkTypeHaskellPG pg t + +prettyDCWithType :: PrettyGuide -> DataCon -> T.Text +prettyDCWithType pg dc = mkDataConHaskell pg dc <> " :: " <> mkTypeHaskellPG pg (typeOf dc) + +prettyTypeClasses :: PrettyGuide -> TypeClasses -> T.Text +prettyTypeClasses pg = T.intercalate "\n" . map (\(n, tc) -> mkNameHaskell pg n <> " = " <> prettyClass pg tc) . HM.toList . toMap + +prettyClass :: PrettyGuide -> Class -> T.Text +prettyClass pg cls = + let + sc = T.intercalate ", " $ map (\(t, i) -> mkTypeHaskellPG pg t <> " " <> mkIdHaskell pg i) (superclasses cls) + ti = T.intercalate " " . map (mkIdHaskell pg) $ typ_ids cls + ins = T.intercalate "\n\t\t" $ map (\(t, i) -> mkTypeHaskellPG pg t <> " " <> mkIdHaskell pg i) (insts cls) + in + "\n\tsuper_classes = " <> sc + <> "\n\ttype_ids = " <> ti + <> "\n\tinsts = " <> ins + +------------------------------------------------------------------------------- + injNewLine :: [String] -> String injNewLine strs = intercalate "\n" strs -injTuple :: [String] -> String -injTuple strs = "(" ++ (intercalate "," strs) ++ ")" - -- | More raw version of state dumps. -pprExecStateStr :: State t -> Bindings -> String +pprExecStateStr :: Show t => State t -> Bindings -> String pprExecStateStr ex_state b = injNewLine acc_strs where eenv_str = pprExecEEnvStr (expr_env ex_state) @@ -264,7 +574,7 @@ estk_str = pprExecStackStr (exec_stack ex_state) code_str = pprExecCodeStr (curr_expr ex_state) names_str = pprExecNamesStr (name_gen b) - input_str = pprInputIdsStr (symbolic_ids ex_state) + input_str = pprInputIdsStr (E.symbolicIds . expr_env $ ex_state) paths_str = pprPathsStr (PC.toList $ path_conds ex_state) non_red_paths_str = injNewLine (map show $ non_red_path_conds ex_state) tc_str = pprTCStr (type_classes ex_state) @@ -272,6 +582,7 @@ cleaned_str = pprCleanedNamesStr (cleaned_names b) model_str = pprModelStr (model ex_state) rules_str = intercalate "\n" $ map show (zip ([0..] :: [Integer]) $ rules ex_state) + track_str = show (track ex_state) acc_strs = [ ">>>>> [State] >>>>>>>>>>>>>>>>>>>>>" , "----- [Code] ----------------------" , code_str @@ -301,6 +612,8 @@ , cleaned_str , "----- [Model] -------------------" , model_str + , "----- [Track] -------------------" + , track_str , "----- [Rules] -------------------" , rules_str , "<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<" @@ -314,12 +627,12 @@ pprTEnvStr :: TypeEnv -> String pprTEnvStr tenv = injNewLine kv_strs where - kv_strs = map show $ M.toList tenv + kv_strs = map show $ HM.toList tenv pprModelStr :: Model -> String pprModelStr m = injNewLine kv_strs where - kv_strs = map show $ M.toList m + kv_strs = map show $ HM.toList m pprExecStackStr :: Stack Frame -> String pprExecStackStr stk = injNewLine frame_strs @@ -343,7 +656,7 @@ pprTCStr :: TypeClasses -> String pprTCStr tc = injNewLine cond_strs where - cond_strs = map show $ M.toList $ toMap tc + cond_strs = map show $ HM.toList $ toMap tc pprInputIdsStr :: InputIds -> String pprInputIdsStr i = injNewLine id_strs @@ -351,25 +664,54 @@ id_strs = map show i pprPathCondStr :: PathCond -> String -pprPathCondStr (AltCond am expr b) = injTuple acc_strs - where - am_str = show am - expr_str = show expr - b_str = show b - acc_strs = [am_str, expr_str, b_str] -pprPathCondStr (ExtCond am b) = injTuple acc_strs - where - am_str = show am - b_str = show b - acc_strs = [am_str, b_str] -pprPathCondStr (ConsCond d expr b) = injTuple acc_strs - where - d_str = show d - expr_str = show expr - b_str = show b - acc_strs = [d_str, expr_str, b_str] -pprPathCondStr (PCExists p) = show p +pprPathCondStr = show pprCleanedNamesStr :: CleanedNames -> String pprCleanedNamesStr = injNewLine . map show . HM.toList +printFuncCall :: FuncCall -> T.Text +printFuncCall = printFuncCallPG (mkPrettyGuide ()) + +printFuncCallPG :: PrettyGuide -> FuncCall -> T.Text +printFuncCallPG pg (FuncCall { funcName = f, arguments = ars, returns = r}) = + let + call_str fn = mkDirtyExprHaskell pg . foldl (\a a' -> App a a') (Var (Id fn TyUnknown)) $ ars + r_str = mkDirtyExprHaskell pg r + in + "(" <> call_str f <> " " <> r_str <> ")" + +------------------------------------------------------------------------------- +-- Pretty Guide +------------------------------------------------------------------------------- + +-- | Maps G2 `Name`s to printable `String`s uniquely and consistently +-- (two `Name`s will not map to the same `String`, and on a per `PrettyGuide` +-- basis the same `Name` will always map to the same `String`.) +-- The `PrettyGuide` will only work on `Name`s it "knows" about. +-- It "knows" about names in the `Named` value it is passed in it's creation +-- (via `mkPrettyGuide`) and all `Name`s that it is passed via `updatePrettyGuide`. +data PrettyGuide = PG { pg_assigned :: HM.HashMap Name T.Text, pg_nums :: HM.HashMap T.Text Int } + +mkPrettyGuide :: Named a => a -> PrettyGuide +mkPrettyGuide = foldr insertPG (PG HM.empty HM.empty) . names + +updatePrettyGuide :: Named a => a -> PrettyGuide -> PrettyGuide +updatePrettyGuide ns pg = foldr insertPG pg $ names ns + +insertPG :: Name -> PrettyGuide -> PrettyGuide +insertPG n pg@(PG { pg_assigned = as, pg_nums = nms }) + | not (HM.member n as) = + case HM.lookup (nameOcc n) nms of + Just i -> + PG { pg_assigned = HM.insert n (nameOcc n <> "'" <> T.pack (show i)) as + , pg_nums = HM.insert (nameOcc n) (i + 1) nms } + Nothing -> + PG { pg_assigned = HM.insert n (nameOcc n) as + , pg_nums = HM.insert (nameOcc n) 1 nms } + | otherwise = pg + +lookupPG :: Name -> PrettyGuide -> Maybe T.Text +lookupPG n = HM.lookup n . pg_assigned + +prettyGuideStr :: PrettyGuide -> T.Text +prettyGuideStr = T.intercalate "\n" . map (\(n, s) -> s <> " <-> " <> T.pack (show n)) . HM.toList . pg_assigned diff --git a/src/G2/Liquid/AddCFBranch.hs b/src/G2/Liquid/AddCFBranch.hs --- a/src/G2/Liquid/AddCFBranch.hs +++ b/src/G2/Liquid/AddCFBranch.hs @@ -1,11 +1,26 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -module G2.Liquid.AddCFBranch (addCounterfactualBranch) where +module G2.Liquid.AddCFBranch ( CounterfactualName + , addCounterfactualBranch + , onlyCounterfactual + , elimNonTop + , instFuncTickName + , existentialInstId ) where + import G2.Language +import qualified G2.Language.ExprEnv as E import G2.Language.Monad +import G2.Liquid.Config import G2.Liquid.Types +import G2.Liquid.TyVarBags +import qualified Data.HashSet as S +import Data.List + +type CounterfactualName = Name + -- Enables finding abstract counterexamples, by adding counterfactual branches -- with two states. -- (a) One state is exactly the same as the current reduce function: we lookup @@ -20,51 +35,116 @@ -- This is essentially abstracting away the function definition, leaving -- only the information that LH also knows (that is, the information in the -- refinment type.) -addCounterfactualBranch :: [Name] -> LHStateM Name -addCounterfactualBranch ns = do +addCounterfactualBranch :: CFModules + -> [Name] -- ^ Which functions to consider abstracting + -> LHStateM CounterfactualName +addCounterfactualBranch cf_mod ns = do + let ns' = case cf_mod of + CFAll -> ns + CFOnly mods -> filter (\(Name n m _ _) -> (n, m) `S.member` mods) ns + + bag_func_ns <- return . concat =<< mapM argumentNames ns' + inst_func_ns <- return . concat =<< mapM returnNames ns' + + createBagAndInstFuncs bag_func_ns inst_func_ns + cfn <- freshSeededStringN "cf" - mapWithKeyME (addCounterfactualBranch' cfn ns) + mapWithKeyME (addCounterfactualBranch' cfn ns') return cfn -addCounterfactualBranch' :: Name -> [Name]-> Name -> Expr -> LHStateM Expr +addCounterfactualBranch' :: CounterfactualName -> [Name] -> Name -> Expr -> LHStateM Expr addCounterfactualBranch' cfn ns n = if n `elem` ns then insertInLamsE (\_ -> addCounterfactualBranch'' cfn) else return -addCounterfactualBranch'' :: Name -> Expr -> LHStateM Expr +addCounterfactualBranch'' :: CounterfactualName -> Expr -> LHStateM Expr addCounterfactualBranch'' cfn orig_e@(Let - [(b, _)] - (Assert (Just (FuncCall { funcName = fn, arguments = ars })) a _)) = do - let t = returnType orig_e - sg = SymGen t - - -- Create lambdas, to gobble up any ApplyFrames left on the stack - lams <- tyBindings orig_e + [(b, _)] + (Assert (Just (FuncCall { funcName = fn, arguments = ars, returns = r })) a _)) = do + sg <- cfRetValue ars rt - -- If the type of b is not the same as e's type, we have no assumption, - -- so we get a new b. Otherwise, we just keep our current b, - -- in case it is used in the assertion - b' <- if typeOf b == t then return b else freshIdN t + -- If the type of b is not the same as e's type, we have no assumption, + -- so we get a new b. Otherwise, we just keep our current b, + -- in case it is used in the assertion + b' <- if typeOf b == rt then return b else freshIdN rt - let fc = FuncCall { funcName = fn, arguments = ars', returns = (Var b')} - e' = lams $ Let [(b', sg)] $ Tick (NamedLoc cfn) $ Assume (Just fc) a (Var b') - -- We add the Id's from the newly created Lambdas to the arguments list - lamI = map Var $ leadingLamIds e' - ars' = ars ++ lamI + let fc = FuncCall { funcName = fn, arguments = ars, returns = (Var b')} + e' = Let [(b', sg)] $ Tick (NamedLoc cfn) $ Assume (Just fc) a (Var b') - return $ NonDet [orig_e, e'] + return $ NonDet [orig_e, e'] + where + rt = typeOf r addCounterfactualBranch'' cfn e = modifyChildrenM (addCounterfactualBranch'' cfn) e --- Creates Lambda bindings to saturate the type of the given Typed thing, --- and a list of the bindings so they can be used elsewhere -tyBindings :: Typed t => t -> LHStateM (Expr -> Expr) -tyBindings t = do - let at = spArgumentTypes t - fn <- freshNamesN (length at) - return $ tyBindings' fn at +cfRetValue :: [Expr] -- ^ Arguments + -> Type -- ^ Type of return value + -> LHStateM Expr +cfRetValue ars rt + | tvs <- tyVarIds rt + , not (null tvs) = do + let all_tvs = tvs ++ tyVarIds ars + ty_bags <- getTyVarBags -tyBindings' :: [Name] -> [ArgType] -> Expr -> Expr -tyBindings' _ [] = id -tyBindings' ns (NamedType i:ts) = Lam TypeL i . tyBindings' ns ts -tyBindings' (n:ns) (AnonType t:ts) = Lam TermL (Id n t) . tyBindings' ns ts -tyBindings' [] _ = error "Name list exhausted in tyBindings'" + ex_vrs <- freshIdsN (map TyVar all_tvs) + let ex_tvs_to_vrs = zip all_tvs ex_vrs + + ex_ty_clls <- mapM + (\tv -> wrapExtractCalls + . filter nullNonDet + . concat + =<< mapM (extractTyVarCall ty_bags ex_tvs_to_vrs tv) ars) (nub all_tvs) + + let ex_let_bnds = zip ex_vrs ex_ty_clls + + dUnit <- mkUnitE + + insts_f <- getInstFuncs + inst_ret <- instTyVarCall insts_f ex_tvs_to_vrs rt + let inst_ret_call = App inst_ret dUnit + ir_bndr <- freshIdN (typeOf inst_ret_call) + + return . Let ((ir_bndr, inst_ret_call):ex_let_bnds) $ Tick (NamedLoc instFuncTickName) (Var ir_bndr) + | otherwise = do + return (SymGen SNoLog rt) + +nullNonDet :: Expr -> Bool +nullNonDet (NonDet []) = False +nullNonDet _ = True + +instFuncTickName :: Name +instFuncTickName = Name "INST_FUNC_TICK" Nothing 0 Nothing + +argumentNames :: ExState s m => Name -> m [Name] +argumentNames n = do + e <- lookupE n + case e of + Just e' -> return . concatMap tyConNames $ anonArgumentTypes e' + Nothing -> return [] + +returnNames :: ExState s m => Name -> m [Name] +returnNames n = do + e <- lookupE n + case e of + Just e' -> return . tyConNames $ returnType e' + Nothing -> return [] + +tyConNames :: Type -> [Name] +tyConNames (TyCon n t) = n:tyConNames t +tyConNames t = evalChildren tyConNames t + +-- | Eliminates the real branch of the non-deterministic choices, leaving only +-- the abstract branch. Assumes all non-determinisitic choices are for +-- counterfactual symbolic execution. +onlyCounterfactual :: ASTContainer m Expr => m -> m +onlyCounterfactual = modifyASTs onlyCounterfactual' + +onlyCounterfactual' :: Expr -> Expr +onlyCounterfactual' (NonDet [_, e]) = e +onlyCounterfactual' e = e + +-- | Eliminate all Asserts, except for the functions with names in the HashSet +elimNonTop :: S.HashSet Name -> State t -> State t +elimNonTop hs s@(State { expr_env = eenv }) = s { expr_env = E.mapWithKey (elimNonTop' hs) eenv } + +elimNonTop' :: S.HashSet Name -> Name -> Expr -> Expr +elimNonTop' hs n e = if n `S.member` hs then e else elimAsserts e diff --git a/src/G2/Liquid/AddLHTC.hs b/src/G2/Liquid/AddLHTC.hs --- a/src/G2/Liquid/AddLHTC.hs +++ b/src/G2/Liquid/AddLHTC.hs @@ -2,13 +2,14 @@ {-# LANGUAGE OverloadedStrings #-} module G2.Liquid.AddLHTC ( addLHTC - , addLHTCExprPasses ) where + , addLHTCCurrExpr + , addLHTCExprPasses ) where import G2.Language import G2.Language.Monad import G2.Liquid.Types -import qualified Data.Map as M +import qualified Data.HashMap.Lazy as HM -- | Adds the LiquidHaskell typeclass to all functions in the ExprEnv, and to -- the current expression. This requires: @@ -18,9 +19,12 @@ addLHTC :: LHStateM () addLHTC = do mapME addLHTCExprEnv + addLHTCCurrExpr +addLHTCCurrExpr :: LHStateM () +addLHTCCurrExpr = do (CurrExpr er ce) <- currExpr - ce' <- addLHTCExprPasses M.empty ce + ce' <- addLHTCExprPasses HM.empty ce putCurrExpr (CurrExpr er ce') addLHTCExprEnv :: Expr -> LHStateM Expr @@ -43,7 +47,7 @@ addTypeLams' :: Type -> Expr -> LHStateM Expr addTypeLams' (TyForAll _ t) (Lam TypeL i e) = return . Lam TypeL i =<< addTypeLams' t e -addTypeLams' (TyForAll (NamedTyBndr i) t) e = +addTypeLams' (TyForAll i t) e = return . Lam TypeL i =<< addTypeLams' t (App e (Type (TyVar i))) addTypeLams' _ e = return e @@ -62,7 +66,7 @@ addTypeLamsLet' e = return e -- Updates a function definition with Lambdas to take the LH TC for each type argument. -addLHTCExprEnvLams :: [Id] -> Expr -> LHStateM (Expr, M.Map Name Id) +addLHTCExprEnvLams :: [Id] -> Expr -> LHStateM (Expr, HM.HashMap Name Id) addLHTCExprEnvLams is (Lam TypeL i e) = do (e', m) <- addLHTCExprEnvLams (i:is) e return (Lam TypeL i e', m) @@ -70,7 +74,7 @@ lh <- lhTCM let is' = reverse is - let is'' = map (TyApp (TyCon lh (TyApp TYPE TYPE)) . TyVar) $ is' + let is'' = map (TyApp (TyCon lh (TyFun TYPE TYPE)) . TyVar) $ is' is''' <- freshIdsN is'' -- Lambdas may be nested in an Expr (for example, if the lambda is in a Let) @@ -80,19 +84,19 @@ let e' = foldr (Lam TermL) le is''' - let m = M.fromList $ zip (map idName is') is''' + let m = HM.fromList $ zip (map idName is') is''' - return (e', M.union m m') + return (e', HM.union m m') -addLHTCExprEnvNextLams :: Expr -> LHStateM (Expr, M.Map Name Id) -addLHTCExprEnvNextLams e@(Var _) = return (e, M.empty) -addLHTCExprEnvNextLams e@(Lit _) = return (e, M.empty) -addLHTCExprEnvNextLams e@(Prim _ _) = return (e, M.empty) -addLHTCExprEnvNextLams e@(Data _) = return (e, M.empty) +addLHTCExprEnvNextLams :: Expr -> LHStateM (Expr, HM.HashMap Name Id) +addLHTCExprEnvNextLams e@(Var _) = return (e, HM.empty) +addLHTCExprEnvNextLams e@(Lit _) = return (e, HM.empty) +addLHTCExprEnvNextLams e@(Prim _ _) = return (e, HM.empty) +addLHTCExprEnvNextLams e@(Data _) = return (e, HM.empty) addLHTCExprEnvNextLams (App e1 e2) = do (e1', m1) <- addLHTCExprEnvNextLams e1 (e2', m2) <- addLHTCExprEnvNextLams e2 - return (App e1' e2', M.union m1 m2) + return (App e1' e2', HM.union m1 m2) addLHTCExprEnvNextLams e@(Lam TypeL _ _) = addLHTCExprEnvLams [] e addLHTCExprEnvNextLams (Lam TermL i e) = do (e', m) <- addLHTCExprEnvNextLams e @@ -104,35 +108,35 @@ ) b (e', m) <- addLHTCExprEnvNextLams e - return (Let b' e', foldr M.union M.empty (m:ms)) -addLHTCExprEnvNextLams (Case e i a) = do + return (Let b' e', foldr HM.union HM.empty (m:ms)) +addLHTCExprEnvNextLams (Case e i t a) = do (e', m) <- addLHTCExprEnvNextLams e (a', ms) <- return . unzip =<< mapM addLHTCExprEnvNextLamsAlt a - return (Case e' i a', foldr M.union M.empty (m:ms)) -addLHTCExprEnvNextLams e@(Type _) = return (e, M.empty) + return (Case e' i t a', foldr HM.union HM.empty (m:ms)) +addLHTCExprEnvNextLams e@(Type _) = return (e, HM.empty) addLHTCExprEnvNextLams (Cast e c) = do (e', m) <- addLHTCExprEnvNextLams e return (Cast e' c, m) -addLHTCExprEnvNextLams e@(Coercion _) = return (e, M.empty) +addLHTCExprEnvNextLams e@(Coercion _) = return (e, HM.empty) addLHTCExprEnvNextLams (Tick t e) = do (e', m) <- addLHTCExprEnvNextLams e return (Tick t e', m) addLHTCExprEnvNextLams (NonDet es) = do (es', ms) <- return . unzip =<< mapM addLHTCExprEnvNextLams es - return (NonDet es', foldr M.union M.empty ms) -addLHTCExprEnvNextLams e@(SymGen _) = return (e, M.empty) + return (NonDet es', foldr HM.union HM.empty ms) +addLHTCExprEnvNextLams e@(SymGen _ _) = return (e, HM.empty) addLHTCExprEnvNextLams (Assume fc e1 e2) = do (e1', m1) <- addLHTCExprEnvNextLams e1 (e2', m2) <- addLHTCExprEnvNextLams e2 - return (Assume fc e1' e2', M.union m1 m2) + return (Assume fc e1' e2', HM.union m1 m2) addLHTCExprEnvNextLams (Assert fc e1 e2) = do (e1', m1) <- addLHTCExprEnvNextLams e1 (e2', m2) <- addLHTCExprEnvNextLams e2 - return (Assert fc e1' e2', M.union m1 m2) + return (Assert fc e1' e2', HM.union m1 m2) -addLHTCExprEnvNextLamsAlt :: Alt -> LHStateM (Alt, M.Map Name Id) +addLHTCExprEnvNextLamsAlt :: Alt -> LHStateM (Alt, HM.HashMap Name Id) addLHTCExprEnvNextLamsAlt (Alt am e) = do (e', m) <- addLHTCExprEnvNextLams e return (Alt am e', m) @@ -141,26 +145,34 @@ -- This requires both: -- (1) Modifying the expression, to pass the appropriate arguments -- (2) Modifying the type of the function variable -addLHTCExprEnvPasses :: M.Map Name Id -> Expr -> LHStateM Expr +addLHTCExprEnvPasses :: HM.HashMap Name Id -> Expr -> LHStateM Expr addLHTCExprEnvPasses m e = addLHTCExprPasses m =<< addLHDictToTypes m e -- We only want to pass the LH TC to Var's (aka function calls) -- We DO NOT want to put it in DataCons -addLHTCExprPasses :: M.Map Name Id -> Expr -> LHStateM Expr +addLHTCExprPasses :: HM.HashMap Name Id -> Expr -> LHStateM Expr addLHTCExprPasses m = modifyAppTopE (addLHTCExprPasses' m) -addLHTCExprPasses' :: M.Map Name Id -> Expr -> LHStateM Expr +addLHTCExprPasses' :: HM.HashMap Name Id -> Expr -> LHStateM Expr addLHTCExprPasses' m a@(App _ _) - | (Data _:_) <- unApp a = return a - | otherwise = do - let a' = unApp a - a'' <- addLHTCExprPasses'' m [] a' - return $ mkApp a'' + | (Data _:_) <- as = return a + | otherwise = do + if any (isLHDict) as + then return a + else do + a' <- addLHTCExprPasses'' m [] as + return $ mkApp a' + where + as = unApp a + isLHDict (Var (Id _ t)) + | TyCon (Name "lh" _ _ _) _ <- tyAppCenter t = True + isLHDict _ = False + addLHTCExprPasses' _ e = return e -addLHTCExprPasses'' :: M.Map Name Id -> [Expr] -> [Expr] -> LHStateM [Expr] +addLHTCExprPasses'' :: HM.HashMap Name Id -> [Expr] -> [Expr] -> LHStateM [Expr] addLHTCExprPasses'' _ es [] = return $ reverse es addLHTCExprPasses'' m es (te@(Type t):es') = do dict <- lhTCDict m t @@ -168,34 +180,37 @@ return $ te:as addLHTCExprPasses'' m es (e:es') | Var (Id n _) <- e - , Just dict <- M.lookup n m = do + , Just dict <- HM.lookup n m = do as <- addLHTCExprPasses'' m (Var dict:es) es' return $ e:as | otherwise = do as <- addLHTCExprPasses'' m [] es' return $ reverse es ++ e:as --- We want to add a LH Dict Type argument to Var's, but not DataCons or Lambdas. +-- We want to add a LH Dict Type argument to Var's and Cases, but not DataCons or Lambdas. -- That is: function calls need to be passed the LH Dict but it -- doesn't need to be passed around in DataCons -addLHDictToTypes :: ASTContainerM e Expr => M.Map Name Id -> e -> LHStateM e +addLHDictToTypes :: ASTContainerM e Expr => HM.HashMap Name Id -> e -> LHStateM e addLHDictToTypes m = modifyASTsM (addLHDictToTypes' m) -addLHDictToTypes' :: M.Map Name Id -> Expr -> LHStateM Expr +addLHDictToTypes' :: HM.HashMap Name Id -> Expr -> LHStateM Expr addLHDictToTypes' m (Var (Id n t)) = return . Var . Id n =<< addLHDictToTypes'' m t +addLHDictToTypes' m (Case e i t a) = do + t' <- addLHDictToTypes'' m t + return $ Case e i t' a addLHDictToTypes' _ e = return e -addLHDictToTypes'' :: M.Map Name Id -> Type -> LHStateM Type -addLHDictToTypes'' m t@(TyForAll (NamedTyBndr _) _) = addLHDictToTypes''' m [] t +addLHDictToTypes'' :: HM.HashMap Name Id -> Type -> LHStateM Type +addLHDictToTypes'' m t@(TyForAll _ _) = addLHDictToTypes''' m [] t addLHDictToTypes'' m t = modifyChildrenM (addLHDictToTypes'' m) t -addLHDictToTypes''' :: M.Map Name Id -> [Id] -> Type -> LHStateM Type -addLHDictToTypes''' m is (TyForAll (NamedTyBndr b) t) = - return . TyForAll (NamedTyBndr b) =<< addLHDictToTypes''' m (b:is) t +addLHDictToTypes''' :: HM.HashMap Name Id -> [Id] -> Type -> LHStateM Type +addLHDictToTypes''' m is (TyForAll b t) = + return . TyForAll b =<< addLHDictToTypes''' m (b:is) t addLHDictToTypes''' m is t = do lh <- lhTCM let is' = reverse is - let dictT = map (TyApp (TyCon lh (TyApp TYPE TYPE)) . TyVar) is' + let dictT = map (TyApp (TyCon lh (TyFun TYPE TYPE)) . TyVar) is' -- The recursive step in addLHDictToTypes'' only kicks in when it is not -- at a TyForAll. So we have to perform recursion here, on the type nested @@ -204,13 +219,13 @@ return $ foldr TyFun t' dictT -lhTCDict :: M.Map Name Id -> Type -> LHStateM Expr +lhTCDict :: HM.HashMap Name Id -> Type -> LHStateM Expr lhTCDict m t = do lh <- lhTCM tc <- typeClassInstTC m lh t case tc of Just e -> return $ dropAppedLH e - Nothing -> return $ Var (Id (Name "BAD 2" Nothing 0 Nothing) TyUnknown) + Nothing -> return $ Var (Id (Name "bad2" Nothing 0 Nothing) (TyCon lh (TyFun TYPE TYPE))) where -- typeClassInstTC adds any needed LH Dict arguments for us. -- Unfortunately, the LH Dicts are then added AGAIN, by addLHTCExprEnvPasses diff --git a/src/G2/Liquid/AddOrdToNum.hs b/src/G2/Liquid/AddOrdToNum.hs --- a/src/G2/Liquid/AddOrdToNum.hs +++ b/src/G2/Liquid/AddOrdToNum.hs @@ -23,13 +23,17 @@ addOrdToNum :: LHStateM () addOrdToNum = do tc <- typeClasses + lh_tc <- lhRenamedTCM num <- numTCM -- Rewrite dictionary declaration let tcd = lookupTCDicts num tc - case tcd of - Just tcd' -> mapM_ (uncurry addOrdToNumDictDec) tcd' - Nothing -> return () + lh_tcd = lookupTCDicts num lh_tc + case (tcd, lh_tcd) of + (Just tcd', Just lh_tcd') -> do + mapM_ (uncurry (addOrdToNumDictDec lookupE insertE)) tcd' + mapM_ (uncurry (addOrdToNumDictDec lookupMeasureM insertMeasureM)) lh_tcd' + _ -> return () -- Rewrite case statements mapME addOrdToNumCase @@ -45,11 +49,15 @@ -- Create a function to extract the Ord Dict ordDictFunc -addOrdToNumDictDec :: Type -> Id -> LHStateM () -addOrdToNumDictDec t (Id n _) = do +addOrdToNumDictDec :: (Name -> LHStateM (Maybe Expr)) + -> (Name -> Expr -> LHStateM ()) + -> Type + -> Id + -> LHStateM () +addOrdToNumDictDec lkup insert t (Id n _) = do ord <- ordTCM - me <- lookupE n + me <- lkup n case me of Just e -> do @@ -58,14 +66,14 @@ e' <- insertInLamsE (\_ e'' -> return (App e'' ordD')) e - insertE n e' + insert n e' Nothing -> return () addOrdToNumCase :: Expr -> LHStateM Expr addOrdToNumCase = modifyASTsM addOrdToNumCase' addOrdToNumCase' :: Expr -> LHStateM Expr -addOrdToNumCase' ce@(Case e i@(Id _ t) a@[Alt (DataAlt dc is) ae]) +addOrdToNumCase' ce@(Case e i@(Id _ t) ct a@[Alt (DataAlt dc is) ae]) | (TyCon n ts) <- tyAppCenter t = do num <- numTCM ord <- ordTCM @@ -75,8 +83,8 @@ if num == n then do ordI <- freshIdN ordT let is' = is ++ [ordI] - return (Case e i [Alt (DataAlt dc is') ae]) - else return (Case e i a) + return (Case e i ct [Alt (DataAlt dc is') ae]) + else return (Case e i ct a) | otherwise = return ce addOrdToNumCase' e = return e @@ -90,10 +98,10 @@ | (TyCon n _) <- tyAppCenter $ returnType dc , num == n = return . Data =<< changeNumTypeDC dc | otherwise = return d -changeNumType' num ce@(Case e i@(Id n _) [Alt (DataAlt dc is) ae]) +changeNumType' num ce@(Case e i@(Id n _) ct [Alt (DataAlt dc is) ae]) | num == n = do dc' <- changeNumTypeDC dc - return (Case e i [Alt (DataAlt dc' is) ae]) + return (Case e i ct [Alt (DataAlt dc' is) ae]) | otherwise = return ce changeNumType' _ e = return e @@ -103,8 +111,7 @@ return (DataCon n t') changeNumTypeType :: Maybe Id -> Type -> LHStateM Type -changeNumTypeType _ (TyForAll b@(NamedTyBndr i) t) = return . TyForAll b =<< changeNumTypeType (Just i) t -changeNumTypeType i (TyForAll b t) = return . TyForAll b =<< changeNumTypeType i t +changeNumTypeType _ (TyForAll i t) = return . TyForAll i =<< changeNumTypeType (Just i) t changeNumTypeType i (TyFun t t') = return . TyFun t =<< changeNumTypeType i t' changeNumTypeType i t = do ord <- ordTCM @@ -133,10 +140,12 @@ num <- numTCM let numT = TyCon num TYPE - Just numDC <- lookupT num - let [numDC'] = dataCon numDC + numDC <- lookupT num + let [numDC'] = case numDC of + Just ndc -> dataCon ndc + Nothing -> error "ordDictFunc: No NumDC" - let numA = dataConArgs numDC' + let numA = anonArgumentTypes numDC' lamI <- freshIdN numT caseI <- freshIdN numT @@ -144,7 +153,7 @@ binds <- freshIdsN numA let cOrdBIs = last binds - let e = Lam TermL lamI $ Case (Var lamI) caseI [Alt (DataAlt numDC' binds) (Var cOrdBIs)] + let e = Lam TermL lamI $ Case (Var lamI) caseI (typeOf cOrdBIs) [Alt (DataAlt numDC' binds) (Var cOrdBIs)] (Id n _) <- lhNumOrdM insertE n e diff --git a/src/G2/Liquid/AddTyVars.hs b/src/G2/Liquid/AddTyVars.hs new file mode 100644 --- /dev/null +++ b/src/G2/Liquid/AddTyVars.hs @@ -0,0 +1,240 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +module G2.Liquid.AddTyVars ( addTyVarsEEnvTEnv + , addTyVarsMeasures + + , PhantomTyVars) where + +import G2.Initialization.Types +import G2.Language hiding (State (..), Bindings (..)) +import G2.Liquid.Types + +import qualified Data.HashMap.Lazy as HM +import Data.List +import Data.Maybe +import Data.Text as T (pack) + +addTyVarsEEnvTEnv :: SimpleState -> (SimpleState, PhantomTyVars) +addTyVarsEEnvTEnv s@(SimpleState { expr_env = eenv + , type_env = tenv + , known_values = kv + , name_gen = ng }) = + let + (new_mjn, ng') = mkNewMaybe kv ng + + unused_poly = getUnusedPoly tenv + + eenv' = addTyVarsExpr unused_poly eenv ng eenv + tenv' = addTyVarsTypeEnv unused_poly tenv + + tenv'' = addNewMaybe new_mjn tenv' + in + (s { expr_env = eenv', type_env = tenv'', name_gen = ng' } + , PhantomTyVars { ph_new_maybe = new_mjn, ph_unused_poly = unused_poly }) + +addTyVarsMeasures :: PhantomTyVars -> LHStateM () +addTyVarsMeasures PhantomTyVars { ph_unused_poly = unused_poly } = do + meenv <- measuresM + ng <- nameGen + putMeasuresM (addTyVarsExpr unused_poly meenv ng meenv) + +-- | Identifies data constructors with unused polymorphic arguments +getUnusedPoly :: TypeEnv -> UnusedPoly +getUnusedPoly tenv = + let + adts = HM.elems tenv + in + foldr unionUP emptyUP $ map getUnusedPoly' adts + +getUnusedPoly' :: AlgDataTy -> UnusedPoly +getUnusedPoly' adt = + let + bound = bound_ids adt + dcs = case adt of + DataTyCon { data_cons = dcs' } -> dcs' + NewTyCon {} -> [] + TypeSynonym {} -> [] + in + foldr (uncurry insertUP) emptyUP $ mapMaybe (getUnusedPoly'' bound) dcs + +getUnusedPoly'' :: [Id] -> DataCon -> Maybe (Name, [Int]) +getUnusedPoly'' is dc@(DataCon n _) = + let + used = tyVarIds . argumentTypes . PresType . inTyForAlls $ typeOf dc + in + case filter (flip notElem used) is of + [] -> Nothing + not_used -> Just (n, getTypeInds not_used (typeOf dc)) + +getTypeInds :: [Id] -> Type -> [Int] +getTypeInds is t = + map fst + . filter (flip elem is . snd) + . zip [0..] + . leadingTyForAllBindings + $ PresType t + +------------------------------- +-- Adjust TypeEnv +------------------------------- +addTyVarsTypeEnv :: UnusedPoly -> TypeEnv -> TypeEnv +addTyVarsTypeEnv unused = HM.map (addTyVarADT unused) + +addTyVarADT :: UnusedPoly -> AlgDataTy -> AlgDataTy +addTyVarADT unused dtc@(DataTyCon { data_cons = dcs }) = + dtc { data_cons = map (addTyVarDC unused) dcs } +addTyVarADT _ adt = adt + +addNewMaybe :: NewMaybe -> TypeEnv -> TypeEnv +addNewMaybe new_mb@(NewMaybe { new_maybe = new_mb_t }) tenv = + let + dtc = DataTyCon { bound_ids = [Id (new_maybe_bound new_mb) TYPE] + , data_cons = [mkNewJustDC new_mb, mkNewNothingDC new_mb] } + in + HM.insert new_mb_t dtc tenv + +------------------------------- +-- Adjust Expr +------------------------------- + +addTyVarsExpr :: ASTContainer m Expr => UnusedPoly -> ExprEnv -> NameGen -> m -> m +addTyVarsExpr unused eenv ng = + modifyASTs (addTyVarsExprCase unused) . addTyVarsExprDC unused . etaExpandDC eenv ng + +etaExpandDC :: ASTContainer m Expr => ExprEnv -> NameGen -> m -> m +etaExpandDC eenv ng = modifyAppedDatas (etaExpandDC' eenv ng) + +etaExpandDC' :: ExprEnv -> NameGen -> DataCon -> [Expr] -> Expr +etaExpandDC' eenv ng dc ars = + let + e = mkApp (Data dc:ars) + num_binds = length $ leadingTyForAllBindings dc + (e', _) = etaExpandTo eenv ng num_binds e + in + e' + +addTyVarsExprDC :: ASTContainer m Expr => UnusedPoly -> m -> m +addTyVarsExprDC unused = modifyAppedDatas (addTyVarsExprDC' unused) + +addTyVarsExprDC' :: UnusedPoly -> DataCon -> [Expr] -> Expr +addTyVarsExprDC' unused dc@(DataCon n _) ars + | Just is <- lookupUP n unused = + let + (ty_ars, expr_ars) = partition (isTypeExpr) ars + + sym_gens = map (\(Type t) -> SymGen SNoLog t) $ map (ars !!) is + -- nothings = map (\(Type t) -> mkNewNothing new_mb) $ map (ars !!) is + in + mkApp $ Data (addTyVarDC unused dc):ty_ars ++ sym_gens ++ expr_ars + | otherwise = mkApp $ Data dc:ars + +addTyVarsExprCase :: UnusedPoly -> Expr -> Expr +addTyVarsExprCase unused (Case e i t as) = + Case e i t $ map (addTyVarsAlt unused e) as +addTyVarsExprCase _ e = e + +addTyVarsAlt :: UnusedPoly -> Expr -> Alt -> Alt +addTyVarsAlt unused case_e (Alt (DataAlt dc@(DataCon n _) is) alt_e) + | Just i <- lookupUP n unused = + let + dc' = addTyVarDC unused dc + + ty_binds = reverse . unTyApp $ typeOf case_e + + n_str = "a_FILLING_IN_HERE" + new_is = map (\(l, tyi) -> Id (Name (T.pack $ n_str ++ show l) Nothing 0 Nothing) $ tyi) + . zip ([0..] :: [Int]) + $ map (ty_binds !!) i + is' = new_is ++ is + in + Alt (DataAlt dc' is') alt_e +addTyVarsAlt _ _ alt = alt + +------------------------------- +-- Generic +------------------------------- +addTyVarDC :: UnusedPoly -> DataCon -> DataCon +addTyVarDC unused dc@(DataCon n t) + | Just is <- lookupUP n unused = DataCon n (addTyVarsToType is t) + | otherwise = dc + +addTyVarsToType :: [Int] -> Type -> Type +addTyVarsToType i t = + let + ty_binds = leadingTyForAllBindings (PresType t) + is = map (ty_binds !!) i + in + mapInTyForAlls (\t' -> mkTyFun $ map TyVar is ++ [t']) t + +isTypeExpr :: Expr -> Bool +isTypeExpr (Type _) = True +isTypeExpr _ = False + +------------------------------- +-- Added TyVar +------------------------------- + +data PhantomTyVars = PhantomTyVars { ph_new_maybe :: NewMaybe, ph_unused_poly :: UnusedPoly } + +------------------------------- +-- New Maybe +------------------------------- +data NewMaybe = NewMaybe { new_maybe :: Name + + , new_maybe_bound :: Name + , new_just :: Name + , new_nothing :: Name } + +mkNewMaybe :: KnownValues -> NameGen -> (NewMaybe, NameGen) +mkNewMaybe _ ng = + let + ((n_m, n_j, n_n), ng') = renameAll ( Name "NewMaybe" Nothing 0 Nothing + , Name "NewJust" Nothing 0 Nothing + , Name "NewNothing" Nothing 0 Nothing) ng + bnd = Name "a_NEW_MAYBE" Nothing 0 Nothing + in + (NewMaybe { new_maybe = n_m, new_maybe_bound = bnd, new_just = n_j, new_nothing = n_n }, ng') + +mkNewJustDC :: NewMaybe -> DataCon +mkNewJustDC new_mb = + let + n = new_just new_mb + + a = new_maybe_bound new_mb + tya = TyVar (Id a TYPE) + t = TyForAll (Id a TYPE) + . TyFun tya + $ TyApp (TyCon (new_maybe new_mb) TYPE) tya + in + DataCon n t + +mkNewNothingDC :: NewMaybe -> DataCon +mkNewNothingDC new_mb = + let + n = new_nothing new_mb + + a = new_maybe_bound new_mb + tya = TyVar (Id a TYPE) + t = TyForAll (Id a TYPE) + $ TyApp (TyCon (new_maybe new_mb) TYPE) tya + in + DataCon n t + +------------------------------- +-- UnusedPoly +------------------------------- +newtype UnusedPoly = UnusedPoly (HM.HashMap Name [Int]) + deriving (Show, Read) + +emptyUP :: UnusedPoly +emptyUP = UnusedPoly HM.empty + +lookupUP :: Name -> UnusedPoly -> Maybe [Int] +lookupUP n (UnusedPoly up) = HM.lookup n up + +insertUP :: Name -> [Int] -> UnusedPoly -> UnusedPoly +insertUP n is (UnusedPoly up) = UnusedPoly $ HM.insert n is up + +unionUP :: UnusedPoly -> UnusedPoly -> UnusedPoly +unionUP (UnusedPoly up1) (UnusedPoly up2) = UnusedPoly $ HM.union up1 up2 diff --git a/src/G2/Liquid/Annotations.hs b/src/G2/Liquid/Annotations.hs --- a/src/G2/Liquid/Annotations.hs +++ b/src/G2/Liquid/Annotations.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE CPP, MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} module G2.Liquid.Annotations ( AnnotMap @@ -25,9 +25,11 @@ import Data.Maybe import qualified Data.Text as T +#if MIN_VERSION_GLASGOW_HASKELL(9,0,2,0) +import GHC.Types.SrcLoc +#else import SrcLoc - -import Debug.Trace +#endif lookupAnnot :: Name -> AnnotMap -> Maybe [(Maybe T.Text, Expr)] lookupAnnot (Name _ _ _ (Just s)) = @@ -69,7 +71,7 @@ let ai = leadingLamUsesIds e' dm <- dictMapFromIds (map snd ai) - ce <- convertSpecType dm M.empty (map snd ai) (Just i) ast + ce <- convertSpecType CheckPre dm HM.empty (map snd ai) (Just i) ast let ce' = addIds ce (ai ++ [(TermL, i)]) insertAnnotM spn n ce' @@ -118,7 +120,7 @@ pickOneA xas = case (rs, ds, ls, us) of (x:_, _, _, _) -> [x] (_, x:_, _, _) -> [x] - (_, _, _:_, _) -> trace ("Loc") [] + (_, _, _:_, _) -> [] (_, _, _, x:_) -> [x] -- (_, x:_, _, _) -> [x] diff --git a/src/G2/Liquid/Config.hs b/src/G2/Liquid/Config.hs new file mode 100644 --- /dev/null +++ b/src/G2/Liquid/Config.hs @@ -0,0 +1,83 @@ +module G2.Liquid.Config ( LHConfig (..) + , Counterfactual (..) + , CFModules (..) + , BlockErrorsMethod (..) + , getLHConfig + , mkLHConfig + , mkLHConfigDirect) where + +import G2.Config.Config + +import qualified Data.HashSet as S +import qualified Data.Map.Lazy as M +import Data.Monoid ((<>)) +import qualified Data.Text as T +import Options.Applicative +import System.Directory + +data Counterfactual = Counterfactual CFModules | NotCounterfactual deriving (Eq, Show, Read) + +data CFModules = CFAll | CFOnly (S.HashSet (T.Text, Maybe T.Text)) deriving (Eq, Show, Read) + +data BlockErrorsMethod = ArbBlock + | AssumeBlock deriving (Eq, Show, Read) + +data LHConfig = LHConfig { + cut_off :: Int -- ^ How many steps to take after finding an equally good equiv state, in LH mode + , switch_after :: Int --- ^ How many steps to take in a single step, in LH mode + , counterfactual :: Counterfactual -- ^ Which functions should be able to generate abstract counterexamples + , only_top :: Bool -- ^ Only try to find counterexamples in the very first function definition, or directly called functions? + , block_errors_in :: (S.HashSet (T.Text, Maybe T.Text)) -- ^ Prevents calls from errors occuring in the indicated functions + , block_errors_method :: BlockErrorsMethod -- ^ Should errors be blocked with an Assume or with an arbitrarily inserted value + , reduce_abs :: Bool + , add_tyvars :: Bool + } + +getLHConfig :: IO (String, String, Config, LHConfig) +getLHConfig = do + homedir <- getHomeDirectory + execParser (mkConfigInfo homedir) + +mkConfigInfo :: String -> ParserInfo (String, String, Config, LHConfig) +mkConfigInfo homedir = + info (((,,,) <$> getFileName <*> getFunctionName <*> mkConfig homedir <*> mkLHConfig) <**> helper) + ( fullDesc + <> progDesc "Allows symbolically executing LiquidHaskell code" + <> header "The G2 Symbolic Execution Engine" ) + +getFileName :: Parser String +getFileName = argument str (metavar "FILE") + +getFunctionName :: Parser String +getFunctionName = argument str (metavar "FUNCTION") + +mkLHConfig :: Parser LHConfig +mkLHConfig = LHConfig + <$> option auto (long "cut-off" + <> metavar "N" + <> value 600 + <> help "how many steps to take after finding an equally good equivalent state, in LH mode ") + <*> option auto (long "switch-after" + <> metavar "N" + <> value 300 + <> help "how many steps to take before switching states, in LH mode ") + <*> flag (Counterfactual CFAll) (NotCounterfactual) (long "no-counterfactual" <> help "disable counterfactual counterexamples") + <*> pure False + <*> pure S.empty + <*> pure AssumeBlock + <*> pure True + <*> pure False + + +mkLHConfigDirect :: [String] -> M.Map String [String] -> LHConfig +mkLHConfigDirect as m = LHConfig { + cut_off = strArg "cut-off" as m read 600 + , switch_after = strArg "switch-after" as m read 300 + , counterfactual = boolArg' "counterfactual" as + (Counterfactual CFAll) (Counterfactual CFAll) NotCounterfactual + , only_top = False + , block_errors_in = S.empty + , block_errors_method = AssumeBlock + , reduce_abs = True + , add_tyvars = False +} diff --git a/src/G2/Liquid/Conversion.hs b/src/G2/Liquid/Conversion.hs --- a/src/G2/Liquid/Conversion.hs +++ b/src/G2/Liquid/Conversion.hs @@ -1,27 +1,35 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE CPP, FlexibleContexts #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} module G2.Liquid.Conversion ( LHDictMap - , DictMaps (..) - , BoundTypes - , mergeLHSpecState - , convertSpecType - , dictMapFromIds - , convertLHExpr - , specTypeToType - , unsafeSpecTypeToType - , symbolName - , lhTCDict') where + , DictMaps (..) + , BoundTypes + , CheckPre (..) + , mergeLHSpecState + , convertSpecType + , dictMapFromIds + , convertLHExpr + , specTypeToType + , unsafeSpecTypeToType + , symbolName + , lhTCDict' + , higherOrderTickName) where + import G2.Language import qualified G2.Language.KnownValues as KV import G2.Language.Monad import qualified G2.Language.ExprEnv as E +import G2.Language.TypeEnv import G2.Liquid.Types import G2.Translation.Haskell +#if MIN_VERSION_GLASGOW_HASKELL(9,0,2,0) +import qualified GHC.Types.Var as Var +#else import qualified Var as Var +#endif import Language.Fixpoint.Types.Names import Language.Fixpoint.Types.Sorts @@ -37,56 +45,72 @@ import qualified Data.Text as T -- | A mapping of TyVar Name's, to Id's for the LH dict's -type LHDictMap = M.Map Name Id +type LHDictMap = HM.HashMap Name Id -- | A mapping of TyVar Name's, to Id's for the Num dict's -type NumDictMap = M.Map Name Id +type NumDictMap = HM.HashMap Name Id -- | A mapping of TyVar Name's, to Id's for the Integral dict's -type IntegralDictMap = M.Map Name Id +type IntegralDictMap = HM.HashMap Name Id +-- | A mapping of TyVar Name's, to Id's for the Fractional dict's +type FractionalDictMap = HM.HashMap Name Id + -- | A mapping of TyVar Name's, to Id's for the Ord dict's -type OrdDictMap = M.Map Name Id +type OrdDictMap = HM.HashMap Name Id -- | A collection of all DictMaps required to convert LH refinement types to G2 `Expr`@s@ data DictMaps = DictMaps { lh_dicts :: LHDictMap , num_dicts :: NumDictMap , integral_dicts :: IntegralDictMap + , fractional_dicts :: FractionalDictMap , ord_dicts :: OrdDictMap } deriving (Eq, Show, Read) copyIds :: Name -> Name -> DictMaps -> DictMaps -copyIds n1 n2 dm@(DictMaps { lh_dicts = lhd, num_dicts = nd, integral_dicts = ind, ord_dicts = od }) = +copyIds n1 n2 dm@(DictMaps { lh_dicts = lhd + , num_dicts = nd + , integral_dicts = ind + , fractional_dicts = frac + , ord_dicts = od }) = let - dm2 = case M.lookup n1 lhd of - Just lh -> dm { lh_dicts = M.insert n2 lh lhd } + dm2 = case HM.lookup n1 lhd of + Just lh -> dm { lh_dicts = HM.insert n2 lh lhd } Nothing -> dm - dm3 = case M.lookup n1 nd of - Just num -> dm2 { num_dicts = M.insert n2 num nd } + dm3 = case HM.lookup n1 nd of + Just num -> dm2 { num_dicts = HM.insert n2 num nd } Nothing -> dm2 - dm4 = case M.lookup n1 ind of - Just int -> dm3 { integral_dicts = M.insert n2 int ind } + dm4 = case HM.lookup n1 ind of + Just int -> dm3 { integral_dicts = HM.insert n2 int ind } Nothing -> dm3 - dm5 = case M.lookup n1 od of - Just ord -> dm4 { ord_dicts = M.insert n2 ord od } + dm5 = case HM.lookup n1 frac of + Just fr -> dm4 { fractional_dicts = HM.insert n2 fr frac } Nothing -> dm4 + + dm6 = case HM.lookup n1 od of + Just ord -> dm5 { ord_dicts = HM.insert n2 ord od } + Nothing -> dm5 in - dm5 + dm6 -- | A mapping of variable names to the corresponding types -type BoundTypes = M.Map Name Type +type BoundTypes = HM.HashMap Name Type -mergeLHSpecState :: [(Var.Var, LocSpecType)] -> LHStateM () -mergeLHSpecState = mapM_ (uncurry mergeLHSpecState') +type NMExprEnv = HM.HashMap (T.Text, Maybe T.Text) (Name, Expr) -mergeLHSpecState' :: Var.Var -> LocSpecType -> LHStateM () -mergeLHSpecState' v lst = do +mergeLHSpecState :: [(Var.Var, LocSpecType)] -> LHStateM () +mergeLHSpecState var_st = do eenv <- exprEnv + let nm_eenv = E.nameModMap eenv + mapM_ (uncurry (mergeLHSpecState' nm_eenv)) var_st + +mergeLHSpecState' :: NMExprEnv -> Var.Var -> LocSpecType -> LHStateM () +mergeLHSpecState' nm_eenv v lst = do let (Id (Name n m _ _) _) = mkIdUnsafe v - g2N = E.lookupNameMod n m eenv + g2N = HM.lookup (n, m) nm_eenv case g2N of Just (n', e) -> do @@ -97,10 +121,14 @@ assumpt <- createAssumption (val lst) e insertAssumptionM n' assumpt + + post <- createPost (val lst) e + insertPostM n' post False -> return () Nothing -> return () convertVar :: Name -> Bool +convertVar (Name "fromInteger" _ _ _) = False convertVar (Name "error" _ _ _) = False convertVar (Name "patError" _ _ _) = False convertVar (Name "." _ _ _) = False @@ -118,25 +146,36 @@ -- Gather up LH TC's to use in Assertion dm@(DictMaps {lh_dicts = lhm}) <- dictMapFromIds is - let e' = foldl' (\e_ -> App e_ . Var) e is + trueE <- mkTrueE + higher_is <- handleHigherOrderSpecs CheckPre (mkHigherAssert trueE) lh dm (HM.map typeOf lhm) is st + let e' = foldl' App e . map (\(i, hi) -> maybe (Var i) id hi) $ zip is higher_is + -- Create a variable for the returned value -- We do not pass the LH TC to the assertion, since there is no matching -- lambda for it in the LH Spec r <- freshIdN (typeOf e') let is' = filter (not . isTC lh . typeOf) is - assert <- convertAssertSpecType dm (M.map typeOf lhm) is' r st + assert <- convertAssertSpecType dm (HM.map typeOf lhm) is' r st let fc = FuncCall { funcName = fn , arguments = map Var is , returns = Var r } - let rLet = Let [(r, e')] $ Assert (Just fc) assert (Var r) + e'' = modifyASTs (repAssertFC fc) e' + let rLet = Let [(r, e'')] $ Assert (Just fc) assert (Var r) let e''' = foldr (uncurry Lam) rLet $ zip lu is return e''' + where + -- We insert an extra, redundant assume to record information about the function being used as a higher order function + mkHigherAssert true_dc spec i ars ret = + Tick (NamedLoc higherOrderTickName) . Assume (Just $ FuncCall { funcName = idName i, arguments = map Var ars, returns = Var ret }) true_dc $ Assert Nothing spec (Var ret) -createAssumption :: SpecType -> Expr -> LHStateM Expr + repAssertFC fc_ (Assert Nothing e1 e2) = Assert (Just fc_) e1 e2 + repAssertFC _ e_ = e_ + +createAssumption :: SpecType -> Expr -> LHStateM ([(LamUse, Id)], [Maybe Expr], Expr) createAssumption st e = do lh <- lhTCM @@ -148,38 +187,57 @@ let is' = filter (not . isTC lh . typeOf) is dm@(DictMaps {lh_dicts = lhm}) <- dictMapFromIds is - assume <- convertAssumeSpecType dm (M.map typeOf lhm) is' st + assume <- convertAssumeSpecType dm (HM.map typeOf lhm) is' st + higher_is <- handleHigherOrderSpecs CheckOnlyPost mkHigherAssume lh dm (HM.map typeOf lhm) is st - return . foldr (uncurry Lam) assume $ zip lu is + let assume' = foldr (uncurry Lam) assume $ zip lu is + return (zip lu is, higher_is, assume') + where + mkHigherAssume spec i ars ret = + Tick (NamedLoc higherOrderTickName) $ Assume (Just $ FuncCall { funcName = idName i, arguments = map Var ars, returns = Var ret } ) spec (Var ret) +higherOrderTickName :: Name +higherOrderTickName = Name "HIGHER_ORDER_FUNC" Nothing 0 Nothing +createPost :: SpecType -> Expr -> LHStateM Expr +createPost st e = do + lh <- lhTCM + + -- Create new bindings to use in the Ref. Type + let argT = spArgumentTypes e + is <- mapM argsFromArgT argT + let lu = map argTypeToLamUse argT + + r <- freshIdN (returnType e) + let is' = filter (not . isTC lh . typeOf) is + dm@(DictMaps {lh_dicts = lhm}) <- dictMapFromIds is + + pst <- convertPostSpecType dm (HM.map typeOf lhm) is' r st + + return . foldr (uncurry Lam) pst $ zip (lu ++ [TermL]) (is ++ [r]) + + + dictMapFromIds :: [Id] -> LHStateM DictMaps dictMapFromIds is = do lh <- lhTCM - num <- numTCM + num <- lhNumTCM int <- return . KV.integralTC =<< knownValues + frac <- return . KV.fractionalTC =<< knownValues ord <- ordTCM let lhm = tcWithNameMap lh is let nm = tcWithNameMap num is let im = tcWithNameMap int is + let fr = tcWithNameMap frac is let om = tcWithNameMap ord is return $ DictMaps { lh_dicts = lhm , num_dicts = nm , integral_dicts = im + , fractional_dicts = fr , ord_dicts = om } -tcWithNameMap :: Name -> [Id] -> M.Map Name Id -tcWithNameMap n = - M.fromList - . map (\i -> (forType $ typeOf i, i)) - . filter (isTC n . typeOf) - where - forType :: Type -> Name - forType (TyApp _ (TyVar (Id n' _))) = n' - forType _ = error "Bad type in forType" - isTC :: Name -> Type -> Bool isTC n t = case tyAppCenter t of TyCon n' _ -> n == n' @@ -189,107 +247,148 @@ argsFromArgT (AnonType t) = freshIdN t argsFromArgT (NamedType i) = return i +-- | Should we translate the precondition in convertSpecType? +data CheckPre = CheckPre | CheckOnlyPost deriving Eq + convertAssumeSpecType :: DictMaps -> BoundTypes -> [Id] -> SpecType -> LHStateM Expr convertAssumeSpecType m bt is st = do - convertSpecType m bt is Nothing st + convertSpecType CheckPre m bt is Nothing st convertAssertSpecType :: DictMaps -> BoundTypes -> [Id] -> Id -> SpecType -> LHStateM Expr convertAssertSpecType m bt is r st = do - convertSpecType m bt is (Just r) st + convertSpecType CheckPre m bt is (Just r) st +convertPostSpecType :: DictMaps -> BoundTypes -> [Id] -> Id -> SpecType -> LHStateM Expr +convertPostSpecType m bt is r st = + convertSpecType CheckOnlyPost m bt is (Just r) st -- | See also: convertAssumeSpecType, convertAssertSpecType -- We can Maybe pass an Id for the value returned by the function -- If we do, our Expr includes the Refinement on the return value, -- otherwise it does not. This allows us to use this same function to -- translate both for assumptions and assertions -convertSpecType :: DictMaps -> BoundTypes -> [Id] -> Maybe Id -> SpecType -> LHStateM Expr -convertSpecType m bt _ r (RVar {rt_var = (RTV v), rt_reft = ref}) +convertSpecType :: CheckPre -> DictMaps -> BoundTypes -> [Id] -> Maybe Id -> SpecType -> LHStateM Expr +convertSpecType _ m bt _ r (RVar {rt_var = (RTV v), rt_reft = ref}) | Just r' <- r = do let symb = reftSymbol $ ur_reft ref let i = mkIdUnsafe v let symbId = convertSymbolT symb (TyVar i) - let bt' = M.insert (idName symbId) (typeOf symbId) bt + let bt' = HM.insert (idName symbId) (typeOf symbId) bt re <- convertLHExpr m bt' Nothing (reftExpr $ ur_reft ref) return $ App (Lam TermL symbId re) (Var r') | otherwise = mkTrueE -convertSpecType m bt (i:is) r (RFun {rt_bind = b, rt_in = fin, rt_out = fout }) = do +convertSpecType cp m bt (i:is) r (RFun {rt_bind = b, rt_in = fin, rt_out = fout }) = do t <- unsafeSpecTypeToType fin let i' = convertSymbolT b t - let bt' = M.insert (idName i') t bt + let bt' = HM.insert (idName i') t bt - e <- convertSpecType m bt' is r fout + e <- convertSpecType cp m bt' is r fout case hasFuncType i of True -> return $ App (Lam TermL i' e) (Var i) False -> do - e' <- convertSpecType m bt' [] (Just i') fin + e' <- convertSpecType cp m bt' [] (Just i') fin an <- lhAndE - let e'' = App (App an e) e' + let e'' = if cp == CheckPre + then App (App an e') e + else e return $ App (Lam TermL i' e'') (Var i) -convertSpecType m bt (i:is) r (RAllT {rt_tvbind = RTVar (RTV v) _, rt_ty = rty}) = do +convertSpecType cp m bt (i:is) r (RAllT {rt_tvbind = RTVar (RTV v) _, rt_ty = rty}) = do let i' = mkIdUnsafe v let m' = copyIds (idName i) (idName i') m - let bt' = M.insert (idName i') (typeOf i) bt + let bt' = HM.insert (idName i') (typeOf i) bt - e <- convertSpecType m' bt' is r rty + e <- convertSpecType cp m' bt' is r rty return $ App (Lam TypeL i' e) (Var i) -convertSpecType m bt _ r (RApp {rt_tycon = c, rt_reft = ref, rt_args = as}) +convertSpecType cp m bt _ r (RApp {rt_tycon = c, rt_reft = ref, rt_args = as}) | Just r' <- r = do let symb = reftSymbol $ ur_reft ref ty <- return . maybe (error "Error in convertSpecType") id =<< rTyConType c as let i = convertSymbolT symb ty - let bt' = M.insert (idName i) ty bt + let bt' = HM.insert (idName i) ty bt - argsPred <- polyPredFunc as ty m bt' r' + argsPred <- polyPredFunc cp as ty m bt' r' re <- convertLHExpr m bt' Nothing (reftExpr $ ur_reft ref) an <- lhAndE return $ App (App an (App (Lam TermL i re) (Var r'))) argsPred | otherwise = mkTrueE -convertSpecType _ _ _ _ (RAppTy { }) = mkTrueE - -- | Just <- r = mkTrueE - -- t <- unsafeSpecTypeToType st - -- argsPred <- polyPredFunc2 [res] t m bt r' - -- return argsPred - -- | otherwise = mkTrueE -convertSpecType _ _ _ _ st@(RFun {}) = error $ "RFun " ++ show st -convertSpecType _ _ _ _ st@(RAllT {}) = error $ "RAllT " ++ show st -convertSpecType _ _ _ _ st@(RAllP {}) = error $ "RAllP " ++ show st -convertSpecType _ _ _ _ st@(RAllS {}) = error $ "RAllS " ++ show st -convertSpecType _ _ _ _ st@(RAllE {}) = error $ "RAllE " ++ show st -convertSpecType _ _ _ _ st@(REx {}) = error $ "REx " ++ show st -convertSpecType _ _ _ _ st@(RExprArg {}) = error $ "RExprArg " ++ show st -convertSpecType _ _ _ _ st@(RRTy {}) = error $ "RRTy " ++ show st -convertSpecType _ _ _ _ st = error $ "Bad st = " ++ show st +convertSpecType _ _ _ _ _ (RAppTy { }) = mkTrueE +convertSpecType _ _ _ _ _ st@(RFun {}) = error $ "RFun " ++ show st +convertSpecType _ _ _ _ _ st@(RAllT {}) = error $ "RAllT " ++ show st +convertSpecType _ _ _ _ _ st@(RAllP {}) = error $ "RAllP " ++ show st +convertSpecType _ _ _ _ _ st@(RAllE {}) = error $ "RAllE " ++ show st +convertSpecType _ _ _ _ _ st@(REx {}) = error $ "REx " ++ show st +convertSpecType _ _ _ _ _ st@(RExprArg {}) = error $ "RExprArg " ++ show st +convertSpecType _ _ _ _ _ st@(RRTy {}) = error $ "RRTy " ++ show st +convertSpecType _ _ _ _ _ st = error $ "Bad st = " ++ show st -polyPredFunc :: [SpecType] -> Type -> DictMaps -> BoundTypes -> Id -> LHStateM Expr -polyPredFunc as ty m bt b = do +handleHigherOrderSpecs :: CheckPre -> (Expr -> Id -> [Id] -> Id -> Expr) -> Name -> DictMaps -> BoundTypes -> [Id] -> SpecType -> LHStateM [Maybe Expr] +handleHigherOrderSpecs check_pre wrap_spec lh dm bt (i:is) st | isTC lh $ typeOf i = do + es <- handleHigherOrderSpecs check_pre wrap_spec lh dm bt is st + return $ Nothing:es +handleHigherOrderSpecs check_pre wrap_spec lh dm bt (i:is) (RFun {rt_bind = b, rt_in = fin, rt_out = fout }) + | hasFuncType i = do + t <- unsafeSpecTypeToType fin + let i' = convertSymbolT b t + + let bt' = HM.insert (idName i') t bt + es <- handleHigherOrderSpecs check_pre wrap_spec lh dm bt' is fout + + ars <- freshIdsN (anonArgumentTypes i) + ret <- freshIdN (returnType i) + spec <- convertSpecType check_pre dm bt' ars (Just ret) fin + + let let_assert_spec = mkLams (zip (repeat TermL) ars) + . Let [(ret, mkApp $ Var i:map Var ars)] + $ wrap_spec spec i ars ret -- (Var ret) + + return $ Just let_assert_spec:es + | otherwise = do + t <- unsafeSpecTypeToType fin + let i' = convertSymbolT b t + + let bt' = HM.insert (idName i') t bt + es <- handleHigherOrderSpecs check_pre wrap_spec lh dm bt' is fout + return $ Nothing:es +handleHigherOrderSpecs _ _ _ _ _ [] _ = return [] +handleHigherOrderSpecs check_pre wrap_spec lh dm bt (i:is) (RAllT {rt_tvbind = RTVar (RTV v) _, rt_ty = rty}) = do + let i' = mkIdUnsafe v + + let dm' = copyIds (idName i) (idName i') dm + let bt' = HM.insert (idName i') (typeOf i) bt + + es <- handleHigherOrderSpecs check_pre wrap_spec lh dm' bt' is rty + return $ Nothing:es +handleHigherOrderSpecs _ _ _ _ _ _ _ = error "handleHigherOrderSpecs: unhandled SpecType" + +polyPredFunc :: CheckPre -> [SpecType] -> Type -> DictMaps -> BoundTypes -> Id -> LHStateM Expr +polyPredFunc cp as ty m bt b = do dict <- lhTCDict m ty - as' <- mapM (polyPredLam m bt) as + as' <- mapM (polyPredLam cp m bt) as bool <- tyBoolT let ar1 = Type (typeOf b) ars = [dict] ++ as' ++ [Var b] - t = TyForAll (NamedTyBndr b) $ foldr1 TyFun $ map typeOf ars ++ [bool] + t = TyForAll b $ foldr1 TyFun $ map typeOf ars ++ [bool] lhPP <- lhPPM return $ mkApp $ Var (Id lhPP t):ar1:ars -polyPredLam :: DictMaps -> BoundTypes -> SpecType -> LHStateM Expr -polyPredLam m bt rapp = do +polyPredLam :: CheckPre -> DictMaps -> BoundTypes -> SpecType -> LHStateM Expr +polyPredLam cp m bt rapp = do t <- unsafeSpecTypeToType rapp let argT = spArgumentTypes $ PresType t @@ -297,53 +396,63 @@ i <- freshIdN . returnType $ PresType t - st <- convertSpecType m bt is (Just i) rapp + st <- convertSpecType cp m bt is (Just i) rapp return $ Lam TermL i st convertLHExpr :: DictMaps -> BoundTypes -> Maybe Type -> Ref.Expr -> LHStateM Expr convertLHExpr _ _ t (ECon c) = convertCon t c convertLHExpr _ bt t (EVar s) = convertEVar (symbolName s) bt t -convertLHExpr m bt _ (EApp e e') = do - f <- convertLHExpr m bt Nothing e +convertLHExpr m bt rt eapp@(EApp e e') = do + meas <- measuresM + m_set_e <- convertSetExpr meas m bt rt eapp + + case m_set_e of + Just set_e -> return set_e + Nothing -> do + f <- convertLHExpr m bt Nothing e - let at = argumentTypes f - f_ar_t = case at of - (_:_) -> Just $ last at - _ -> Nothing + let at = argumentTypes f + f_ar_t = case at of + (_:_) -> Just $ last at + _ -> Nothing - f_ar_ts = fmap tyAppArgs f_ar_t + f_ar_ts = fmap relTyVars f_ar_t - argE <- convertLHExpr m bt f_ar_t e' + argE <- convertLHExpr m bt f_ar_t e' - let tArgE = typeOf argE - ctArgE = tyAppCenter tArgE - ts = take (numTypeArgs f) $ tyAppArgs tArgE - - case (ctArgE, f_ar_ts) of - (TyCon _ _, Just f_ar_ts') -> do - let specTo = concatMap (map snd) $ map M.toList $ map (snd . uncurry (specializes M.empty)) $ zip ts f_ar_ts' - te = map Type specTo + let tArgE = typeOf argE + ctArgE = tyAppCenter tArgE + ts = take (numTypeArgs f) $ relTyVars tArgE - tcs <- mapM (lhTCDict m) ts + case (ctArgE, f_ar_ts) of + (_, Just f_ar_ts') -> do + let specTo = concatMap (map snd) $ map M.toList $ map (fromJust . uncurry specializes) $ zip ts f_ar_ts' + te = map Type specTo - let fw = mkApp $ f:te + tcs <- mapM (lhTCDict m) ts - apps = mkApp $ fw:tcs ++ [argE] - - return apps - _ -> return $ App f argE + let fw = mkApp $ f:te + + apps = mkApp $ fw:tcs ++ [argE] + + return apps + _ -> return $ App f argE + where + relTyVars t@(TyVar _) = [t] + relTyVars t@(TyApp _ _) = tyAppArgs t + relTyVars _ = [] convertLHExpr m bt t (ENeg e) = do e' <- convertLHExpr m bt t e let t' = typeOf e' neg <- lhNegateM - num <- numTCM + num <- lhNumTCM a <- freshIdN TYPE let tva = TyVar a let negate' = Var $ Id neg - (TyForAll (NamedTyBndr a) + (TyForAll a (TyFun - (TyApp (TyCon num (TyApp TYPE TYPE)) tva) + (TyApp (TyCon num (TyFun TYPE TYPE)) tva) (TyFun tva tva @@ -370,19 +479,29 @@ , nDict , e2 , e2' ] +convertLHExpr m bt t (EIte b e e') = do + b2 <- convertLHExpr m bt t b + (e2, e2') <- correctTypes m bt t e e' + + trueDC <- mkDCTrueM + falseDC <- mkDCFalseM + + bnd <- freshIdN =<< tyBoolT + + return $ Case b2 bnd (typeOf e2) [Alt (DataAlt trueDC []) e2, Alt (DataAlt falseDC []) e2'] convertLHExpr m bt _ (ECst e s) = do t <- sortToType s convertLHExpr m bt (Just t) e convertLHExpr m bt _ (PAnd es) = do es' <- mapM (convertLHExpr m bt Nothing) es - true <- mkTrueE + trueE <- mkTrueE an <- lhAndE case es' of - [] -> return $ true + [] -> return $ trueE [e] -> return e - _ -> return $ foldr (\e -> App (App an e)) true es' + _ -> return $ foldr (\e -> App (App an e)) trueE es' convertLHExpr m bt _ (POr es) = do es' <- mapM (convertLHExpr m bt Nothing) es @@ -395,7 +514,7 @@ _ -> return $ foldr (\e -> App (App orE e)) false es' convertLHExpr m bt _ (PNot e) = do e' <- convertLHExpr m bt Nothing e - no <- mkNotE + no <- notM return (App no e') convertLHExpr m bt t (PImp e1 e2) = do e1' <- convertLHExpr m bt t e1 @@ -418,6 +537,81 @@ return $ mkApp [brel', Type t', dict, e1', e2'] convertLHExpr _ _ _ e = error $ "Untranslated LH Expr " ++ (show e) +convertSetExpr :: Measures -> DictMaps -> BoundTypes -> Maybe Type -> Ref.Expr -> LHStateM (Maybe Expr) +convertSetExpr meas dm bt rt e + | [EVar v, e1] <- unEApp e + , Just (nm, nm_mod) <- get_nameTyVarAr v + , Just (f_nm, f_e) <- E.lookupNameMod nm nm_mod meas = do + e1' <- convertLHExpr dm bt rt e1 + tyI <- tyIntegerT + t <- if typeOf e1' == tyI then tyIntT else return $ typeOf e1' + e1'' <- if typeOf e1' == tyI then correctType dm t e1' else return e1' + return . Just $ mkApp ([ Var (Id f_nm (typeOf f_e)) + , Type t + , e1'']) + | [EVar v, e1, e2] <- unEApp e + , Just (nm, nm_mod) <- get_nameTyVarArOrd v + , Just (f_nm, f_e) <- E.lookupNameMod nm nm_mod meas = do + e1' <- convertLHExpr dm bt rt e1 + e2' <- convertLHExpr dm bt rt e2 + let TyApp _ t2 = typeOf e2' + e1'' <- correctType dm t2 e1' + let t = typeOf e1'' + ord <- ordDict dm t + return . Just $ mkApp ([ Var (Id f_nm (typeOf f_e)) + , Type t + , ord + , e1'' + , e2' ]) + | EVar v:es <- unEApp e + , Just (nm, nm_mod) <- get_nameSetAr v + , Just (f_nm, f_e) <- E.lookupNameMod nm nm_mod meas = do + es' <- mapM (convertLHExpr dm bt rt) es + case typeOf (head es') of + TyApp _ t -> do + return . Just $ mkApp ([ Var (Id f_nm (typeOf f_e)) + , Type t ] + ++ es') + _ -> do + t <- tyIntT + return . Just $ App (Var (Id f_nm (typeOf f_e))) (Type t) + | EVar v:es <- unEApp e + , Just (nm, nm_mod) <- get_nameSetArOrd v + , Just (f_nm, f_e) <- E.lookupNameMod nm nm_mod meas = do + es' <- mapM (convertLHExpr dm bt rt) es + case typeOf (head es') of + TyApp _ t -> do + ord <- ordDict dm t + return . Just $ mkApp ([ Var (Id f_nm (typeOf f_e)) + , Type t + , ord ] + ++ es') + _ -> error "convertSetExpr: incorrect type" + | otherwise = return Nothing + where + get_nameTyVarAr v = case nameOcc (symbolName v) of + "Set_sng" -> Just ("singleton", Just "Data.Set.Internal") + _ -> Nothing + + get_nameTyVarArOrd v = case nameOcc (symbolName v) of + "Set_mem" -> Just ("member", Just "Data.Set.Internal") + _ -> Nothing + + get_nameSetAr v = case nameOcc (symbolName v) of + "Set_empty" -> Just ("empty", Just "Data.Set.Internal") + "Set_emp" -> Just ("null", Just "Data.Set.Internal") + _ -> Nothing + + get_nameSetArOrd v = case nameOcc (symbolName v) of + "Set_cup" -> Just ("union", Just "Data.Set.Internal") + "Set_cap" -> Just ("intersection", Just "Data.Set.Internal") + "Set_sub" -> Just ("isSubsetOf", Just "Data.Set.Internal") + _ -> Nothing + +unEApp :: Ref.Expr -> [Ref.Expr] +unEApp (EApp f a) = unEApp f ++ [a] +unEApp e = [e] + convertBop :: Bop -> LHStateM Expr convertBop Ref.Plus = convertBop' lhPlusM convertBop Ref.Minus = convertBop' lhMinusM @@ -429,13 +623,13 @@ convertBop' :: LHStateM Name -> LHStateM Expr convertBop' f = do - num <- numTCM + num <- lhNumTCM n <- f a <- freshIdN TYPE let tva = TyVar a - return $ Var $ Id n (TyForAll (NamedTyBndr a) + return $ Var $ Id n (TyForAll a (TyFun - (TyApp (TyCon num (TyApp TYPE TYPE)) tva) + (TyApp (TyCon num (TyFun TYPE TYPE)) tva) (TyFun tva (TyFun @@ -469,27 +663,88 @@ let retT = returnType e let retT' = returnType e' - may_nDict <- maybeNumDict m t - may_nDict' <- maybeNumDict m t' + may_nDict <- maybeNumDict m retT + may_nDict' <- maybeNumDict m retT' - may_iDict <- maybeIntegralDict m t - may_iDict' <- maybeIntegralDict m t' + may_iDict <- maybeIntegralDict m retT + may_iDict' <- maybeIntegralDict m retT' + may_fDict <- maybeFractionalDict m retT + may_fDict' <- maybeFractionalDict m retT' + + may_ratio_e <- maybeRatioFromInteger m e + may_ratio_e' <- maybeRatioFromInteger m e' + fromRationalF <- lhFromRationalM + if | t == t' -> return (e, e') | retT /= tyI , retT' == tyI , Just nDict <- may_nDict -> return (e, mkApp [Var fIntgr, Type t, nDict, e']) + | retT == tyI , retT' /= tyI , Just nDict' <- may_nDict' -> return (mkApp [Var fIntgr, Type t', nDict', e], e') + | retT /= tyI , retT' == tyI , Just iDict <- may_iDict -> return (mkApp [Var tIntgr, Type t, iDict, e], e') + | retT == tyI , retT' /= tyI , Just iDict' <- may_iDict' -> return (e, mkApp [Var tIntgr, Type t', iDict', e']) - | otherwise -> error "correctTypes: Unhandled case" + | Just ratio_e <- may_ratio_e + , Just fDict' <- may_fDict' -> return (mkApp [Var fromRationalF, Type t', fDict', ratio_e], e') + + | Just fDict <- may_fDict + , Just ratio_e' <- may_ratio_e' -> return (e, mkApp [Var fromRationalF, Type t, fDict, ratio_e']) + + | Just iDict <- may_iDict + , Just nDict' <- may_nDict' -> + return (mkApp [Var fIntgr, Type t', nDict', mkApp [Var tIntgr, Type t, iDict, e]], e') + + | Just nDict <- may_nDict + , Just iDict' <- may_iDict' -> + return (e, mkApp [Var fIntgr, Type t, nDict, mkApp [Var tIntgr, Type t', iDict', e']]) + + | otherwise -> error $ "correctTypes: Unhandled case" + ++ "\ne = " ++ show e + ++ "\ne' = " ++ show e' + ++ "\nt = " ++ show t + ++ "\nt' = " ++ show t' + ++ "\nretT = " ++ show retT + ++ "\nretT' = " ++ show retT' + ++ "\nm = " ++ show m + +correctType :: DictMaps -> Type -> Expr -> LHStateM Expr +correctType m t e = do + fIntgr <- lhFromIntegerM + tyI <- tyIntegerT + + let t' = typeOf e + + may_nDict <- maybeNumDict m t + + if | t == t' -> return e + | t' == tyI + , t /= tyI + , Just nDict <- may_nDict -> return $ mkApp [Var fIntgr, Type t, nDict, e] + | otherwise -> error $ "correctType: unhandled case\n" ++ show e ++ "\nmay_nDict" ++ show may_nDict + +maybeRatioFromInteger :: DictMaps -> Expr -> LHStateM (Maybe Expr) +maybeRatioFromInteger m e = do + tyI <- tyIntegerT + + toRatioF <- lhToRatioFuncM -- return . mkToRatioExpr =<< knownValues + may_iDict <- maybeIntegralDict m (typeOf e) + + dcIntegerE <- mkDCIntegerE + + if | Just iDict <- may_iDict + , typeOf e == tyI -> + return . Just $ mkApp [Var toRatioF, Type (typeOf e), iDict, e, App dcIntegerE (Lit (LitInt 1))] + | otherwise -> return Nothing + convertSymbolT :: Symbol -> Type -> Id convertSymbolT s = Id (symbolName s) @@ -525,7 +780,7 @@ convertEVar :: Name -> BoundTypes -> Maybe Type -> LHStateM Expr convertEVar nm@(Name n md _ _) bt mt - | Just t <- M.lookup nm bt = return $ Var (Id nm t) + | Just t <- HM.lookup nm bt = return $ Var (Id nm t) | otherwise = do meas <- measuresM tenv <- typeEnv @@ -534,15 +789,22 @@ return . Var $ Id n' (typeOf e) | Just dc <- getDataConNameMod' tenv nm -> return $ Data dc | Just t <- mt -> return $ Var (Id nm t) - | otherwise -> error $ "convertEVar: Required type not found" + | otherwise -> error $ "convertEVar: Required type not found" ++ "\n" ++ show n ++ "\nbt = " ++ show bt + where + getDataConNameMod' tenv n = find (flip dataConHasNameMod n) $ concatMap dataCon $ HM.elems tenv + dataConHasNameMod (DataCon (Name n m _ _) _) (Name n' m' _ _) = n == n' && m == m' + convertCon :: Maybe Type -> Constant -> LHStateM Expr convertCon (Just (TyCon n _)) (Ref.I i) = do - (TyCon ti _) <- tyIntT - dc <- mkDCIntE - if n == ti - then return $ App dc (Lit . LitInt $ fromIntegral i) - else error $ "Unknown Con" ++ show n + tyI <- tyIntT + case tyI of + TyCon ti _ -> do + dc <- mkDCIntE + if n == ti + then return $ App dc (Lit . LitInt $ fromIntegral i) + else error $ "Unknown Con" ++ show n + _ -> error "convertCon: Non-tyInt" convertCon _ (Ref.I i) = do dc <- mkDCIntegerE return $ App dc (Lit . LitInt $ fromIntegral i) @@ -572,7 +834,7 @@ specTypeToType (RAllT {rt_tvbind = RTVar (RTV v) _, rt_ty = rty}) = do let i = mkIdUnsafe v t <- specTypeToType rty - return $ fmap (TyForAll (NamedTyBndr i)) t + return $ fmap (TyForAll i) t specTypeToType (RApp {rt_tycon = c, rt_args = as}) = rTyConType c as specTypeToType (RAppTy {rt_arg = arg, rt_res = res}) = do argT <- specTypeToType arg @@ -586,7 +848,7 @@ rTyConType rtc sts = do tenv <- typeEnv - let tcn = mkTyConName HM.empty . rtc_tc $ rtc + let tcn = mkTyConNameUnsafe . rtc_tc $ rtc n = nameModMatch tcn tenv ts <- mapM specTypeToType sts @@ -628,9 +890,9 @@ b <- tyBoolT let tva = TyVar a t = TyForAll - (NamedTyBndr a) + a (TyFun - (TyCon lh TYPE) + (TyCon lh (TyFun TYPE TYPE)) (TyFun tva (TyFun tva b) @@ -643,8 +905,18 @@ brelTCDict = lhTCDict bopTCDict :: Bop -> DictMaps -> Type -> LHStateM Expr -bopTCDict Ref.Mod = integralDict -bopTCDict _ = numDict +bopTCDict Ref.Mod dm t = integralDict dm t +bopTCDict Ref.Div dm t = do + fd <- maybeFractionalDict dm t + case fd of + Just fd' -> return fd' + Nothing -> integralDict dm t +bopTCDict Ref.RDiv dm t = do + fd <- maybeFractionalDict dm t + case fd of + Just fd' -> return fd' + Nothing -> integralDict dm t +bopTCDict _ dm t = numDict dm t lhTCDict :: DictMaps -> Type -> LHStateM Expr lhTCDict m t = do @@ -662,9 +934,28 @@ Just e -> return e Nothing -> error $ "No lh dict " ++ show lh ++ "\n" ++ show t ++ "\n" ++ show m +maybeOrdDict :: DictMaps -> Type -> LHStateM (Maybe Expr) +maybeOrdDict m t = do + ordTC <- lhOrdTCM + tc <- typeClassInstTC (ord_dicts m) ordTC t + case tc of + Just _ -> return tc + Nothing -> do + ord <- lhOrdM + lh <- lhTCDict m t + return . Just $ App (App (Var (Id ord TyUnknown)) (Type t)) lh + + +ordDict :: DictMaps -> Type -> LHStateM Expr +ordDict m t = do + tc <- maybeOrdDict m t + case tc of + Just e -> return e + Nothing -> error $ "No ord dict \n" ++ show t ++ "\n" ++ show m + maybeNumDict :: DictMaps -> Type -> LHStateM (Maybe Expr) maybeNumDict m t = do - num <- numTCM + num <- lhNumTCM typeClassInstTC (num_dicts m) num t numDict :: DictMaps -> Type -> LHStateM Expr @@ -685,3 +976,8 @@ case tc of Just e -> return e Nothing -> error $ "No integral dict\n" ++ show t ++ "\n" ++ show m + +maybeFractionalDict :: DictMaps -> Type -> LHStateM (Maybe Expr) +maybeFractionalDict m t = do + integral <- return . KV.fractionalTC =<< knownValues + typeClassInstTC (fractional_dicts m) integral t diff --git a/src/G2/Liquid/ConvertCurrExpr.hs b/src/G2/Liquid/ConvertCurrExpr.hs --- a/src/G2/Liquid/ConvertCurrExpr.hs +++ b/src/G2/Liquid/ConvertCurrExpr.hs @@ -1,7 +1,10 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} -module G2.Liquid.ConvertCurrExpr (convertCurrExpr) where +module G2.Liquid.ConvertCurrExpr ( convertCurrExpr + , initiallyCalledFuncName) where import G2.Language import G2.Language.Monad @@ -11,12 +14,14 @@ import G2.Liquid.Types import Control.Monad.Extra -import qualified Data.Map as M +import qualified Data.HashMap.Lazy as HM import Data.Maybe -convertCurrExpr :: Id -> Bindings -> LHStateM [Name] +-- | Returns (1) the Id of the new main function and (2) the functions that need counterfactual variants +convertCurrExpr :: Id -> Bindings -> LHStateM (Id, [Name]) convertCurrExpr ifi bindings = do ifi' <- modifyInputExpr ifi + mapWithKeyME (\(Name _ m _ _) e -> if isJust m then letLiftHigherOrder e else return e) addCurrExprAssumption ifi bindings return ifi' @@ -33,7 +38,7 @@ -- it'll only be computed once. This is NOT just for efficiency. -- Since the choice is nondeterministic, this is the only way to ensure that -- we don't make two different choices, and get two different values. -modifyInputExpr :: Id -> LHStateM [Name] +modifyInputExpr :: Id -> LHStateM (Id, [Name]) modifyInputExpr i@(Id n _) = do (CurrExpr er ce) <- currExpr @@ -45,15 +50,16 @@ let ce' = replaceVarWithName (idName i) (Var newI) ce putCurrExpr (CurrExpr er ce') - return ns - Nothing -> return [] + return (newI, ns) + Nothing -> return (error "Name not found", []) -- Actually does the work of modify the function for modifyInputExpr -- Inserts the new function in the ExprEnv, and returns the Id modifyInputExpr' :: Id -> Expr -> LHStateM (Id, [Name]) modifyInputExpr' i e = do (e', ns) <- rebindFuncs e - e''' <- letLiftFuncs e' + e'' <- letLiftFuncs e' + e''' <- replaceLocalAssert i e'' newI <- freshSeededIdN (idName i) (typeOf i) insertE (idName newI) e''' @@ -75,6 +81,33 @@ rewriteAssertName n (Assert (Just fc) e1 e2) = Assert (Just $ fc {funcName = n}) e1 e2 rewriteAssertName n e1 = modifyChildren (rewriteAssertName n) e1 +-- | We are assuming the precondiiton holds, so we only have to check the postcondition! +-- We also replace the name of the assert so we can recognize it as the inital call later. +replaceLocalAssert :: Id -> Expr -> LHStateM Expr +replaceLocalAssert (Id n _) ce = do + n_assert <- lookupPostM n + -- Replace the initial function assertion with one that only checks the postcondition, + -- but is careful to not replace assertions tied to higher order functions. + let ce' = insertInLams + (\_ e -> case e of + Let b (Assert (Just fc) e1 e2) -> + let ars = arguments fc ++ [returns fc] + assrt = case n_assert of + Just a -> mkApp (a:ars) + Nothing -> e1 + in + Let b $ Assert (Just fc) assrt e2 + _ -> e) ce + ce'' = modifyASTs + (\e -> case e of + Assert (Just fc) e1 e2 -> + Assert (Just $ fc { funcName = initiallyCalledFuncName}) e1 e2 + _ -> e) ce' + return ce'' + +initiallyCalledFuncName :: Name +initiallyCalledFuncName = Name "INITIALLY_CALLED_FUNC" Nothing 0 Nothing + replaceVarWithName :: Name -> Expr -> Expr -> Expr replaceVarWithName n new = modify (replaceVarWithName' n new) @@ -89,7 +122,9 @@ -- Furthermore, we have to be careful to not move bindings from Lambdas/other Let's -- out of scope. letLiftFuncs :: Expr -> LHStateM Expr -letLiftFuncs = modifyAppTopE letLiftFuncs' +letLiftFuncs e = do + e' <- modifyAppTopE letLiftFuncs' e + return $ flattenLets e' letLiftFuncs' :: Expr -> LHStateM Expr letLiftFuncs' e @@ -101,6 +136,59 @@ return . Let (zip is ars) . mkApp $ c:map Var is | otherwise = return e + +-- | Tries to be more selective then liftLetFuncs, doesn't really work yet... +letLiftHigherOrder :: Expr -> LHStateM Expr +letLiftHigherOrder e = return . shiftLetsOutOfApps =<< insertInLamsE letLiftHigherOrder' e + +letLiftHigherOrder' :: [Id] -> Expr -> LHStateM Expr +letLiftHigherOrder' is e@(App _ _) + | Var i <- appCenter e + , i `elem` is = do + ni <- freshIdN (typeOf e) + e' <- modifyAppRHSE (letLiftHigherOrder' is) e + return $ Let [(ni, e')] (Var ni) + | d@(Data _) <- appCenter e = do + let ars = passedArgs e + f_is <- freshIdsN $ map typeOf ars + + ars' <- mapM (letLiftHigherOrder' f_is) ars + + return . Let (zip f_is ars') . mkApp $ d:map Var f_is +letLiftHigherOrder' is e@(Lam _ _ _) = insertInLamsE (\is' -> letLiftHigherOrder' (is ++ is')) e +letLiftHigherOrder' is e = modifyChildrenM (letLiftHigherOrder' is) e + +shiftLetsOutOfApps :: Expr -> Expr +shiftLetsOutOfApps e@(App _ _) = + case shiftLetsOutOfApps' e of + Let b e' -> Let b . modifyBottomApp shiftLetsOutOfApps $ e' + e' -> modifyBottomApp shiftLetsOutOfApps $ e' +shiftLetsOutOfApps e = modifyChildren shiftLetsOutOfApps e + +shiftLetsOutOfApps' :: Expr -> Expr +shiftLetsOutOfApps' a@(App _ _) = + let + b = getLetsInApp a + in + case b of + [] -> a + _ -> Let b $ elimLetsInApp a +shiftLetsOutOfApps' _ = error "shiftLetsOutOfApps': must be passed an App" + +getLetsInApp :: Expr -> Binds +getLetsInApp (Let b e) = b ++ getLetsInApp e +getLetsInApp (App e e') = getLetsInApp e ++ getLetsInApp e' +getLetsInApp _ = [] + +elimLetsInApp :: Expr -> Expr +elimLetsInApp (Let _ e) = elimLetsInApp e +elimLetsInApp (App e e') = App (elimLetsInApp e) (elimLetsInApp e') +elimLetsInApp e = e + +modifyBottomApp :: (Expr -> Expr) -> Expr -> Expr +modifyBottomApp f (App e e') = App (modifyBottomApp f e) (modifyBottomApp f e') +modifyBottomApp f e = f e + -- We add an assumption about the inputs to the current expression -- This prevents us from finding a violation of the output refinement type -- that requires a violation of the input refinement type @@ -108,22 +196,45 @@ addCurrExprAssumption ifi (Bindings {fixed_inputs = fi}) = do (CurrExpr er ce) <- currExpr + lh_tc_n <- lhTCM + let lh_tc = TyCon lh_tc_n (TyFun TYPE TYPE) + let fi' = filter (\e -> tyAppCenter (typeOf e) /= lh_tc) fi + assumpt <- lookupAssumptionM (idName ifi) -- fi <- fixedInputs eenv <- exprEnv inames <- inputNames - lh <- mapM (lhTCDict' M.empty) $ mapMaybe typeType fi + lh <- mapM (lhTCDict' HM.empty) $ mapMaybe typeType fi' let is = catMaybes (map (E.getIdFromName eenv) inames) - let (typs, ars) = span isType $ fi ++ map Var is + let (typs, ars) = span isType $ fi' ++ map Var is case assumpt of - Just assumpt' -> do - let appAssumpt = mkApp $ assumpt':typs ++ lh ++ ars - let ce' = Assume Nothing appAssumpt ce - putCurrExpr (CurrExpr er ce') + Just (assumpt_is, higher_is, assumpt') -> do + let all_args = typs ++ lh ++ ars + appAssumpt = mkApp $ assumpt':all_args + + inputs <- inputNames + let matching = zipWith (\n (i, hi) -> (n, i, hi)) inputs $ drop (length higher_is - length inputs) $ zip assumpt_is higher_is + matching_higher = mapMaybe (\(n, i, hi) -> maybe Nothing (Just . (n, i,)) hi) matching + let_expr = Let (map (\(n, i, _) -> (snd i, Var (Id n . typeOf $ snd i))) matching_higher) + + let ce' = let_expr + . flip (foldr (uncurry replaceAssumeFC)) (map (\(n, (_, i), _) -> (idName i, n)) matching_higher) + $ foldr (uncurry replaceVar) ce (map (\(n, _, hi) -> (n, hi)) matching_higher) + assume_ce = Assume Nothing appAssumpt ce' + + putCurrExpr (CurrExpr er assume_ce) Nothing -> return () + +replaceAssumeFC :: ASTContainer m Expr => Name -> Name -> m -> m +replaceAssumeFC old new = modifyASTs (replaceAssumeFC' old new) + +replaceAssumeFC' :: Name -> Name -> Expr -> Expr +replaceAssumeFC' old new e@(Assume (Just fc) e1 e2) = + if funcName fc == old then Assume (Just (fc { funcName = new })) e1 e2 else e +replaceAssumeFC' _ _ e = e isType :: Expr -> Bool isType (Type _) = True diff --git a/src/G2/Liquid/G2Calls.hs b/src/G2/Liquid/G2Calls.hs new file mode 100644 --- /dev/null +++ b/src/G2/Liquid/G2Calls.hs @@ -0,0 +1,531 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} + +module G2.Liquid.G2Calls ( G2Call + , gathererReducer + , checkAbstracted + , reduceAbstracted + , reduceAllCalls + , reduceCalls + , reduceFuncCall + , mapAccumM) where + +import G2.Config +import G2.Data.Utils +import G2.Execution +import G2.Interface +import G2.Language as G2 +import qualified G2.Language.ExprEnv as E +import G2.Liquid.Helpers +import G2.Liquid.LHReducers +import G2.Liquid.SpecialAsserts +import G2.Liquid.Types +import G2.Liquid.TyVarBags +import G2.Solver + +import Control.Monad +import Control.Monad.IO.Class +import qualified Data.HashMap.Lazy as HM +import qualified Data.HashSet as HS +import Data.Maybe +import Data.Monoid + +-- | The function to actually use for Symbolic Execution +type G2Call solver simplifier = + forall m t . ( MonadIO m + , Named t + , ASTContainer t Expr + , ASTContainer t Type) => + SomeReducer m t -> SomeHalter m t -> SomeOrderer m t -> solver -> simplifier -> MemConfig -> State t -> Bindings -> m ([ExecRes t], Bindings) + +------------------------------- +-- Check Abstracted +------------------------------- +-- Checks if the abstracted functions actually deviate from the real function behavior. +-- If they do not, they can simply be eliminated from the state. + +-- The result of a call to checkAbstracted'. Either: +-- (1) the function does need to be abstract, and we get the actual result of executing the function call. +-- (2) the function does not need to be abstract +data AbstractedRes = AbstractRes Abstracted Model + | NotAbstractRes + +toAbstracted :: AbstractedRes -> Maybe Abstracted +toAbstracted (AbstractRes a _) = Just a +toAbstracted _ = Nothing + +toModel :: AbstractedRes -> Maybe Model +toModel (AbstractRes _ m) = Just m +toModel _ = Nothing + +-- | Checks if abstracted functions actually had to be abstracted. +checkAbstracted :: (Solver solver, Simplifier simplifier) => G2Call solver simplifier -> solver -> simplifier -> Config -> Id -> Bindings -> ExecRes LHTracker -> IO (ExecRes AbstractedInfo) +checkAbstracted g2call solver simplifier config init_id bindings er@(ExecRes{ final_state = s@State { track = lht } + , conc_args = inArg + , conc_out = ex }) = do + -- Get `Abstracted`s for the abstracted functions + let chck = checkAbstracted' g2call solver simplifier (sharing config) + ((s', bindings'), abstractedR) <- mapAccumM (uncurry chck) (s, bindings) (abstract_calls lht) + let abstracted' = mapMaybe toAbstracted $ abstractedR + models = mapMaybe toModel $ abstractedR + + -- Get an `Abstracted` for the initial call + let init_call_fc = FuncCall (idName init_id) inArg ex + (s'', bindings'', abs_init, model_init) <- getAbstracted g2call solver simplifier (sharing config) s' bindings' init_call_fc + + -- Get an `Abstracted` for the violated function (if it exists) + (bindings''', viol_er) <- reduceViolated g2call solver simplifier (sharing config) bindings'' (er { final_state = s'' }) + abs_viol <- case violated viol_er of + Just v -> return . Just =<< + getAbstracted g2call solver simplifier (sharing config) (final_state viol_er) bindings''' v + Nothing -> return Nothing + let viol_model = maybeToList $ fmap fth4 abs_viol + abs_info = AbstractedInfo { init_call = abs_init + , abs_violated = fmap thd4 abs_viol + , abs_calls = abstracted' + , ai_all_calls = all_calls lht + , ai_higher_order_calls = higher_order_calls lht } + fs = maybe (final_state viol_er) fst4 abs_viol + + return $ viol_er { final_state = fs { track = abs_info + , model = foldr HM.union (model s) (model_init:viol_model ++ models) } + } + +checkAbstracted' :: (Solver solver, Simplifier simplifier) + => G2Call solver simplifier + -> solver + -> simplifier + -> Sharing + -> State LHTracker + -> Bindings + -> FuncCall + -> IO ((State LHTracker, Bindings), AbstractedRes) +checkAbstracted' g2call solver simplifier share s bindings abs_fc@(FuncCall { funcName = n, arguments = ars, returns = r }) + | Just e <- E.lookup n $ expr_env s = do + let + e' = mkApp $ Var (Id n (typeOf e)):ars + + ds = deepseq_walkers bindings + strict_call = maybe e' (fillLHDictArgs ds) $ mkStrict_maybe ds e' + + -- We leave assertions in the code, and set true_assert to false so we can + -- tell if an assertion was violated. + -- If an assertion is violated, it means that the function did not need to be abstracted, + -- but does need to be in `assert_ids` . + -- We eliminate all assumes, except those blocking calls to library functions. + -- See [BlockErrors] in G2.Liquid.SpecialAsserts + let s' = elimAssumesExcept + . pickHead + . elimSymGens (arb_value_gen bindings) + . modelToExprEnv $ + s { curr_expr = CurrExpr Evaluate strict_call + , track = False } + + + let pres = HS.fromList $ namesList s' ++ namesList bindings + (er, bindings') <- g2call + (SomeReducer (hitsLibError ~> stdRed share retReplaceSymbFuncVar solver simplifier)) + (SomeHalter (swhnfHalter <~> acceptOnlyOneHalter <~> switchEveryNHalter 200)) + (SomeOrderer (incrAfterN 2000 (adtSizeOrderer 0 Nothing))) + solver simplifier + (emptyMemConfig { pres_func = \_ _ _ -> pres }) + s' bindings + + case er of + [ExecRes + { + final_state = fs@(State { curr_expr = CurrExpr _ ce, model = m, track = t}) + }] -> case not $ ce `eqUpToTypes` r of + True -> do + let ar = AbstractRes + ( Abstracted { abstract = repTCsFC (type_classes s) $ abs_fc + , real = repTCsFC (type_classes s) $ abs_fc { returns = ce } + , hits_lib_err_in_real = t + , func_calls_in_real = [] } + ) m + return ( ( s { expr_env = foldr E.insertSymbolic (expr_env s) (E.symbolicIds $ expr_env fs) + , path_conds = path_conds fs } + , bindings' + ) + , ar) + False -> return ((s, bindings), NotAbstractRes) + _ -> error $ "checkAbstracted': Bad return from g2call" + | otherwise = error $ "checkAbstracted': Bad lookup in g2call" + +getAbstracted :: (Solver solver, Simplifier simplifier) + => G2Call solver simplifier + -> solver + -> simplifier + -> Sharing + -> State LHTracker + -> Bindings + -> FuncCall + -> IO (State LHTracker, Bindings, Abstracted, Model) +getAbstracted g2call solver simplifier share s bindings abs_fc@(FuncCall { funcName = n, arguments = ars }) + | Just e <- E.lookup n $ expr_env s = do + let + e' = mkApp $ Var (Id n (typeOf e)):ars + + ds = deepseq_walkers bindings + strict_call = maybe e' (fillLHDictArgs ds) $ mkStrict_maybe ds e' + + let s' = mkAssertsTrue (known_values s) + . elimAssumesExcept + . pickHead + . elimSymGens (arb_value_gen bindings) + . modelToExprEnv $ + s { curr_expr = CurrExpr Evaluate strict_call + , track = ([] :: [FuncCall], False)} + + (er, bindings') <- g2call + (((hitsLibErrorGatherer ~> stdRed share retReplaceSymbFuncVar solver simplifier) :== Finished + --> (nonRedPCRed .|. nonRedPCRedConst) )) + (SomeHalter (swhnfHalter <~> acceptOnlyOneHalter <~> switchEveryNHalter 200)) + (SomeOrderer (incrAfterN 2000 (adtSizeOrderer 0 Nothing))) + solver simplifier + PreserveAllMC + s' bindings + + case er of + [ExecRes + { + final_state = fs@(State { curr_expr = CurrExpr _ ce, track = (gfc, hle), model = m}) + }] -> do + let fs' = modelToExprEnv fs + (fs'', bindings'', gfc') <- reduceFuncCallMaybeList g2call solver simplifier share bindings' fs' gfc + let ar = Abstracted { abstract = repTCsFC (type_classes s) abs_fc + , real = repTCsFC (type_classes s) $ abs_fc { returns = (inline (expr_env fs) HS.empty ce) } + , hits_lib_err_in_real = hle + , func_calls_in_real = gfc' } + return ( s { expr_env = foldr E.insertSymbolic (expr_env s) (E.symbolicIds $ expr_env fs'') + , path_conds = path_conds fs } + , bindings'' + , ar + , m) + _ -> error $ "checkAbstracted': Bad return from g2call" + | otherwise = error $ "getAbstracted: Bad lookup in g2call" ++ show n + +repTCsFC :: TypeClasses -> FuncCall -> FuncCall +repTCsFC tc fc = fc { arguments = map (repTCs tc) (arguments fc) + , returns = repTCs tc (returns fc) } + +repTCs :: TypeClasses -> Expr -> Expr +repTCs tc e + | isTypeClass tc $ (typeOf e) + , TyCon n _:t:_ <- unTyApp (typeOf e) + , Just tc_dict <- typeClassInst tc HM.empty n t = tc_dict + | otherwise = e + + +inline :: ExprEnv -> HS.HashSet Name -> Expr -> Expr +inline h ns v@(Var (Id n _)) + | E.isSymbolic n h = v + | HS.member n ns = v + | Just e <- E.lookup n h = inline h (HS.insert n ns) e +inline h ns e = modifyChildren (inline h ns) e + +hitsLibError :: Monad m => Reducer m () Bool +hitsLibError = mkSimpleReducer + (const ()) + rr + where + rr _ s@(State { curr_expr = CurrExpr _ ce }) b = + case ce of + Tick t _ + | t == assumeErrorTickish -> + return (NoProgress, [(s { track = True }, ())], b) + _ -> return (NoProgress, [(s, ())], b) + +gathererReducer :: Monad m => Reducer m () [FuncCall] +gathererReducer = mkSimpleReducer + (const ()) + rr + where + rr _ s@(State { curr_expr = CurrExpr Evaluate (e@(Assume (Just fc) _ _)) + , track = tr + }) b = + let + s' = s { curr_expr = CurrExpr Evaluate e + , track = fc:tr} + in + return (Finished, [(s', ())], b) + rr _ s@(State { curr_expr = CurrExpr Evaluate (e@(G2.Assert (Just fc) _ _)) + , track = tr + }) b = + let + s' = s { curr_expr = CurrExpr Evaluate e + , track = fc:tr} + in + return (Finished, [(s', ())], b) + rr _ s b = return (Finished, [(s, ())], b) + +hitsLibErrorGatherer :: Monad m => Reducer m () ([FuncCall], Bool) +hitsLibErrorGatherer = mkSimpleReducer + (const ()) + rr + where + rr _ s@(State { curr_expr = CurrExpr Evaluate (e@(Assume (Just fc) _ _)) + , track = (tr, hle) + }) b = + let + s' = s { curr_expr = CurrExpr Evaluate e + , track = (fc:tr, hle)} + in + return (Finished, [(s', ())], b) + rr _ s@(State { curr_expr = CurrExpr Evaluate (e@(G2.Assert (Just fc) _ _)) + , track = (tr, hle) + }) b = + let + s' = s { curr_expr = CurrExpr Evaluate e + , track = (fc:tr, hle)} + in + return (Finished, [(s', ())], b) + rr _ s@(State { curr_expr = CurrExpr _ ce, track = (glc, _) }) b = + case ce of + Tick t _ + | t == assumeErrorTickish -> + return (NoProgress, [(s { track = (glc, True) }, ())], b) + _ -> return (NoProgress, [(s, ())], b) + +acceptOnlyOneHalter :: Monad m => Halter m () t +acceptOnlyOneHalter = + (mkSimpleHalter (const ()) + (\hv _ _ -> hv) + (\_ _ _ -> return Continue) + (\hv _ _ _ -> hv)) + { discardOnStart = \_ pr _ -> not . null $ accepted pr} + +-- | Remove all @Assume@s from the given `Expr`, unless they have a particular @Tick@ +elimAssumesExcept :: ASTContainer m Expr => m -> m +elimAssumesExcept = modifyASTs elimAssumesExcept' + +elimAssumesExcept' :: Expr -> Expr +elimAssumesExcept' (Assume _ (Tick t _) e) + | t == assumeErrorTickish = Tick t e + | otherwise = e +elimAssumesExcept' (Assume _ _ e) = e +elimAssumesExcept' e = e + + +------------------------------- +-- Reduce Calls +------------------------------- +-- Reduces the arguments and results of the violated and abstracted functions to normal form. + +reduceCalls :: (Solver solver, Simplifier simplifier) => G2Call solver simplifier -> solver -> simplifier -> Config -> Bindings -> ExecRes LHTracker -> IO (Bindings, ExecRes LHTracker) +reduceCalls g2call solver simplifier config bindings er = do + (bindings', er') <- reduceAbstracted g2call solver simplifier (sharing config) bindings er + (bindings'', er'') <- reduceAllCalls g2call solver simplifier (sharing config) bindings' er' + (bindings''', er''') <- reduceHigherOrderCalls g2call solver simplifier (sharing config) bindings'' er'' + + return (bindings''', er''') + +reduceViolated :: (Solver solver, Simplifier simplifier) => G2Call solver simplifier -> solver -> simplifier -> Sharing -> Bindings -> ExecRes LHTracker -> IO (Bindings, ExecRes LHTracker) +reduceViolated g2call solver simplifier share bindings er@(ExecRes { final_state = s, violated = Just v }) = do + let red = redArbErrors :== Finished --> stdRed share retReplaceSymbFuncVar solver simplifier + (s', bindings', v') <- reduceFuncCall g2call red solver simplifier s bindings v + -- putStrLn $ "v = " ++ show v + -- putStrLn $ "v' = " ++ show v' + return (bindings', er { final_state = s { expr_env = foldr E.insertSymbolic (expr_env s) (E.symbolicIds $ expr_env s') + , path_conds = path_conds s' } + , violated = Just v' }) +reduceViolated _ _ _ _ b er = return (b, er) + +reduceAbstracted :: (Solver solver, Simplifier simplifier) => G2Call solver simplifier -> solver -> simplifier -> Sharing -> Bindings -> ExecRes LHTracker -> IO (Bindings, ExecRes LHTracker) +reduceAbstracted g2call solver simplifier share bindings + er@(ExecRes { final_state = (s@State { track = lht}) }) = do + let red = redArbErrors :== Finished --> stdRed share retReplaceSymbFuncVar solver simplifier + fcs = abstract_calls lht + + ((s', bindings'), fcs') <- mapAccumM (\(s_, b_) fc -> do + (new_s, new_b, r_fc) <- reduceFuncCall g2call red solver simplifier s_ b_ fc + return ((new_s, new_b), r_fc)) + (s, bindings) fcs + + return (bindings', er { final_state = s { expr_env = foldr E.insertSymbolic (expr_env s) (E.symbolicIds $ expr_env s') + , path_conds = path_conds s' + , track = lht { abstract_calls = fcs' } } + }) + +reduceAllCalls :: (Solver solver, Simplifier simplifier) => G2Call solver simplifier -> solver -> simplifier -> Sharing -> Bindings -> ExecRes LHTracker -> IO (Bindings, ExecRes LHTracker) +reduceAllCalls g2call solver simplifier share bindings + er@(ExecRes { final_state = (s@State { track = lht}) }) = do + let fcs = all_calls lht + + (s', bindings', fcs') <- reduceFuncCallMaybeList g2call solver simplifier share bindings s fcs + + return (bindings', er { final_state = s' { track = lht { all_calls = fcs' } }}) + +reduceHigherOrderCalls :: (Solver solver, Simplifier simplifier) => G2Call solver simplifier -> solver -> simplifier -> Sharing -> Bindings -> ExecRes LHTracker -> IO (Bindings, ExecRes LHTracker) +reduceHigherOrderCalls g2call solver simplifier share bindings + er@(ExecRes { final_state = (s@State { track = lht}) }) = do + let fcs = higher_order_calls lht + + (s', bindings', fcs') <- reduceFuncCallMaybeList g2call solver simplifier share bindings s fcs + + return (bindings', er { final_state = s' { track = lht { higher_order_calls = fcs' } }}) + +reduceFuncCallMaybeList :: ( ASTContainer t Expr + , ASTContainer t Type + , Named t + , Show t + , Solver solver + , Simplifier simplifier) => G2Call solver simplifier -> solver -> simplifier -> Sharing -> Bindings -> State t -> [FuncCall] -> IO (State t, Bindings, [FuncCall]) +reduceFuncCallMaybeList g2call solver simplifier share bindings st fcs = do + let red = redArbErrors :== Finished --> stdRed share retReplaceSymbFuncVar solver simplifier + ((s', b'), fcs') <- mapAccumM (\(s, b) fc -> do + s_b_fc <- reduceFuncCallMaybe g2call red solver simplifier s b fc + case s_b_fc of + Just (s', b', fc') -> return ((s', b'), Just fc') + Nothing -> return ((s, b), Nothing)) (st, bindings) fcs + return (s', b', catMaybes fcs') + +reduceFuncCall :: ( MonadIO m + , Solver solver + , Simplifier simplifier + , ASTContainer t Expr + , ASTContainer t Type + , Show t + , Named t) + => G2Call solver simplifier -> SomeReducer m t -> solver -> simplifier -> State t -> Bindings -> FuncCall -> m (State t, Bindings, FuncCall) +reduceFuncCall g2call red solver simplifier s bindings fc@(FuncCall { arguments = ars, returns = r }) = do + -- (bindings', red_ars) <- mapAccumM (reduceFCExpr share (red <~ SomeReducer (Logger "arg")) solver simplifier s) bindings ars + -- (bindings'', red_r) <- reduceFCExpr share (red <~ SomeReducer (Logger "ret")) solver simplifier s bindings' r + ((s', bindings'), red_ars) <- mapAccumM (uncurry (reduceFCExpr g2call red solver simplifier)) (s, bindings) ars + ((s'', bindings''), red_r) <- reduceFCExpr g2call red solver simplifier s' bindings' r + + return (s'', bindings'', fc { arguments = red_ars, returns = red_r }) + +reduceFCExpr :: ( MonadIO m + , Solver solver + , Simplifier simplifier + , ASTContainer t Expr + , ASTContainer t Type + , Show t + , Named t) + => G2Call solver simplifier -> SomeReducer m t -> solver -> simplifier -> State t -> Bindings -> Expr -> m ((State t, Bindings), Expr) +reduceFCExpr g2call reducer solver simplifier s bindings e + | not . isTypeClass (type_classes s) $ (typeOf e) + , ds <- deepseq_walkers bindings + , Just strict_e <- mkStrict_maybe ds e = do + let + e' = fillLHDictArgs ds strict_e + + let s' = elimAssumesExcept + . elimAsserts + . pickHead + . elimSymGens (arb_value_gen bindings) + . modelToExprEnv $ + s { curr_expr = CurrExpr Evaluate e'} + + (er, bindings') <- g2call + reducer + (SomeHalter (acceptOnlyOneHalter <~> swhnfHalter <~> switchEveryNHalter 200)) + (SomeOrderer (incrAfterN 2000 (adtSizeOrderer 0 Nothing))) + solver simplifier + emptyMemConfig + s' bindings + + case er of + [er'] -> do + let fs = final_state er' + (CurrExpr _ ce) = curr_expr fs + return ((s { expr_env = foldr E.insertSymbolic (expr_env s') (E.symbolicIds $ expr_env fs) + , path_conds = path_conds fs } + , bindings { name_gen = name_gen bindings' }), ce) + _ -> error $ "reduceFCExpr: Bad reduction" + | isTypeClass (type_classes s) $ (typeOf e) + , TyCon n _:_ <- unTyApp (typeOf e) + , _:Type t:_ <- unApp e + , Just tc_dict <- typeClassInst (type_classes s) HM.empty n t = + return $ ((s, bindings), tc_dict) + | otherwise = return ((s, bindings), redVar (expr_env s) e) + + +reduceFuncCallMaybe :: ( MonadIO m + , Solver solver + , Simplifier simplifier + , ASTContainer t Expr + , ASTContainer t Type + , Show t + , Named t) + => G2Call solver simplifier -> SomeReducer m t -> solver -> simplifier -> State t -> Bindings -> FuncCall -> m (Maybe (State t, Bindings, FuncCall)) +reduceFuncCallMaybe g2call red solver simplifier s bindings fc@(FuncCall { arguments = ars, returns = r }) = do + ((s', bindings'), red_ars) <- mapAccumM (uncurry (reduceFCExpr g2call red solver simplifier)) (s, bindings) ars + ((s'', bindings''), red_r) <- reduceFCExpr g2call red solver simplifier s' bindings' r + + return $ Just (s'', bindings'', fc { arguments = red_ars, returns = red_r }) + +redVar :: E.ExprEnv -> Expr -> Expr +redVar = redVar' HS.empty + +-- We use the hashset to track names we've seen, and make sure we don't loop forever on the same variable +redVar' :: HS.HashSet Name -> E.ExprEnv -> Expr -> Expr +redVar' rep eenv v@(Var (Id n t)) + | n `HS.member` rep = v + | Just e <- E.lookup n eenv = redVar' (HS.insert n rep) eenv e + -- We fill in fake LH dict variable for reduction, so they don't exist in the ExprEnv, + -- but we don't want them to error + | TyCon (Name tn _ _ _) _ <- t + , tn == "lh" = v + | otherwise = error $ "redVar: variable not found" +redVar' _ _ e = e + +mapAccumM :: (Monad m, MonadPlus p) => (acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, p y) +mapAccumM _ z [] = return (z, mzero) +mapAccumM f z (x:xs) = do + (z', y) <- f z x + (z'', ys) <- mapAccumM f z' xs + return (z'', return y `mplus` ys) + +modelToExprEnv :: State t -> State t +modelToExprEnv s = + let + m = HM.filterWithKey (\k _ -> k /= idName existentialInstId && k /= idName postSeqExistentialInstId) (model s) + in + s { expr_env = m `E.union'` expr_env s + , model = HM.empty } + +mkAssertsTrue :: ASTContainer t Expr => KnownValues -> State t -> State t +mkAssertsTrue kv = modifyASTs (mkAssertsTrue' (mkTrue kv)) + +mkAssertsTrue' :: Expr -> Expr -> Expr +mkAssertsTrue' tre (G2.Assert fc _ e) = G2.Assert fc tre e +mkAssertsTrue' _ e = e + +elimSymGens :: ArbValueGen -> State t -> State t +elimSymGens arb s = s { expr_env = E.map esg $ expr_env s } + where + -- Rewriting the whole ExprEnv is slow, so we only + -- rewrite an Expr if needed. + esg e = + if hasSymGen e + then modify (elimSymGens' (type_env s) arb) e + else e + +elimSymGens' :: TypeEnv -> ArbValueGen -> Expr -> Expr +elimSymGens' tenv arb (SymGen _ t) = fst $ arbValue t tenv arb +elimSymGens' _ _ e = e + +hasSymGen :: Expr -> Bool +hasSymGen = getAny . eval hasSymGen' + +hasSymGen' :: Expr -> Any +hasSymGen' (SymGen _ _) = Any True +hasSymGen' _ = Any False + +------------------------------- +-- Generic +------------------------------- + +pickHead :: (ASTContainer m Expr) => m -> m +pickHead = modifyASTs pickHead' + +pickHead' :: Expr -> Expr +pickHead' (NonDet xs) + | x:_ <- xs = x + | otherwise = error "pickHead: empty NonDet" +pickHead' e = e diff --git a/src/G2/Liquid/Helpers.hs b/src/G2/Liquid/Helpers.hs new file mode 100644 --- /dev/null +++ b/src/G2/Liquid/Helpers.hs @@ -0,0 +1,196 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} + +module G2.Liquid.Helpers ( MeasureSymbols (..) + , getGHCInfos + , funcSpecs + + , getTySigs + , putTySigs + , getAssumedSigs + , putAssumedSigs + , getQualifiers + , putQualifiers + , findFuncSpec + , measureSpecs + , measureSymbols + , measureNames + , varToName + , varEqName + , namesEq + , fillLHDictArgs ) where + +import G2.Language as G2 +import G2.Liquid.Types +import G2.Translation.Haskell + +#if MIN_VERSION_liquidhaskell(0,9,0) +import qualified Liquid.GHC.Interface as LHI +#else +import qualified Language.Haskell.Liquid.GHC.Interface as LHI +#endif +import Language.Fixpoint.Types.Names +#if MIN_VERSION_liquidhaskell(0,8,10) +import Language.Haskell.Liquid.Types hiding + (Config, TargetInfo (..), TargetSpec (..), GhcSpec (..), cls, names) +#else +import Language.Haskell.Liquid.Types +#endif +import qualified Language.Haskell.Liquid.UX.Config as LHC +import Language.Fixpoint.Types (Qualifier (..)) + +import Data.List +import qualified Data.Map as M +import qualified Data.Text as T + +import GHC as GHC +#if MIN_VERSION_GLASGOW_HASKELL(9,0,2,0) +import GHC.Types.Name +import GHC.Types.Var as V +#else +import Name +import Var as V +#endif + +-- | Interface with LH +getGHCInfos :: LHC.Config -> [FilePath] -> [FilePath] -> IO [GhcInfo] +getGHCInfos config proj fp = do + let config' = config {idirs = idirs config ++ proj + , files = files config + , ghcOptions = ["-v"]} + + -- GhcInfo +#if MIN_VERSION_liquidhaskell(0,8,10) + (ghci, _) <- LHI.getTargetInfos Nothing config' fp +#else + (ghci, _) <- LHI.getGhcInfos Nothing config' fp +#endif + + return ghci + +funcSpecs :: [GhcInfo] -> [(Var, LocSpecType)] +funcSpecs fs = + let + asserted = concatMap getTySigs fs + assumed = concatMap getAssumedSigs fs + in + asserted ++ assumed + +-- | Functions asserted in LH +getTySigs :: GhcInfo -> [(Var, LocSpecType)] +#if MIN_VERSION_liquidhaskell(0,8,6) +getTySigs = gsTySigs . gsSig . giSpec +#else +getTySigs = gsTySigs . spec +#endif + +putTySigs :: GhcInfo -> [(Var, LocSpecType)] -> GhcInfo +#if MIN_VERSION_liquidhaskell(0,8,6) +putTySigs gi@(GI { + giSpec = sp@(SP { gsSig = sp_sig }) + } + ) new_ty_sigs = + gi { giSpec = sp { gsSig = sp_sig { gsTySigs = new_ty_sigs } } } +#else +putTySigs gi@(GI { spec = sp }) new_ty_sigs = + gi { spec = sp { gsTySigs = new_ty_sigs }} +#endif + +-- | Functions assumed in LH +getAssumedSigs :: GhcInfo -> [(Var, LocSpecType)] +#if MIN_VERSION_liquidhaskell(0,8,6) +getAssumedSigs = gsAsmSigs . gsSig . giSpec +#else +getAssumedSigs = gsAsmSigs . spec +#endif + +putAssumedSigs :: GhcInfo -> [(Var, LocSpecType)] -> GhcInfo +#if MIN_VERSION_liquidhaskell(0,8,6) +putAssumedSigs gi@(GI { + giSpec = sp@(SP { gsSig = sp_sig }) + } + ) new_ty_sigs = + gi { giSpec = sp { gsSig = sp_sig { gsTySigs = new_ty_sigs } } } +#else +putAssumedSigs gi@(GI { spec = sp }) new_ty_sigs = + gi { spec = sp { gsTySigs = new_ty_sigs }} +#endif + +getQualifiers :: GhcInfo -> [Qualifier] +#if MIN_VERSION_liquidhaskell(0,8,6) +getQualifiers = gsQualifiers . gsQual . giSpec +#else +getQualifiers = gsQualifiers . spec +#endif + +putQualifiers :: GhcInfo -> [Qualifier] -> GhcInfo +#if MIN_VERSION_liquidhaskell(0,8,6) +putQualifiers gi@(GI { + giSpec = sp@(SP { gsQual = quals }) + } + ) new_quals = + gi { giSpec = sp { gsQual = quals { gsQualifiers = new_quals } } } +#else +putQualifiers gi@(GI { spec = sp }) new_quals = + gi { spec = sp { gsQualifiers = new_quals }} +#endif + + +findFuncSpec :: [GhcInfo] -> G2.Name -> Maybe SpecType +findFuncSpec ghci g2_n = + let + fs = funcSpecs ghci + fs' = map (\(v, lst) -> (V.varName v, lst)) fs + in + case find (\(n, _) -> namesEq n g2_n) fs' of + Just st -> Just . val . snd $ st + Nothing -> Nothing + +varToName :: V.Var -> G2.Name +varToName = mkName . V.varName + +varEqName :: V.Var -> G2.Name -> Bool +varEqName v = namesEq (V.varName v) + +namesEq :: GHC.Name -> G2.Name -> Bool +namesEq ghc_n (Name n m _ _) = + T.pack (occNameString $ nameOccName ghc_n) == n + && (case nameModule_maybe ghc_n of + Just m' -> + Just (T.pack . moduleNameString . moduleName $ m') == m + Nothing -> m == Nothing) + +measureSpecs :: [GhcInfo] -> [Measure SpecType GHC.DataCon] +#if MIN_VERSION_liquidhaskell(0,8,6) +measureSpecs = concatMap (gsMeasures . gsData . giSpec) +#else +measureSpecs = concatMap (gsMeasures . spec) +#endif + +newtype MeasureSymbols = MeasureSymbols { symbols :: [Symbol] } + +measureSymbols :: [GhcInfo] -> MeasureSymbols +measureSymbols = MeasureSymbols . measureNames + +measureNames :: [GhcInfo] -> [Symbol] +#if MIN_VERSION_liquidhaskell(0,8,6) +measureNames = map (val . msName) . measureSpecs +#else +measureNames = map (val . name) . measureSpecs +#endif + +-- The walk function takes lhDict arguments that are not correctly accounted for by mkStrict. +-- The arguments are not actually used, so, here, we fill them in with undefined. +fillLHDictArgs :: Walkers -> Expr -> Expr +fillLHDictArgs w = modifyAppTop (fillLHDictArgs' w) + +fillLHDictArgs' :: Walkers -> Expr -> Expr +fillLHDictArgs' w e + | f@(Var i):xs <- unApp e + , any (\(_, i') -> i == i') (M.toList w) = mkApp $ f:fillLHDictArgs'' 0 xs + | otherwise = e + +fillLHDictArgs'' :: Int -> [Expr] -> [Expr] +fillLHDictArgs'' !n [] = replicate n (Prim Undefined TyBottom) +fillLHDictArgs'' !n (t@(Type _):xs) = t:fillLHDictArgs'' (n + 1) xs +fillLHDictArgs'' !n xs = replicate n (Prim Undefined TyBottom) ++ xs diff --git a/src/G2/Liquid/Inference/Config.hs b/src/G2/Liquid/Inference/Config.hs new file mode 100644 --- /dev/null +++ b/src/G2/Liquid/Inference/Config.hs @@ -0,0 +1,431 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} + +module G2.Liquid.Inference.Config ( + Progress (..) + , Progresser (..) + , ProgresserM (..) + , MaxSize (..) + , newProgress + , runProgresser + + , InfConfigM (..) + , InferenceConfig (..) + , Configs (..) + , InfConfig (..) + , runConfigs + + , getAllConfigsForInf + , mkInferenceConfig + , mkInferenceConfigDirect + , adjustConfig + , adjustConfigPostLH + + , incrMaxSize ) where + +import G2.Config.Config +import G2.Initialization.Types +import G2.Language ( ExprEnv + , Expr + , Name (..) + , Type (..)) +import qualified G2.Language.ExprEnv as E +import qualified G2.Language.Support as S +import G2.Language.Typing +import G2.Liquid.Config +import G2.Liquid.Conversion +import G2.Liquid.Helpers +import G2.Liquid.TCValues +import G2.Liquid.Types +import G2.Liquid.Inference.PolyRef +import G2.Translation.Haskell + +#if MIN_VERSION_liquidhaskell(0,8,10) +import G2.Liquid.Types (GhcInfo (..), GhcSpec (..)) +#else +import Language.Haskell.Liquid.Types (GhcInfo (..), GhcSpec (..)) +#endif +import qualified Language.Haskell.Liquid.Types as LH + +#if MIN_VERSION_GLASGOW_HASKELL(9,0,2,0) +import GHC.Types.Var as V +#else +import Var as V +#endif + +import Control.Monad.Reader +import Control.Monad.State.Lazy +import qualified Data.HashSet as S +import qualified Data.Map as M +import Data.Maybe (isJust) +import Data.Monoid ((<>)) +import qualified Data.Text as T +import Data.Time.Clock +import Options.Applicative +import System.Directory + + +------------------------------- +-- Progresser +------------------------------- + +newtype MaxSize = MaxSize Integer + +data Progress = + Progress { ex_max_ce :: M.Map (T.Text, Maybe T.Text) Int -- ^ Gives an extra budget for maximum ce number + , ex_max_depth :: Int -- ^ Gives an extra budget for the depth limit + , ex_max_time :: M.Map (T.Text, Maybe T.Text) NominalDiffTime -- ^ Gives an extra max bufget for time + , max_synth_form_size :: MaxSize + , max_synth_coeff_size :: MaxSize + , synth_fresh :: Int -- ^ An int to increment to get fresh names + } + +newProgress :: Progress +newProgress = Progress { ex_max_ce = M.empty + , ex_max_depth = 0 + , ex_max_time = M.empty + , max_synth_form_size = MaxSize 1 + , max_synth_coeff_size = MaxSize 2 + , synth_fresh = 0 } + +class Progresser p where + extraMaxCEx :: (T.Text, Maybe T.Text) -> p -> Int + incrMaxCEx :: (T.Text, Maybe T.Text) -> p -> p + + extraMaxDepth :: p -> Int + incrMaxDepth :: p -> p + + extraMaxTime :: (T.Text, Maybe T.Text) -> p -> NominalDiffTime + incrMaxTime :: (T.Text, Maybe T.Text) -> p -> p + + maxSynthFormSize :: p -> MaxSize + incrMaxSynthFormSize :: p -> p + + maxSynthCoeffSize :: p -> MaxSize + incrMaxSynthCoeffSize :: p -> p + setMaxSynthCoeffSize :: MaxSize -> p -> p + + synthFresh :: p -> Int + incrSynthFresh :: p -> p + +instance Progresser Progress where + extraMaxCEx n (Progress { ex_max_ce = m }) = M.findWithDefault 0 n m + incrMaxCEx n p@(Progress { ex_max_ce = m }) = + p { ex_max_ce = M.insertWith (+) n 2 m } + + extraMaxDepth (Progress { ex_max_depth = m }) = m + incrMaxDepth p@(Progress { ex_max_depth = m }) = p { ex_max_depth = m + 200 } + + extraMaxTime n (Progress { ex_max_time = m }) = M.findWithDefault 0 n m + incrMaxTime n p@(Progress { ex_max_time = m }) = + p { ex_max_time = M.insertWith (+) n 4 m } + + maxSynthFormSize (Progress { max_synth_form_size = mss }) = mss + incrMaxSynthFormSize p@(Progress { max_synth_form_size = mss }) = p { max_synth_form_size = incrMaxSize 1 mss } + + maxSynthCoeffSize (Progress { max_synth_coeff_size = mss }) = mss + incrMaxSynthCoeffSize p@(Progress { max_synth_coeff_size = mss }) = p { max_synth_coeff_size = incrMaxSize 2 mss } + setMaxSynthCoeffSize max_size p = p { max_synth_coeff_size = max_size } + + + synthFresh (Progress { synth_fresh = syf }) = syf + incrSynthFresh p@(Progress { synth_fresh = syf }) = p { synth_fresh = syf + 1 } + +class Monad m => ProgresserM m where + extraMaxCExM :: (T.Text, Maybe T.Text) -> m Int + incrMaxCExM :: (T.Text, Maybe T.Text) -> m () + + extraMaxDepthM :: m Int + incrMaxDepthM :: m () + + extraMaxTimeM :: (T.Text, Maybe T.Text) -> m NominalDiffTime + incrMaxTimeM :: (T.Text, Maybe T.Text) -> m () + + maxSynthFormSizeM :: m MaxSize + incrMaxSynthFormSizeM :: m () + + maxSynthCoeffSizeM :: m MaxSize + incrMaxSynthCoeffSizeM :: m () + setMaxSynthCoeffSizeM :: MaxSize -> m () + + synthFreshM :: m Int + incrSynthFreshM :: m () + +instance (Monad m, Progresser p) => ProgresserM (StateT p m) where + extraMaxCExM n = gets (extraMaxCEx n) + incrMaxCExM n = modify' (incrMaxCEx n) + + extraMaxDepthM = gets extraMaxDepth + incrMaxDepthM = modify' incrMaxDepth + + extraMaxTimeM n = gets (extraMaxTime n) + incrMaxTimeM n = modify' (incrMaxTime n) + + maxSynthFormSizeM = gets maxSynthFormSize + incrMaxSynthFormSizeM = modify' incrMaxSynthFormSize + + maxSynthCoeffSizeM = gets maxSynthCoeffSize + incrMaxSynthCoeffSizeM = modify' incrMaxSynthCoeffSize + setMaxSynthCoeffSizeM max_size = modify' (setMaxSynthCoeffSize max_size) + + synthFreshM = gets synthFresh + incrSynthFreshM = modify' incrSynthFresh + +instance ProgresserM m => ProgresserM (ReaderT env m) where + extraMaxCExM n = lift (extraMaxCExM n) + incrMaxCExM n = lift (incrMaxCExM n) + + extraMaxDepthM = lift extraMaxDepthM + incrMaxDepthM = lift incrMaxDepthM + + extraMaxTimeM n = lift (extraMaxTimeM n) + incrMaxTimeM n = lift (incrMaxTimeM n) + + maxSynthFormSizeM = lift maxSynthFormSizeM + incrMaxSynthFormSizeM = lift incrMaxSynthFormSizeM + + maxSynthCoeffSizeM = lift maxSynthCoeffSizeM + incrMaxSynthCoeffSizeM = lift incrMaxSynthCoeffSizeM + setMaxSynthCoeffSizeM max_size = lift (setMaxSynthCoeffSizeM max_size) + + synthFreshM = lift synthFreshM + incrSynthFreshM = lift incrSynthFreshM + +runProgresser :: (Monad m, Progresser p) => StateT p m a -> p -> m a +runProgresser = evalStateT + +incrMaxSize :: Integer -> MaxSize -> MaxSize +incrMaxSize incr (MaxSize sz) = MaxSize (sz + incr) + +------------------------------- +-- Configurations +------------------------------- + +data Configs = Configs { g2_config :: Config + , g2lh_config :: LHConfig -- ^ Configurations for running G2 in LH mode + , lh_config :: LH.Config -- ^ LiquidHaskell configuration settings + , inf_config :: InferenceConfig } + +class InfConfig c where + g2Config :: c -> Config + g2lhConfig :: c -> LHConfig + lhConfig :: c -> LH.Config + infConfig :: c -> InferenceConfig + +class Monad m => InfConfigM m where + g2ConfigM :: m Config + g2lhConfigM :: m LHConfig + lhConfigM :: m LH.Config + infConfigM :: m InferenceConfig + +instance InfConfig Configs where + g2Config = g2_config + g2lhConfig = g2lh_config + lhConfig = lh_config + infConfig = inf_config + +instance InfConfig env => InfConfig (ReaderT env m a) where + g2Config = return . g2Config =<< ask + g2lhConfig = return . g2lhConfig =<< ask + lhConfig = return . lhConfig =<< ask + infConfig = return . infConfig =<< ask + +instance (Monad m, InfConfig env) => InfConfigM (ReaderT env m) where + g2ConfigM = return . g2Config =<< ask + g2lhConfigM = return . g2lhConfig =<< ask + lhConfigM = return . lhConfig =<< ask + infConfigM = return . infConfig =<< ask + +instance InfConfigM m => InfConfigM (StateT env m) where + g2ConfigM = lift g2ConfigM + g2lhConfigM = lift g2lhConfigM + lhConfigM = lift lhConfigM + infConfigM = lift infConfigM + + +data InferenceConfig = + InferenceConfig { keep_quals :: Bool + + , modules :: S.HashSet (Maybe T.Text) + , max_ce :: Int + + , pre_refined :: S.HashSet (T.Text, Maybe T.Text) + , refinable_funcs :: S.HashSet (T.Text, Maybe T.Text) + + , restrict_coeffs :: Bool -- ^ If true, only allow coefficients in the range of -1 <= c <= 1 + + , use_extra_fcs :: Bool -- ^ If true, generate as many constraints as possible, if false, generate + -- only those that are essential to block bad specifications + , use_level_dec :: Bool + , use_negated_models :: Bool + + , use_binary_minimization :: Bool -- ^ In parallel to the SMT's solvers minimization support, + -- use a binary search to minimize synthesis solutions + + , use_invs :: Bool + + , timeout_se :: NominalDiffTime + , timeout_sygus :: NominalDiffTime } + +getAllConfigsForInf :: IO (String, Bool, Config, LHConfig, InferenceConfig, Maybe String) +getAllConfigsForInf = do + homedir <- getHomeDirectory + execParser (mkAllConfigsForInf homedir) + +mkAllConfigsForInf :: String -> ParserInfo (String, Bool, Config, LHConfig, InferenceConfig, Maybe String) +mkAllConfigsForInf homedir = + info (((,,,,,) <$> getFileName + <*> flag False True (long "count" <> help "count the number of functions in the file") + <*> mkConfig homedir + <*> mkLHConfig + <*> mkInferenceConfig + <*> mkFuncCheck) <**> helper) + ( fullDesc + <> progDesc "Automatically infers specifications to verify code using LiquidHaskell." + <> header "The G2 Symbolic Execution Engine" ) + +getFileName :: Parser String +getFileName = argument str (metavar "FILE") + +runConfigs :: InfConfig env => ReaderT env m a -> env -> m a +runConfigs = runReaderT + +mkInferenceConfig :: Parser InferenceConfig +mkInferenceConfig = InferenceConfig + <$> flag True False (long "keep-quals" <> help "allow qualifiers to be generated and used during inference") + <*> pure S.empty + <*> option auto (long "max-ce" + <> metavar "M" + <> value 5 + <> help "the initial maximal number of counterexamples to return from any symbolic execution call") + <*> pure S.empty + <*> pure S.empty + <*> switch (long "restrict-coeffs-1" <> help "restrict coefficients to -1, 0, 1") + <*> flag True False (long "no-extra-fcs" <> help "do not generate extra (non-blocking) constraints") + <*> flag True False (long "no-level-dec" <> help "do not use level descent") + <*> flag True False (long "no-negated-models" <> help "do not use negated models") + <*> flag True False (long "no-binary-min" <> help "use binary minimization during synthesis") + <*> switch (long "use-invs" <> help "use invariant mode (benchmarking only)") + <*> option (maybeReader (Just . fromInteger . read)) (long "timeout-se" + <> metavar "T" + <> value 5 + <> help "timeout for symbolic execution") + <*> option (maybeReader (Just . fromInteger . read)) (long "timeout-sygus" + <> metavar "T" + <> value 5 + <> help "timeout for synthesis") + +mkFuncCheck :: Parser (Maybe String) +mkFuncCheck = + option (eitherReader (Right . Just)) + ( long "liquid-func" + <> metavar "FUNC" + <> value Nothing + <> help "a function to directly run symbolic execution on") + + +mkInferenceConfigDirect :: [String] -> InferenceConfig +mkInferenceConfigDirect as = + InferenceConfig { keep_quals = boolArg "keep-quals" as M.empty On + , modules = S.empty + , max_ce = strArg "max-ce" as M.empty read 5 + , pre_refined = S.empty + , refinable_funcs = S.empty + , restrict_coeffs = boolArg "restrict-coeffs" as M.empty Off + , use_extra_fcs = boolArg "use-extra-fc" as M.empty On + , use_level_dec = boolArg "use-level-dec" as M.empty On + , use_negated_models = boolArg "use-negated-models" as M.empty On + , use_binary_minimization = True + , use_invs = boolArg "use-invs" as M.empty Off + , timeout_se = strArg "timeout-se" as M.empty (fromInteger . read) 5 + , timeout_sygus = strArg "timeout-sygus" as M.empty (fromInteger . read) 10 } + +adjustConfig :: Maybe T.Text -> SimpleState -> Config -> LHConfig -> InferenceConfig -> [GhcInfo] -> (Config, LHConfig, InferenceConfig) +adjustConfig main_mod (SimpleState { expr_env = eenv }) config lhconfig infconfig ghci = + let + -- ref = refinable main_mod meas tcv eenv + + pre = S.fromList + . map (\(Name n m _ _) -> (n, m)) + . map (mkName . V.varName . fst) + $ concatMap getTySigs ghci + + -- ns_mm = map (\(Name n m _ _) -> (n, m)) + -- -- . filter (\(Name n m _ _) -> not $ (n, m) `S.member` pre) + -- -- . filter (\(Name n _ _ _) -> n `notElem` [ "mapReduce" ]) + -- -- . filter (\(Name n _ _ _) -> n `notElem` [ "mapReduce", "singleton", "concat", "append" + -- -- , "map", "replicate", "empty", "zipWith", "add"]) + -- . filter (\(Name n m _ _) -> (n, m) `elem` ref) + -- . E.keys + -- . E.filter (not . tyVarNoMeas meas tcv) + -- $ E.filter (not . tyVarRetTy) eenv + + ns_not_main = filter (\(n, _) -> n == "foldr1") + . map (\(Name n m _ _) -> (n, m)) + . filter (\(Name _ m _ _) -> m /= main_mod) + $ E.keys eenv + + lhconfig' = lhconfig { only_top = True + , block_errors_in = S.fromList ns_not_main } + + infconfig' = infconfig { modules = S.singleton main_mod + , pre_refined = pre } + in + (config, lhconfig', infconfig') + +adjustConfigPostLH :: Maybe T.Text -> Measures -> TCValues -> S.State t -> [GhcInfo] -> LHConfig -> LHConfig +adjustConfigPostLH main_mod meas tcv (S.State { S.expr_env = eenv, S.known_values = kv }) ghci lhconfig = + let + ref = refinable main_mod meas tcv ghci kv eenv + + ns_mm = map (\(Name n m _ _) -> (n, m)) + . filter (\(Name n m _ _) -> (n, m) `elem` ref) + $ E.keys eenv + + in + lhconfig { counterfactual = Counterfactual . CFOnly $ S.fromList ns_mm } + +refinable :: Maybe T.Text -> Measures -> TCValues -> [GhcInfo] -> S.KnownValues -> ExprEnv -> [(T.Text, Maybe T.Text)] +refinable main_mod meas tcv ghci kv eenv = + let + ns_mm = E.keys + . E.filter (\e -> not (tyVarNoMeas meas tcv ghci e) || isPrimRetTy kv e) + . E.filter (not . tyVarRetTy) + $ E.filterWithKey (\(Name _ m _ _) _ -> m == main_mod) eenv + ns_mm' = map (\(Name n m _ _) -> (n, m)) ns_mm + in + ns_mm' + +isPrimRetTy :: S.KnownValues -> Expr -> Bool +isPrimRetTy kv e = + let + rel_t = extractValues . extractTypePolyBound $ returnType e + in + any (\t -> t == tyInt kv || t == tyBool kv) rel_t + +tyVarNoMeas :: Measures -> TCValues -> [GhcInfo] -> Expr -> Bool +tyVarNoMeas meas tcv ghci e = + let + rel_t = extractValues . extractTypePolyBound $ returnType e + rel_meas = E.filter (\e -> + case filter notLH . argumentTypes . PresType . inTyForAlls $ typeOf e of + [t] -> any (\t' -> isJust $ t' `specializes` t) rel_t + _ -> False ) meas' + in + E.null rel_meas + where + meas_names = measureNames ghci + meas_nameOcc = map (\(Name n md _ _) -> (n, md)) $ map symbolName meas_names + meas' = E.filterWithKey (\(Name n m _ _) _ -> (n, m) `elem` meas_nameOcc) meas + + notLH t + | TyCon n _ <- tyAppCenter t = n /= lhTC tcv + | otherwise = False + +tyVarRetTy :: Expr -> Bool +tyVarRetTy e = + case returnType e of + TyVar _ -> True + _ -> False + diff --git a/src/G2/Liquid/Inference/FuncConstraint.hs b/src/G2/Liquid/Inference/FuncConstraint.hs new file mode 100644 --- /dev/null +++ b/src/G2/Liquid/Inference/FuncConstraint.hs @@ -0,0 +1,199 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} + +module G2.Liquid.Inference.FuncConstraint ( FuncConstraint (..) + , SpecPart (..) + -- , Polarity (..) + -- , Violated (..) + -- , Modification (..) + -- , BoolRel (..) + , FuncConstraints + , HigherOrderFuncCall + , emptyFC + , fromSingletonFC + , fromListFC + , nullFC + , insertFC + , lookupFC + , toListFC + , unionFC + , unionsFC + , mapFC + , filterFC + , differenceFC + , allCallNames + , allCalls + , allCallsFC + + , zeroOutUnq + + , printFCs + , printFC) where + +import G2.Language.AST +import G2.Language.Naming +import G2.Language.Support +import G2.Language.Syntax +import G2.Lib.Printers +import G2.Liquid.Interface +import G2.Liquid.Types + +import Data.Coerce +import GHC.Generics (Generic) +import Data.Hashable +import qualified Data.HashSet as HS +import qualified Data.HashMap.Lazy as HM +import qualified Data.Map as M +import Data.Monoid hiding (All) +import qualified Data.Text as T + +newtype FuncConstraints = FuncConstraints (M.Map Name (HS.HashSet FuncConstraint)) + deriving (Eq, Show, Read) + +data SpecPart = All | Pre | Post deriving (Eq, Show, Read, Generic) + +data FuncConstraint = Call SpecPart FuncCall [HigherOrderFuncCall] + | AndFC [FuncConstraint] + | OrFC [FuncConstraint] + | ImpliesFC FuncConstraint FuncConstraint + | NotFC FuncConstraint + deriving (Eq, Show, Read, Generic) + +instance Hashable SpecPart +instance Hashable FuncConstraint + +emptyFC :: FuncConstraints +emptyFC = FuncConstraints M.empty + +fromSingletonFC :: FuncConstraint -> FuncConstraints +fromSingletonFC = flip insertFC emptyFC + +fromListFC :: [FuncConstraint] -> FuncConstraints +fromListFC = foldr insertFC emptyFC + +nullFC :: FuncConstraints -> Bool +nullFC = null . toListFC + +insertFC :: FuncConstraint -> FuncConstraints -> FuncConstraints +insertFC fc (FuncConstraints fcs) = + let + ns = allCallNames fc + ns' = map zeroOutUnq ns + fc' = renames (HM.fromList $ zip ns ns') fc + hs_fc = HS.singleton fc' + in + FuncConstraints $ foldr (\n -> M.insertWith HS.union n hs_fc) fcs ns' + -- coerce (M.insertWith (++) (zeroOutUnq . funcName . constraint $ fc) [fc]) + +lookupFC :: Name -> FuncConstraints -> [FuncConstraint] +lookupFC n = HS.toList . M.findWithDefault HS.empty (zeroOutUnq n) . coerce + +zeroOutUnq :: Name -> Name +zeroOutUnq (Name n m _ l) = Name n m 0 l + +toListFC :: FuncConstraints -> [FuncConstraint] +toListFC = HS.toList . HS.unions . M.elems . coerce + +unionFC :: FuncConstraints -> FuncConstraints -> FuncConstraints +unionFC (FuncConstraints fc1) (FuncConstraints fc2) = + coerce $ M.unionWith HS.union fc1 fc2 + +unionsFC :: [FuncConstraints] -> FuncConstraints +unionsFC = foldr unionFC emptyFC + +mapFC :: (FuncConstraint -> FuncConstraint) -> FuncConstraints -> FuncConstraints +mapFC f = coerce (M.map (HS.map f)) + +filterFC :: (FuncConstraint -> Bool) -> FuncConstraints -> FuncConstraints +filterFC p = coerce (M.map (HS.filter p)) + +differenceFC :: FuncConstraints -> FuncConstraints -> FuncConstraints +differenceFC (FuncConstraints fc1) (FuncConstraints fc2) = + FuncConstraints $ M.differenceWith + (\v1 v2 -> let + d = HS.difference v1 v2 + in + case HS.null d of + True -> Nothing + False -> Just d) + fc1 fc2 + +allCallNames :: FuncConstraint -> [Name] +allCallNames = map funcName . map fst . allCalls + +allCalls :: FuncConstraint -> [(FuncCall, [HigherOrderFuncCall])] +allCalls (Call _ fc hfc) = [(fc, hfc)] +allCalls (AndFC fcs) = concatMap allCalls fcs +allCalls (OrFC fcs) = concatMap allCalls fcs +allCalls (ImpliesFC fc1 fc2) = allCalls fc1 ++ allCalls fc2 +allCalls (NotFC fc) = allCalls fc + +allCallsFC :: FuncConstraints -> [(FuncCall, [HigherOrderFuncCall])] +allCallsFC = concatMap allCalls . toListFC + +printFCs :: LiquidReadyState -> FuncConstraints -> T.Text +printFCs lrs fcs = + T.intercalate "\n" . map (printFC (state . lr_state $ lrs)) $ toListFC fcs + +printFC :: State t -> FuncConstraint -> T.Text +printFC s (Call sp (FuncCall { funcName = Name f _ _ _, arguments = ars, returns = r}) hclls) = + let + call_str fn = printHaskell s . foldl (\a a' -> App a a') (Var (Id fn TyUnknown)) $ ars + r_str = printHaskell s r + + hclls_str = case null hclls of + True -> "" + False -> ", higher_calls = " <> T.intercalate ", " (map printFuncCall hclls) + in + case sp of + Pre -> "(" <> call_str (Name (f <> "_pre") Nothing 0 Nothing) <> hclls_str <> ")" + Post -> "(" <> call_str (Name (f <> "_post") Nothing 0 Nothing) <> " " <> r_str <> hclls_str <> ")" + All -> "(" <> call_str (Name f Nothing 0 Nothing) <> " " <> r_str <> hclls_str <> ")" +printFC s (AndFC fcs) = + case fcs of + (f:fcs') -> foldr (\fc fcs'' -> fcs'' <> " && " <> printFC s fc) (printFC s f) fcs' + [] -> "True" +printFC s (OrFC fcs) = + case fcs of + (f:fcs') -> foldr (\fc fcs'' -> fcs'' <> " || " <> printFC s fc) (printFC s f) fcs' + [] -> "False" +printFC s (ImpliesFC fc1 fc2) = "(" <> printFC s fc1 <> ") => (" <> printFC s fc2 <> ")" +printFC s (NotFC fc) = "not (" <> printFC s fc <> ")" + +instance ASTContainer FuncConstraint Expr where + containedASTs (Call _ fc hcalls) = containedASTs fc ++ containedASTs hcalls + containedASTs (AndFC fcs) = containedASTs fcs + containedASTs (OrFC fcs) = containedASTs fcs + containedASTs (ImpliesFC fc1 fc2) = containedASTs fc1 ++ containedASTs fc2 + containedASTs (NotFC fc) = containedASTs fc + + modifyContainedASTs f (Call sp fc hcalls) = Call sp (modifyContainedASTs f fc) (modifyContainedASTs f hcalls) + modifyContainedASTs f (AndFC fcs) = AndFC (modifyContainedASTs f fcs) + modifyContainedASTs f (OrFC fcs) = OrFC (modifyContainedASTs f fcs) + modifyContainedASTs f (ImpliesFC fc1 fc2) = ImpliesFC (modifyContainedASTs f fc1) (modifyContainedASTs f fc2) + modifyContainedASTs f (NotFC fc) = NotFC (modifyContainedASTs f fc) + +instance Named FuncConstraints where + names (FuncConstraints fc) = names fc + rename old new (FuncConstraints fc) = FuncConstraints (rename old new fc) + renames hm (FuncConstraints fc) = FuncConstraints (renames hm fc) + +instance Named FuncConstraint where + names (Call _ fc hcalls) = names fc <> names hcalls + names (AndFC fcs) = names fcs + names (OrFC fcs) = names fcs + names (ImpliesFC fc1 fc2) = names fc1 <> names fc2 + names (NotFC fc) = names fc + + rename old new (Call sp fc hcalls) = Call sp (rename old new fc) (rename old new hcalls) + rename old new (AndFC fcs) = AndFC (rename old new fcs) + rename old new (OrFC fcs) = OrFC (rename old new fcs) + rename old new (ImpliesFC fc1 fc2) = ImpliesFC (rename old new fc1) (rename old new fc2) + rename old new (NotFC fc) = NotFC (rename old new fc) + + renames hm (Call sp fc hcalls) = Call sp (renames hm fc) (renames hm hcalls) + renames hm (AndFC fcs) = AndFC (renames hm fcs) + renames hm (OrFC fcs) = OrFC (renames hm fcs) + renames hm (ImpliesFC fc1 fc2) = ImpliesFC (renames hm fc1) (renames hm fc2) + renames hm (NotFC fc) = NotFC (renames hm fc) diff --git a/src/G2/Liquid/Inference/G2Calls.hs b/src/G2/Liquid/Inference/G2Calls.hs new file mode 100644 --- /dev/null +++ b/src/G2/Liquid/Inference/G2Calls.hs @@ -0,0 +1,1110 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +module G2.Liquid.Inference.G2Calls ( MeasureExs + , MaxMeasures + , PreEvals + , PostEvals + , FCEvals + , Evals (..) + + , SpreadOutSolver (..) + + , gatherAllowedCalls + + , runLHInferenceAll + + , runLHInferenceCore + , runLHCExSearch + , checkFuncCall + , checkCounterexample + + , emptyEvals + , preEvals + , postEvals + , checkPre + , checkPost + , lookupEvals + , mapEvals + , mapAccumLEvals + , deleteEvalsForFunc + , printEvals + + , evalMeasures + , formMeasureComps + , chainReturnType) where + +import G2.Config + +import G2.Execution +import G2.Execution.PrimitiveEval +import G2.Interface +import G2.Language as G2 +import qualified G2.Language.ExprEnv as E +import qualified G2.Language.PathConds as PC +import G2.Lib.Printers +import G2.Liquid.Inference.Config +import G2.Liquid.AddCFBranch +import G2.Liquid.Config +import G2.Liquid.Conversion +import G2.Liquid.ConvertCurrExpr +import G2.Liquid.G2Calls +import G2.Liquid.Helpers +import G2.Liquid.Interface +import G2.Liquid.LHReducers +import G2.Liquid.TCValues +import G2.Liquid.Types +import G2.Liquid.TyVarBags +import G2.Liquid.Inference.InfStack +import G2.Liquid.Inference.Initalization +import G2.Solver hiding (Assert) +import G2.Translation + +import Language.Haskell.Liquid.Types hiding (Config, hs) + +import qualified Data.HashSet as HS +import qualified Data.HashMap.Lazy as HM +import Data.List +import qualified Data.Map as M +import Data.Maybe +import qualified Data.Sequence as S +import qualified Data.Text as T +import Data.Tuple.Extra + +import Control.Monad +import Control.Monad.Extra +import Control.Exception +import Control.Monad.IO.Class +import qualified Control.Monad.State as SM +import Data.Function +import Data.Monoid + +------------------------------------- +-- Solvers +------------------------------------- + +-- | A solver that adds soft asserts to (try to) spread out integer values +-- returned in a model. +data SpreadOutSolver solver = SpreadOutSolver Integer solver + +instance Solver solver => Solver (SpreadOutSolver solver) where + check (SpreadOutSolver _ solver) s pc = check solver s pc + + solve (SpreadOutSolver mx_size solver) s b is pc = + let + int_vs = filter (isInteger . typeOf) is + max_vs = map (\i -> Id (Name "MAX_INT_ORD__??__" Nothing i Nothing) TyLitInt) + . map fst + $ zip [1..] int_vs + + max_vs_eq = map (flip ExtCond True) + $ map (\mv -> foldr1 or_expr $ map (\iv -> abs_expr (Var iv) `eq` Var mv) int_vs) max_vs + max_ord = map (flip ExtCond True) . map (\(x, y) -> Var x `le_expr` Var y) $ adj max_vs + soft_space = map SoftPC + . map (flip ExtCond True) + . map (\(v, vs) -> sum_vars vs `lt_expr` Var v) + . map (\(v:vs) -> (v, vs)) + . filter (not . null) + . inits $ reverse max_vs + + pc' = PC.fromList $ max_vs_eq ++ max_ord ++ soft_space + pc_union = pc `PC.union` pc' + in + case null int_vs of + False -> solve solver s b is pc_union + True -> solve solver s b is pc + where + isInteger TyLitInt = True + isInteger _ = False + + abs_expr x = App (Prim Abs TyUnknown) x + eq x y = App (App (Prim Eq TyUnknown) x) y + or_expr x y = App (App (Prim Or TyUnknown) x) y + le_expr x y = App (App (Prim Le TyUnknown) x) y + lt_expr x y = App (App (Prim Lt TyUnknown) x) y + plus_expr x y = App (App (Prim Plus TyUnknown) x) y + mult_expr x y = App (App (Prim Mult TyUnknown) x) y + + sum_vars = foldr plus_expr (Lit (LitInt mx_size)) + . map (mult_expr (Lit (LitInt mx_size))) + . map Var + + adj xs = zip xs $ tail xs + + close (SpreadOutSolver _ solver) = close solver + +------------------------------------- +-- Calling G2 +------------------------------------- + + +{-# SPECIALISE + runLHG2Inference :: (Solver solver, Simplifier simplifier) + => Config + -> SomeReducer (SM.StateT PrettyGuide IO) LHTracker + -> SomeHalter (SM.StateT PrettyGuide IO) LHTracker + -> SomeOrderer (SM.StateT PrettyGuide IO) LHTracker + -> solver + -> simplifier + -> MemConfig + -> Id + -> State LHTracker + -> Bindings + -> SM.StateT PrettyGuide IO ([ExecRes AbstractedInfo], Bindings) + #-} +runLHG2Inference :: (MonadIO m, Solver solver, Simplifier simplifier) + => Config + -> SomeReducer m LHTracker + -> SomeHalter m LHTracker + -> SomeOrderer m LHTracker + -> solver + -> simplifier + -> MemConfig + -> Id + -> State LHTracker + -> Bindings + -> m ([ExecRes AbstractedInfo], Bindings) +runLHG2Inference config red hal ord solver simplifier pres_names init_id final_st bindings = do + let only_abs_st = addTicksToDeepSeqCases (deepseq_walkers bindings) final_st + (ret, final_bindings) <- case (red, hal, ord) of + (SomeReducer red', SomeHalter hal', SomeOrderer ord') -> + runG2ThroughExecution red' hal' ord' pres_names only_abs_st bindings + + ret' <- filterM (satState solver) ret + let ret'' = onlyMinimalStates $ map (earlyExecRes final_bindings) ret' + + cleanupResultsInference solver simplifier config init_id final_bindings ret'' + +cleanupResultsInference :: (MonadIO m, Solver solver, Simplifier simplifier) => + solver + -> simplifier + -> Config + -> Id + -> Bindings + -> [ExecRes LHTracker] + -> m ([ExecRes AbstractedInfo], Bindings) +cleanupResultsInference solver simplifier config init_id bindings ers = do + let ers2 = map (\er -> er { final_state = putSymbolicExistentialInstInExprEnv (final_state er) }) ers + let ers3 = map (replaceHigherOrderNames (idName init_id) (input_names bindings)) ers2 + (bindings', ers4) <- liftIO $ mapAccumM (reduceCalls runG2ThroughExecutionInference solver simplifier config) bindings ers3 + ers5 <- liftIO $ mapM (checkAbstracted runG2ThroughExecutionInference solver simplifier config init_id bindings') ers4 + ers6 <- liftIO $ mapM (runG2SolvingInference solver simplifier bindings') ers5 + + let ers7 = + map (\er@(ExecRes { final_state = s }) -> + (er { final_state = + s {track = + mapAbstractedInfoFCs (evalPrims (type_env s) (known_values s) + . subVarFuncCall True (model s) (expr_env s) (type_classes s)) + $ track s + } + })) ers6 + return (ers7, bindings') + +replaceHigherOrderNames :: Name -> [Name] -> ExecRes LHTracker -> ExecRes LHTracker +replaceHigherOrderNames init_name input_names er@(ExecRes { final_state = s@(State { expr_env = eenv, track = t })}) = + let + higher = higher_order_calls t + + input_names' = filter (hasFuncType . (E.!) eenv) input_names + higher_num_init = zip input_names' (map (higherOrderName (nameOcc init_name)) [1..]) + higher_num_all = concatMap (\fc -> let + as = map nameFromVar $ filter hasFuncType (arguments fc) + in + zip as (map (higherOrderName (nameOcc $ funcName fc)) [1..]) ) + . map (\fc -> if nameOcc (funcName fc) == "INITIALLY_CALLED_FUNC" then fc { funcName = init_name } else fc) + . nubBy ((==) `on` funcName) $ all_calls t + higher_num = higher_num_init ++ higher_num_all + + higher' = map (\fc -> fc { funcName = lookupErr (funcName fc) higher_num }) higher + in + er { final_state = s { track = t { higher_order_calls = higher' }}} + where + lookupErr x xs = case lookup x xs of + Just v -> v + Nothing -> x -- error $ "replaceHigherOrderNames: missing function name" ++ "\nhigher_num = " ++ show xs ++ "\nx = " ++ show x + + nameFromVar (Var (Id n _)) = n + nameFromVar e = error $ "nameFromVar: not Var" ++ show e + +higherOrderName :: T.Text -> Int -> Name +higherOrderName n i = Name n (Just "HIGHER_ORDER_??_") i Nothing + +runG2ThroughExecutionInference :: G2Call solver simplifier +runG2ThroughExecutionInference red hal ord _ _ pres s b = do + (fs, fb) <- case (red, hal, ord) of + (SomeReducer red', SomeHalter hal', SomeOrderer ord') -> runG2ThroughExecution red' hal' ord' pres s b + return (map (earlyExecRes fb) fs, fb) + +runG2SolvingInference :: (MonadIO m, Solver solver, Simplifier simplifier) => solver -> simplifier -> Bindings -> ExecRes AbstractedInfo -> m (ExecRes AbstractedInfo) +runG2SolvingInference solver simplifier bindings (ExecRes { final_state = s }) = do + let abs_resemble_real = softAbstractResembleReal s + pc_with_soft = PC.union abs_resemble_real (path_conds s) + s_with_soft_pc = s { path_conds = pc_with_soft } + er_solving <- liftIO $ runG2SolvingResult solver simplifier bindings s_with_soft_pc + case er_solving of + SAT er_solving' -> do + let er_solving'' = if fmap funcName (violated er_solving') == Just initiallyCalledFuncName + then er_solving' { violated = Nothing } + else er_solving' + return er_solving'' + UNSAT _ -> error "runG2SolvingInference: solving failed" + Unknown _ _ -> do + er_solving_no_min <- liftIO $ runG2SolvingResult solver simplifier bindings s + case er_solving_no_min of + SAT er_solving_no_min' -> do + let er_solving_no_min'' = if fmap funcName (violated er_solving_no_min') == Just initiallyCalledFuncName + then er_solving_no_min' { violated = Nothing } + else er_solving_no_min' + return er_solving_no_min'' + _ -> error "runG2SolvingInference: solving failed with no minimization" + +earlyExecRes :: Bindings -> State t -> ExecRes t +earlyExecRes b s@(State { expr_env = eenv, curr_expr = CurrExpr _ cexpr, sym_gens = gens }) = + let + viol = assert_ids s + viol' = if fmap funcName viol == Just initiallyCalledFuncName + then Nothing + else viol + in + ExecRes { final_state = s + , conc_args = fixed_inputs b ++ mapMaybe getArg (input_names b) + , conc_out = cexpr + , conc_sym_gens = fmap fromJust . S.filter isJust $ fmap getArg gens + , violated = viol' } + where + getArg n = case E.lookup n eenv of + Just e@(Lam _ _ _) -> Just . Var $ Id n (typeOf e) + Just e -> Just e + Nothing -> Nothing + +satState :: ( MonadIO m + , Named t + , ASTContainer t Expr + , ASTContainer t Type + , Solver solver) => + solver + -> State t + -> m Bool +satState solver s + | true_assert s = do + r <- liftIO $ check solver s (path_conds s) + + case r of + SAT _ -> return True + UNSAT _ -> return False + Unknown _ _ -> return False + | otherwise = return False + +-- | Generate soft path constraints that encourage the `abstract` function call arguments +-- to be the same as the `real` function call arguments. +softAbstractResembleReal :: State AbstractedInfo -> PathConds +softAbstractResembleReal = + foldr PC.union PC.empty . map softAbstractResembleReal' . abs_calls . track + +softAbstractResembleReal' :: Abstracted -> PathConds +softAbstractResembleReal' abstracted = + let + ars_pairs = zip (arguments $ abstract abstracted) (arguments $ real abstracted) + ret_pair = (returns $ abstract abstracted, returns $ real abstracted) + in + foldr PC.union PC.empty . map PC.fromList $ map (uncurry softPair) (ret_pair:ars_pairs) + +softPair :: Expr -> Expr -> [PathCond] +softPair v1@(Var (Id _ t1)) e2 | isPrimType t1 = + assert (t1 == typeOf e2) + [MinimizePC $ App (Prim Abs TyUnknown) (App (App (Prim Minus TyUnknown) v1) e2)] +softPair e1 v2@(Var (Id _ t2)) | isPrimType t2 = + assert (typeOf e1 == t2) + [MinimizePC $ App (Prim Abs TyUnknown) (App (App (Prim Minus TyUnknown) e1) v2)] +softPair (App e1 e2) (App e1' e2') = softPair e1 e1' ++ softPair e2 e2' +softPair _ _ = [] + +------------------------------------- +-- Generating Allowed Inputs/Outputs +------------------------------------- + +-- By symbolically executing from user-specified functions, and gathering +-- all called functions, we can get functions calls that MUST be allowed by +-- the specifications + +gatherAllowedCalls :: T.Text + -> Maybe T.Text + -> LiquidReadyState + -> [GhcInfo] + -> InferenceConfig + -> Config + -> LHConfig + -> IO [FuncCall] +gatherAllowedCalls entry m lrs ghci infconfig config lhconfig = do + let config' = config -- { only_top = False } + + LiquidData { ls_state = s + , ls_bindings = bindings + , ls_memconfig = pres_names } <- + processLiquidReadyStateWithCall lrs ghci entry m config' lhconfig mempty + + let (s', bindings') = (s, bindings) -- execStateM addTrueAssertsAll s bindings + + SomeSolver solver <- initSolver config' + let simplifier = IdSimplifier + s'' = repCFBranch $ + s' { true_assert = True + , track = [] :: [FuncCall] } + + (red, hal, ord) <- gatherReducerHalterOrderer infconfig config' lhconfig solver simplifier + (exec_res, bindings'') <- SM.evalStateT (runG2WithSomes red hal ord solver simplifier pres_names s'' bindings') (mkPrettyGuide ()) + + putStrLn $ "length exec_res = " ++ show (length exec_res) + + let called = concatMap (\er -> + let fs = final_state er in + map (fs,) $ track fs) exec_res + + fc_red = SomeReducer (stdRed (sharing config') retReplaceSymbFuncVar solver simplifier) + + (_, red_calls) <- mapAccumM + (\b (fs, fc) -> do + (_, b', rfc) <- reduceFuncCall runG2WithSomes + fc_red + solver + simplifier + fs b fc + return (b', rfc)) + bindings'' + called + + close solver + + return red_calls + +repCFBranch :: ASTContainer t Expr => t -> t +repCFBranch = modifyASTs repCFBranch' + +repCFBranch' :: Expr -> Expr +repCFBranch' nd@(NonDet (e:_)) + | Let b (Assert fc ae1 ae2) <- e = Let b $ Assume fc ae1 ae2 + | otherwise = nd +repCFBranch' (Let b (Assert fc ae1 ae2)) = Let b $ Assume fc ae1 ae2 +repCFBranch' e = e + +gatherReducerHalterOrderer :: (MonadIO m, Solver solver, Simplifier simplifier) + => InferenceConfig + -> Config + -> LHConfig + -> solver + -> simplifier + -> IO ( SomeReducer (SM.StateT PrettyGuide m) [FuncCall] + , SomeHalter (SM.StateT PrettyGuide m) [FuncCall] + , SomeOrderer (SM.StateT PrettyGuide m) [FuncCall]) +gatherReducerHalterOrderer infconfig config lhconfig solver simplifier = do + let + share = sharing config + + state_name = Name "state" Nothing 0 Nothing + + m_logger = fmap SomeReducer $ getLogger config + + timer_halter <- stdTimerHalter (timeout_se infconfig * 3) + + let red = case m_logger of + Just logger -> logger .~> SomeReducer (gathererReducer ~> stdRed share retReplaceSymbFuncVar solver simplifier) + Nothing -> SomeReducer (gathererReducer ~> stdRed share retReplaceSymbFuncVar solver simplifier) + + return + (red .== Finished .--> (taggerRed state_name :== Finished --> nonRedPCRed) + , SomeHalter + (discardIfAcceptedTagHalter state_name + <~> switchEveryNHalter (switch_after lhconfig) + <~> swhnfHalter + <~> timer_halter) + , SomeOrderer (incrAfterN 2000 (adtSizeOrderer 0 Nothing))) + +------------------------------- +-- Direct Counterexamples Calls +------------------------------- +-- This does all the work to take LH source code and run symbolic execution on the named function. +-- In the inference algorithm itself, we don't want to use this, since if we did we would be +-- needlessly repeatedly reading and compiling the code. But it's to have an "end-to-end" +-- function to just running the symbolic execution, for debugging. + +{-# SPECIALISE + runLHInferenceAll :: InferenceConfig + -> Config + -> LHConfig + -> T.Text + -> [FilePath] + -> [FilePath] + -> IO (([ExecRes AbstractedInfo], Bindings), Id) + #-} +runLHInferenceAll :: MonadIO m + => InferenceConfig + -> Config + -> LHConfig + -> T.Text + -> [FilePath] + -> [FilePath] + -> m (([ExecRes AbstractedInfo], Bindings), Id) +runLHInferenceAll infconfig config g2lhconfig func proj fp = do + -- Initialize LiquidHaskell + (ghci, lhconfig) <- liftIO $ getGHCI infconfig proj fp + + let g2config = config { mode = Liquid + , steps = 2000 } + transConfig = simplTranslationConfig { simpl = False } + (main_mod, exg2) <- liftIO $ translateLoaded proj fp transConfig g2config + + let (lrs, g2config', g2lhconfig', infconfig') = initStateAndConfig exg2 main_mod g2config g2lhconfig infconfig ghci + + let configs = Configs { g2_config = g2config', g2lh_config = g2lhconfig', lh_config = lhconfig, inf_config = infconfig'} + + execInfStack configs newProgress (runLHInferenceCore func main_mod lrs ghci) + +------------------------------- +-- Generating Counterexamples +------------------------------- +runLHInferenceCore :: MonadIO m + => T.Text + -> Maybe T.Text + -> LiquidReadyState + -> [GhcInfo] + -> InfStack m (([ExecRes AbstractedInfo], Bindings), Id) +runLHInferenceCore entry m lrs ghci = do + MaxSize max_coeff_sz <- maxSynthCoeffSizeI + + g2config <- g2ConfigM + lhconfig <- g2lhConfigM + infconfig <- infConfigM + + LiquidData { ls_state = final_st + , ls_bindings = bindings + , ls_id = ifi + , ls_counterfactual_name = cfn + , ls_memconfig = pres_names } <- liftIO $ processLiquidReadyStateWithCall lrs ghci entry m g2config lhconfig mempty + SomeSolver solver <- liftIO $ initSolver g2config + -- let solver' = SpreadOutSolver max_coeff_sz solver + let simplifier = IdSimplifier + final_st' = swapHigherOrdForSymGen bindings final_st + + (red, hal, ord) <- inferenceReducerHalterOrderer infconfig g2config lhconfig solver simplifier entry m cfn final_st' + -- liftIO is important so that we specialize runLHG2Inference + (exec_res, final_bindings) <- liftIO $ SM.evalStateT (runLHG2Inference g2config red hal ord solver simplifier pres_names ifi final_st' bindings) (mkPrettyGuide ()) + + liftIO $ close solver + + return ((exec_res, final_bindings), ifi) + +inferenceReducerHalterOrderer :: (MonadIO m, MonadIO m_run, Solver solver, Simplifier simplifier) + => InferenceConfig + -> Config + -> LHConfig + -> solver + -> simplifier + -> T.Text + -> Maybe T.Text + -> Name + -> State LHTracker + -> InfStack m ( SomeReducer (SM.StateT PrettyGuide m_run) LHTracker + , SomeHalter (SM.StateT PrettyGuide m_run) LHTracker + , SomeOrderer (SM.StateT PrettyGuide m_run) LHTracker) +inferenceReducerHalterOrderer infconfig config lhconfig solver simplifier entry mb_modname cfn st = do + extra_ce <- extraMaxCExI (entry, mb_modname) + extra_time <- extraMaxTimeI (entry, mb_modname) + + -- time <- liftIO $ getCurrentTime + let + share = sharing config + + state_name = Name "state" Nothing 0 Nothing + abs_ret_name = Name "abs_ret" Nothing 0 Nothing + + ce_num = max_ce infconfig + extra_ce + lh_max_outputs = lhMaxOutputsHalter ce_num + + timeout = timeout_se infconfig + extra_time + + m_logger = fmap SomeReducer $ getLogger config + -- m_logger = if entry == "mapReduce" then Just (SomeReducer $ PrettyLogger ("a_mapReduce" ++ show time) (mkPrettyGuide ())) else getLogger config + + liftIO $ putStrLn $ "ce num for " ++ T.unpack entry ++ " is " ++ show ce_num + liftIO $ putStrLn $ "timeout for " ++ T.unpack entry ++ " is " ++ show timeout + + timer_halter <- liftIO $ stdTimerHalter (timeout * 2) + lh_timer_halter <- liftIO $ lhStdTimerHalter timeout + + let halter = lhAbsHalter entry mb_modname (expr_env st) + <~> lh_max_outputs + <~> switchEveryNHalter (switch_after lhconfig) + <~> lhSWHNFHalter + <~> timer_halter + <~> lh_timer_halter + let some_red = existentialInstRed :== NoProgress .--> + lhRed cfn :== Finished .--> + redArbErrors :== Finished .--> + SomeReducer (allCallsRed ~> + higherOrderCallsRed ~> + stdRed share retReplaceSymbFuncVar solver simplifier) + + return $ + ( + (case m_logger of + Just logger -> logger .~> some_red + Nothing -> some_red) .== Finished .--> + (taggerRed state_name :== Finished --> nonRedPCRed) .== Finished .--> + (taggerRed abs_ret_name :== Finished --> nonRedAbstractReturnsRed) + , SomeHalter + (discardIfAcceptedTagHalter state_name <~> halter) + , SomeOrderer (incrAfterN 2000 (quotTrueAssert (ordComb (+) (pcSizeOrderer 0) (adtSizeOrderer 0 (Just instFuncTickName)))))) + +runLHCExSearch :: MonadIO m + => T.Text + -> Maybe T.Text + -> LiquidReadyState + -> [GhcInfo] + -> InfStack m (([ExecRes AbstractedInfo], Bindings), Id) +runLHCExSearch entry m lrs ghci = do + g2config <- g2ConfigM + lhconfig <- g2lhConfigM + infconfig <- infConfigM + + let lhconfig' = lhconfig { counterfactual = NotCounterfactual + , only_top = False} + + LiquidData { ls_state = final_st + , ls_bindings = bindings + , ls_id = ifi + , ls_counterfactual_name = cfn + , ls_memconfig = pres_names } <- liftIO $ processLiquidReadyStateWithCall lrs ghci entry m g2config lhconfig' mempty + SomeSolver solver <- liftIO $ initSolver g2config + let simplifier = IdSimplifier + final_st' = swapHigherOrdForSymGen bindings final_st + + (red, hal, ord) <- realCExReducerHalterOrderer infconfig g2config lhconfig' entry m solver simplifier cfn + -- liftIO is important so that we specialize runLHG2Inference + (exec_res, final_bindings) <- liftIO $ SM.evalStateT (runLHG2Inference g2config red hal ord solver simplifier pres_names ifi final_st' bindings) (mkPrettyGuide ()) + + liftIO $ close solver + + return ((exec_res, final_bindings), ifi) + +realCExReducerHalterOrderer :: (MonadIO m, MonadIO m_run, Solver solver, Simplifier simplifier) + => InferenceConfig + -> Config + -> LHConfig + -> T.Text + -> Maybe T.Text + -> solver + -> simplifier + -> Name + -> InfStack m ( SomeReducer (SM.StateT PrettyGuide m_run) LHTracker + , SomeHalter (SM.StateT PrettyGuide m_run) LHTracker + , SomeOrderer (SM.StateT PrettyGuide m_run) LHTracker) +realCExReducerHalterOrderer infconfig config lhconfig entry modname solver simplifier cfn = do + extra_ce <- extraMaxCExI (entry, modname) + extra_depth <- extraMaxDepthI + + liftIO . putStrLn $ "extra_depth = " ++ show extra_depth + + let + share = sharing config + + state_name = Name "state" Nothing 0 Nothing + abs_ret_name = Name "abs_ret" Nothing 0 Nothing + + ce_num = max_ce infconfig + extra_ce + lh_max_outputs = lhMaxOutputsHalter ce_num + + m_logger = fmap SomeReducer $ getLogger config + + timer_halter <- liftIO $ stdTimerHalter (timeout_se infconfig) + + let halter = lh_max_outputs + <~> switchEveryNHalter (switch_after lhconfig) + <~> zeroHalter (0 + extra_depth) + <~> lhAcceptIfViolatedHalter + <~> timer_halter + + lh_std_red = lhRed cfn :== Finished --> stdRed share retReplaceSymbFuncVar solver simplifier + log_opt_red = case m_logger of + Just logger -> logger .~> lh_std_red + Nothing -> lh_std_red + + return $ + (log_opt_red .== Finished .--> + (taggerRed state_name :== Finished --> nonRedPCRed) .== Finished .--> + (taggerRed abs_ret_name :== Finished --> nonRedAbstractReturnsRed) + , SomeHalter + (discardIfAcceptedTagHalter state_name <~> halter) + , SomeOrderer (incrAfterN 1000 (adtSizeOrderer 0 Nothing))) + + +swapHigherOrdForSymGen :: Bindings -> State t -> State t +swapHigherOrdForSymGen b s@(State { expr_env = eenv }) = + let + is = filter (isTyFun . typeOf) $ inputIds s b + + eenv' = foldr swapForSG eenv is + in + s { expr_env = eenv' } + +swapForSG :: Id -> ExprEnv -> ExprEnv +swapForSG i eenv = + let + as = map (\at -> case at of + NamedType i' -> (TypeL, i') + AnonType t -> (TermL, Id (Name "x" Nothing 0 Nothing) t)) + $ spArgumentTypes i + r = returnType i + + sg_i = Id (Name "sym_gen" Nothing 0 Nothing) r + in + E.insert (idName i) (Let [(sg_i, SymGen SNoLog r)] $ mkLams as (Var sg_i)) eenv + +------------------------------- +-- Checking Counterexamples +------------------------------- + +-- Does a given FuncCall (counterexample) violate a specification? +-- This allows us to check if a found counterexample violates a user-provided specifications, +-- or a synthesized specification. +-- Returns True if the original Assertions are True (i.e. not violated) +checkFuncCall :: LiquidReadyState -> [GhcInfo] -> Config -> LHConfig -> FuncCall -> IO Bool +checkFuncCall = checkCounterexample + +checkCounterexample :: LiquidReadyState -> [GhcInfo] -> Config -> LHConfig -> FuncCall -> IO Bool +checkCounterexample lrs ghci config lhconfig cex@(FuncCall { funcName = Name n m _ _ }) = do + let lhconfig' = lhconfig { counterfactual = NotCounterfactual } + -- We use the same function to instantiate this state as in runLHInferenceCore, so all the names line up + LiquidData { ls_state = s + , ls_bindings = bindings } <- processLiquidReadyStateWithCall lrs ghci n m config lhconfig' mempty + + let s' = checkCounterexample' cex s + + SomeSolver solver <- initSolver config + (fsl, _) <- genericG2Call config solver s' bindings + close solver + + -- We may return multiple states if any of the specifications contained a SymGen + return $ any (currExprIsTrue . final_state) fsl + +checkCounterexample' :: FuncCall -> State t -> State t +checkCounterexample' fc@(FuncCall { funcName = n }) s@(State { expr_env = eenv, known_values = kv }) + | Just e <- E.lookup n eenv = + let + e' = toJustSpec kv fc (leadingLamIds e) (inLams e) + in + s { curr_expr = CurrExpr Evaluate e' + , true_assert = True } + | otherwise = error $ "checkCounterexample': Name not found " ++ show n + +toJustSpec :: KnownValues -> FuncCall -> [Id] -> Expr -> Expr +toJustSpec _ (FuncCall { arguments = ars, returns = ret }) is (Let [(b, _)] (Assert _ e _)) = + let + rep = (Var b, ret):zip (map Var is) ars + in + foldr (uncurry replaceASTs) e rep +toJustSpec kv _ _ e = assert (not $ hasAssert e) mkTrue kv + +hasAssert :: Expr -> Bool +hasAssert = getAny . evalASTs hasAssert' + +hasAssert' :: Expr -> Any +hasAssert' (Assert _ _ _) = Any True +hasAssert' _ = Any False + + +currExprIsTrue :: State t -> Bool +currExprIsTrue (State { curr_expr = CurrExpr _ (Data (DataCon (Name dcn _ _ _) _))}) = dcn == "True" +currExprIsTrue _ = False + +------------------------------- +-- Checking Pre and Post Conditions +------------------------------- +type PreEvals b = FCEvals b +type PostEvals b = FCEvals b +type FCEvals b = HM.HashMap Name (HM.HashMap FuncCall b) + +data Evals b = Evals { pre_evals :: PreEvals b + , post_evals :: PostEvals b } + deriving Show + +emptyEvals :: Evals b +emptyEvals = Evals { pre_evals = HM.empty, post_evals = HM.empty } + +preEvals :: (InfConfigM m, MonadIO m) => Evals Bool -> LiquidReadyState -> [GhcInfo] -> [(FuncCall, [HigherOrderFuncCall])] -> m (Evals Bool) +preEvals evals@(Evals { pre_evals = pre }) lrs ghci fcs = do + (pre', _) <- foldM (uncurry (runEvals checkPre' ghci lrs)) (pre, HM.empty) fcs + return $ evals { pre_evals = pre' } + -- return . HM.fromList =<< mapM (\fc -> return . (fc,) =<< checkPre lrs ghci fc) fcs + +postEvals :: (InfConfigM m, MonadIO m) => Evals Bool -> LiquidReadyState -> [GhcInfo] -> [(FuncCall, [HigherOrderFuncCall])] -> m (Evals Bool) +postEvals evals@(Evals { post_evals = post }) lrs ghci fcs = do + (post', _) <- foldM (uncurry (runEvals checkPost' ghci lrs)) (post, HM.empty) fcs + return $ evals { post_evals = post' } + +runEvals :: (InfConfigM m, MonadIO m) => + (LiquidData -> FuncCall -> [HigherOrderFuncCall] -> m Bool) + -> [GhcInfo] + -> LiquidReadyState + -> FCEvals Bool + -> HM.HashMap (T.Text, Maybe T.Text) LiquidData + -> (FuncCall, [HigherOrderFuncCall]) + -> m (FCEvals Bool, HM.HashMap (T.Text, Maybe T.Text) LiquidData) +runEvals f ghci lrs hm ld_m (fc, hfc) = + let + n = zeroOutName $ funcName fc + n_hm = maybe HM.empty id (HM.lookup n hm) + in + if fc `HM.member` n_hm + then return (hm, ld_m) + else do + let nt = nameTuple (funcName fc) + (ld, ld_m') <- case HM.lookup nt ld_m of + Just ld' -> return (ld', ld_m) + Nothing -> do + ld' <- checkPreOrPostLD ghci lrs fc + return (ld', HM.insert nt ld' ld_m) + pr <- f ld fc hfc + return $ (HM.insert n (HM.insert fc pr n_hm) hm, ld_m') + +checkPre :: (InfConfigM m, MonadIO m) => [GhcInfo] -> LiquidReadyState -> FuncCall -> [HigherOrderFuncCall] -> m Bool +checkPre ghci lrs fc hfc = do + ld <- checkPreOrPostLD ghci lrs fc + checkPre' ld fc hfc + +checkPre' :: (InfConfigM m, MonadIO m) => LiquidData -> FuncCall -> [HigherOrderFuncCall] -> m Bool +checkPre' ld fc@(FuncCall { funcName = n }) hfc = do + r <- checkPreOrPost' (M.map thd3 . zeroOutKeys . ls_assumptions) arguments ld fc + case r of + False -> return False + True -> do + let assumpts = M.lookup (zeroOutName n) . zeroOutKeys . ls_assumptions $ ld + case assumpts of + Just (_, higher_assumpts, _) -> do + rs <- allM (checkPreHigherOrder ld (catMaybes higher_assumpts)) $ filter (\h -> nameOcc (funcName h) == nameOcc n) hfc + return rs + Nothing -> return True + +checkPreHigherOrder :: (InfConfigM m, MonadIO m) => LiquidData -> [Expr] -> HigherOrderFuncCall -> m Bool +checkPreHigherOrder ld es (FuncCall {funcName = (Name _ _ i _), arguments = as, returns = r }) = do + config <- g2ConfigM + SomeSolver solver <- liftIO $ initSolver config + let e = es !! (i - 1) + e' = insertInLams (\_ in_e -> + case in_e of + Let [(b, _)] le -> Let [(b, r)] le + _ -> error "checkPreHigherOrder: unexpected expresssion form") e + s' = (ls_state ld) { curr_expr = CurrExpr Evaluate . modifyASTs repAssumeWithAssumption . mkApp $ e':as + , true_assert = True } + bindings = ls_bindings ld + (fsl, _) <- liftIO $ genericG2Call config solver s' bindings + liftIO $ close solver + + -- We may return multiple states if any of the specifications contained a SymGen + return $ any (currExprIsTrue . final_state) fsl + where + repAssumeWithAssumption (Assume _ e _) = e + repAssumeWithAssumption e = e + +checkPost :: (InfConfigM m, MonadIO m) => [GhcInfo] -> LiquidReadyState -> FuncCall -> [HigherOrderFuncCall] -> m Bool +checkPost ghci lrs fc hfc = do + ld <- checkPreOrPostLD ghci lrs fc + checkPost' ld fc hfc + +checkPost' :: (InfConfigM m, MonadIO m) => LiquidData -> FuncCall -> [HigherOrderFuncCall] -> m Bool +checkPost' ld fc _ = checkPreOrPost' (zeroOutKeys . ls_posts) (\fc_ -> arguments fc_ ++ [returns fc_]) ld fc + +zeroOutKeys :: M.Map Name v -> M.Map Name v +zeroOutKeys = M.mapKeys zeroOutName + +zeroOutName :: Name -> Name +zeroOutName (Name n m _ l) = Name n m 0 l + +checkPreOrPostLD :: (InfConfigM m, MonadIO m) + => [GhcInfo] -> LiquidReadyState -> FuncCall -> m LiquidData +checkPreOrPostLD lrs ghci (FuncCall { funcName = Name n m _ _ }) = do + config <- g2ConfigM + lhconfig <- g2lhConfigM + let lhconfig' = lhconfig { counterfactual = NotCounterfactual } + -- We use the same function to instantiate this state as in runLHInferenceCore, so all the names line up + liftIO $ processLiquidReadyStateWithCall ghci lrs n m config lhconfig' mempty + +checkPreOrPost' :: (InfConfigM m, MonadIO m) + => (LiquidData -> M.Map Name Expr) -> (FuncCall -> [Expr]) -> LiquidData -> FuncCall -> m Bool +checkPreOrPost' extract ars ld@(LiquidData { ls_state = s, ls_bindings = bindings }) cex = do + config <- g2ConfigM + + -- We use the same function to instantiate this state as in runLHInferenceCore, so all the names line up + case checkFromMap ars (extract ld) cex s of + Just s' -> do + SomeSolver solver <- liftIO $ initSolver config + (fsl, _) <- liftIO $ genericG2Call config solver s' bindings + liftIO $ close solver + + -- We may return multiple states if any of the specifications contained a SymGen + return $ any (currExprIsTrue . final_state) fsl + -- If there is no explicit specification, the specification is implicitly True + Nothing -> return True + +checkFromMap :: (FuncCall -> [Expr]) -> M.Map Name Expr -> FuncCall -> State t -> Maybe (State t) +checkFromMap ars specs fc@(FuncCall { funcName = n }) s = + let + e = M.lookup (zeroOutName n) specs + in + case e of + Just e' -> + let + e'' = mkApp $ e':ars fc + in + Just $ s { curr_expr = CurrExpr Evaluate e'' + , true_assert = True } + Nothing -> Nothing + +lookupEvals :: FuncCall -> FCEvals a -> Maybe a +lookupEvals fc@(FuncCall { funcName = n }) fce = + HM.lookup fc =<< HM.lookup (zeroOutName n) fce + +mapEvals :: (a -> b) -> Evals a -> Evals b +mapEvals f (Evals { pre_evals = pre, post_evals = post }) = + Evals { pre_evals = HM.map (HM.map f) pre, post_evals = HM.map (HM.map f) post } + +mapAccumLEvals :: (a -> b -> (a, c)) -> a -> Evals b -> (a, Evals c) +mapAccumLEvals f inital ev = + let + (inital', pre') = mapAccumL (mapAccumL f) inital (pre_evals ev) + (inital'', post') = mapAccumL (mapAccumL f) inital' (post_evals ev) + in + (inital'', ev { pre_evals = pre', post_evals = post' }) + +deleteEvalsForFunc :: Name -> Evals a -> Evals a +deleteEvalsForFunc n (Evals { pre_evals = pre_ev, post_evals = post_ev }) = + Evals { pre_evals = HM.delete (zeroOutName n) pre_ev + , post_evals = HM.delete (zeroOutName n) post_ev } + +printEvals :: (a -> T.Text) -> Evals a -> T.Text +printEvals f (Evals { pre_evals = pre, post_evals = post }) = + "Evals {\npre_evals = " <> printEvals' f pre <> "\npost_evals = " <> printEvals' f post <> "\n}" + +printEvals' :: (a -> T.Text) -> FCEvals a -> T.Text +printEvals' f = + T.intercalate "\n" + . map (\(fc, v) -> printFuncCall fc <> " -> " <> f v) + . HM.toList + . HM.unions + . HM.elems + +------------------------------- +-- Eval Measures +------------------------------- +-- Evaluate all relevant measures on a given expression + +type MeasureExs = HM.HashMap Expr (HM.HashMap [Name] Expr) + +type MaxMeasures = Int + +evalMeasures :: (InfConfigM m, ProgresserM m, MonadIO m) => MeasureExs -> LiquidReadyState -> [GhcInfo] -> [Expr] -> m MeasureExs +evalMeasures init_meas lrs ghci es = do + config <- g2ConfigM + + let memc = emptyMemConfig { pres_func = presMeasureNames } + LiquidData { ls_state = s + , ls_bindings = bindings + , ls_measures = meas + , ls_tcv = tcv + , ls_memconfig = pres_names } <- liftIO $ extractWithoutSpecs lrs (Id (Name "" Nothing 0 Nothing) TyUnknown) ghci memc + + let s' = s { true_assert = True } + (final_s, final_b) = markAndSweepPreserving pres_names s' bindings + + tot_meas = E.filter (isTotal (type_env s)) meas + + SomeSolver solver <- liftIO $ initSolver config + meas_res <- foldM (evalMeasures' (final_s {type_env = type_env s}) final_b solver config tot_meas tcv) init_meas $ filter (not . isError) es + liftIO $ close solver + return meas_res + where + meas_names = measureNames ghci + meas_nameOcc = map (\(Name n md _ _) -> (n, md)) $ map symbolName meas_names + + presMeasureNames s _ hs = + let + eenv = E.filterWithKey (\(Name n md _ _) _ -> (n, md) `elem` meas_nameOcc) (expr_env s) + eenv_meas_names = E.keys eenv + in + foldr HS.insert hs eenv_meas_names + + isError (Prim Error _) = True + isError _ = False + +isTotal :: TypeEnv -> Expr -> Bool +isTotal tenv = getAll . evalASTs isTotal' + where + isTotal' (Case i _ _ as) + | TyCon n _:_ <- unTyApp (typeOf i) + , Just adt <- HM.lookup n tenv = + All (length (dataCon adt) == length (filter isDataAlt as)) + isTotal' (Case _ _ _ _) = All False + isTotal' _ = All True + + isDataAlt (G2.Alt (DataAlt _ _) _) = True + isDataAlt _ = False + + +evalMeasures' :: ( InfConfigM m + , MonadIO m + , ProgresserM m + , ASTContainer t Expr + , ASTContainer t Type + , Named t + , Solver solver + , Show t) => State t -> Bindings -> solver -> Config -> Measures -> TCValues -> MeasureExs -> Expr -> m MeasureExs +evalMeasures' s bindings solver config meas tcv init_meas e = do + MaxSize max_meas <- maxSynthFormSizeM + let m_sts = evalMeasures'' (fromInteger max_meas) s bindings meas tcv e + + foldM (\meas_exs (ns, e_in, s_meas) -> do + case HM.lookup ns =<< HM.lookup e_in meas_exs of + Just _ -> return meas_exs + Nothing -> do + (er, _) <- liftIO $ genericG2Call config solver s_meas bindings + case er of + [er'] -> + let + e_out = conc_out er' + in + return $ HM.insertWith HM.union e_in (HM.singleton ns e_out) meas_exs + [] -> return $ HM.insertWith HM.union e_in (HM.singleton ns (Prim Undefined TyBottom)) meas_exs + _ -> error "evalMeasures': Bad G2 Call") init_meas m_sts + +evalMeasures'' :: Int -> State t -> Bindings -> Measures -> TCValues -> Expr -> [([Name], Expr, State t)] +evalMeasures'' mx_meas s b m tcv e = + let + meas_comps = formMeasureComps mx_meas (type_env s) (typeOf e) m + + rel_m = mapMaybe (\ns_me -> + case chainReturnType (typeOf e) (map snd ns_me) of + Just (_, vms) -> Just (ns_me, vms) + Nothing -> Nothing) meas_comps + in + map (\(ns_es, bound) -> + let + is = map (\(n, me) -> Id n (typeOf me)) ns_es + str_call = evalMeasuresCE s b tcv is e bound + in + (map fst ns_es, e, s { curr_expr = CurrExpr Evaluate str_call }) + ) rel_m + +-- Form all possible measure compositions, up to the maximal length +formMeasureComps :: MaxMeasures -- ^ max length + -> TypeEnv + -> Type -- ^ Type of input value to the measures + -> Measures + -> [[(Name, Expr)]] +formMeasureComps !mx tenv in_t meas = + let + meas' = E.toExprList $ E.filter (isTotal tenv) meas + in + formMeasureComps' mx in_t (map (:[]) meas') meas' + +formMeasureComps' :: MaxMeasures -- ^ max length + -> Type -- ^ Type of input value to the measures + -> [[(Name, Expr)]] + -> [(Name, Expr)] + -> [[(Name, Expr)]] +formMeasureComps' !mx in_t existing ns_me + | mx <= 1 = existing + | otherwise = + let + r = [ ne1:ne2 | ne1@(_, e1) <- ns_me + , ne2 <- existing + , case (filter notLH $ anonArgumentTypes e1, fmap fst . chainReturnType in_t $ map snd ne2) of + ([at], Just t) -> PresType t .:: at + _ -> False ] + in + formMeasureComps' (mx - 1) in_t (r ++ existing) ns_me + +chainReturnType :: Type -> [Expr] -> Maybe (Type, [M.Map Name Type]) +chainReturnType t ne = + foldM (\(t', vms) et -> + case filter notLH . anonArgumentTypes $ PresType et of + [at] + | Just vm <- t' `specializes` at -> Just (applyTypeMap vm . returnType $ PresType et, vm:vms) + _ -> Nothing) (t, []) (map typeOf $ reverse ne) + +notLH :: Type -> Bool +notLH ty + | TyCon (Name n _ _ _) _ <- tyAppCenter ty = n /= "lh" + | otherwise = True + +evalMeasuresCE :: State t -> Bindings -> TCValues -> [Id] -> Expr -> [M.Map Name Type] -> Expr +evalMeasuresCE s bindings tcv is e bound = + let + meas_call = map (uncurry tyAppId) $ zip is bound + ds = deepseq_walkers bindings + + call = foldr App e meas_call + str_call = mkStrict_maybe ds call + lh_dicts_call = maybe call (fillLHDictArgs ds) str_call + in + lh_dicts_call + where + tyAppId i b = + let + bound_names = map idName $ tyForAllBindings i + bound_tys = map (\n -> case M.lookup n b of + Just t -> t + Nothing -> TyUnknown) bound_names + lh_dcts = map (\t -> case lookupTCDict (type_classes s) (lhTC tcv) t of + Just tc -> Var tc + Nothing -> Prim Undefined TyBottom) bound_tys -- map (const $ Prim Undefined TyBottom) bound_tys + in + mkApp $ Var i:map Type bound_tys ++ lh_dcts + +------------------------------- +-- Generic +------------------------------- +genericG2Call :: ( MonadIO m + , ASTContainer t Expr + , ASTContainer t Type + , Named t + , Solver solver) => Config -> solver -> State t -> Bindings -> m ([ExecRes t], Bindings) +genericG2Call config solver s bindings = do + let simplifier = IdSimplifier + share = sharing config + + fslb <- runG2WithSomes (SomeReducer (stdRed share retReplaceSymbFuncVar solver simplifier)) + (SomeHalter swhnfHalter) + (SomeOrderer nextOrderer) + solver simplifier PreserveAllMC s bindings + + return fslb + +genericG2CallLogging :: ( MonadIO m + , ASTContainer t Expr + , ASTContainer t Type + , Named t + , Show t + , Solver solver) => + Config + -> solver + -> State t + -> Bindings + -> String + -> (SM.StateT PrettyGuide m) ([ExecRes t], Bindings) +genericG2CallLogging config solver s bindings lg = do + let simplifier = IdSimplifier + share = sharing config + + fslb <- runG2WithSomes (SomeReducer (prettyLogger lg ~> stdRed share retReplaceSymbFuncVar solver simplifier)) + (SomeHalter swhnfHalter) + (SomeOrderer nextOrderer) + solver simplifier PreserveAllMC s bindings + + return fslb diff --git a/src/G2/Liquid/Inference/GeneratedSpecs.hs b/src/G2/Liquid/Inference/GeneratedSpecs.hs new file mode 100644 --- /dev/null +++ b/src/G2/Liquid/Inference/GeneratedSpecs.hs @@ -0,0 +1,322 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} + +module G2.Liquid.Inference.GeneratedSpecs ( GeneratedSpecs + , emptyGS + , namesGS + + , nullAssumeGS + + , unionDroppingGS + + , insertAssumeGS + , insertAssertGS + , insertNewSpec + , insertQualifier + , switchAssumesToAsserts + + , lookupAssertGS + + , filterAssertsKey + , filterOutSpecs + , filterOutAssertSpecs + + , addSpecsToGhcInfos + , addAssumedSpecsToGhcInfos + , addQualifiersToGhcInfos + + , deleteAssume + , deleteAssert + , deleteAllAssumes + , deleteAllAsserts + + , allExprs + + , genSpec + , insertMissingAssertSpec ) where + +import qualified G2.Language as G2 +import G2.Liquid.Helpers +import G2.Liquid.Types +import G2.Liquid.Inference.PolyRef + +import Language.Haskell.Liquid.Constraint.Init +import Language.Haskell.Liquid.Types hiding + (TargetInfo (..), TargetSrc (..), TargetSpec (..), GhcSpec (..), qualifiers) +import Language.Haskell.Liquid.Types.Fresh +import Language.Fixpoint.Types.Refinements +import Language.Haskell.Liquid.Types.RefType +import Language.Fixpoint.Types (Qualifier (..)) + +import qualified Control.Monad.State as S +import Data.List +import qualified Data.Text as T +import qualified Data.Map as M + +#if MIN_VERSION_GLASGOW_HASKELL(9,0,2,0) +import GHC.Types.Name (nameOccName, occNameString) +import GHC.Types.Var as V +#else +import Name (nameOccName, occNameString) +import Var as V +#endif + + +data GeneratedSpecs = GeneratedSpecs { assert_specs :: M.Map G2.Name [PolyBound Expr] + , assume_specs :: M.Map G2.Name [PolyBound Expr] + , qualifiers :: [Qualifier] } deriving (Eq, Show) + +emptyGS :: GeneratedSpecs +emptyGS = GeneratedSpecs M.empty M.empty [] + +nullAssumeGS :: GeneratedSpecs -> Bool +nullAssumeGS = M.null . assume_specs + +namesGS :: GeneratedSpecs -> [G2.Name] +namesGS = M.keys . assert_specs + +insertAssumeGS :: G2.Name -> [PolyBound Expr] -> GeneratedSpecs -> GeneratedSpecs +insertAssumeGS n e gs = + gs { assume_specs = M.insert (zeroOutUnq n) e (assume_specs gs) } + +insertAssertGS :: G2.Name -> [PolyBound Expr] -> GeneratedSpecs -> GeneratedSpecs +insertAssertGS n e gs = + gs { assert_specs = M.insert (zeroOutUnq n) e (assert_specs gs) } + +insertQualifier :: Qualifier -> GeneratedSpecs -> GeneratedSpecs +insertQualifier qual gs@(GeneratedSpecs { qualifiers = quals }) = + gs { qualifiers = qual:quals } + +insertNewSpec :: G2.Name -> [PolyBound Expr] -> GeneratedSpecs -> GeneratedSpecs +insertNewSpec n new_spec = + insertAssertGS n (pre new_spec) . insertAssumeGS n (post new_spec) + where + pre xs = init xs ++ [PolyBound PTrue []] + post xs = replicate (length $ init xs) (PolyBound PTrue []) ++ [last xs] + +switchAssumesToAsserts :: GeneratedSpecs -> GeneratedSpecs +switchAssumesToAsserts gs = + gs { assert_specs = + M.unionWith + (zipWith + (zipWithMaybePB (\s1 s2 -> PAnd [maybe PTrue id s1, maybe PTrue id s2])) + ) + (assert_specs gs) (assume_specs gs) + , assume_specs = M.empty } + +-- | Merges two GeneratedSpecs, favoring constraints in the first generated specs +unionDroppingGS :: GeneratedSpecs -> GeneratedSpecs -> GeneratedSpecs +unionDroppingGS gs1 gs2 = + GeneratedSpecs { assert_specs = M.union (assert_specs gs1) (assert_specs gs2) + , assume_specs = M.union (assume_specs gs1) (assume_specs gs2) + , qualifiers = qualifiers gs1 ++ qualifiers gs2} + +lookupAssertGS :: G2.Name -> GeneratedSpecs -> Maybe [PolyBound Expr] +lookupAssertGS n = M.lookup (zeroOutUnq n) . assert_specs + +filterOutSpecs :: [G2.Name] -> GeneratedSpecs -> GeneratedSpecs +filterOutSpecs ns gs = + let + ns' = map zeroOutUnq ns + fil = M.filterWithKey (\n _ -> n `notElem` ns') + in + gs { assert_specs = fil $ assert_specs gs + , assume_specs = fil $ assume_specs gs } + +filterOutAssertSpecs :: [G2.Name] -> GeneratedSpecs -> GeneratedSpecs +filterOutAssertSpecs ns gs = + let + ns' = map zeroOutUnq ns + fil = M.filterWithKey (\n _ -> n `notElem` ns') + in + gs { assert_specs = fil $ assert_specs gs } + + +filterAssertsKey :: (G2.Name -> Bool) -> GeneratedSpecs -> GeneratedSpecs +filterAssertsKey p gs = gs { assert_specs = M.filterWithKey (\n _ -> p n) $ assert_specs gs} + +deleteAssume :: G2.Name -> GeneratedSpecs -> GeneratedSpecs +deleteAssume n gs@(GeneratedSpecs { assume_specs = as }) = + gs { assume_specs = M.delete (zeroOutUnq n) as } + +deleteAssert :: G2.Name -> GeneratedSpecs -> GeneratedSpecs +deleteAssert n gs@(GeneratedSpecs { assert_specs = as }) = + gs { assert_specs = M.delete (zeroOutUnq n) as } + +deleteAllAssumes :: GeneratedSpecs -> GeneratedSpecs +deleteAllAssumes gs = gs { assume_specs = M.empty } + +deleteAllAsserts :: GeneratedSpecs -> GeneratedSpecs +deleteAllAsserts gs = gs { assert_specs = M.empty } + +modifyGsTySigs :: (Var -> SpecType -> SpecType) -> GhcInfo -> GhcInfo +modifyGsTySigs f ghci = + let + ty_sigs = getTySigs ghci + ty_sigs' = map (\(v, lst) -> (v, fmap (f v) lst)) ty_sigs + in + putTySigs ghci ty_sigs' + +modifyGsAsmSigs :: (Var -> SpecType -> SpecType) -> GhcInfo -> GhcInfo +modifyGsAsmSigs f ghci = + let + ty_sigs = getAssumedSigs ghci + ty_sigs' = map (\(v, lst) -> (v, fmap (f v) lst)) ty_sigs + in + putAssumedSigs ghci ty_sigs' + +addSpecsToGhcInfos :: [GhcInfo] -> GeneratedSpecs -> [GhcInfo] +addSpecsToGhcInfos ghci gs = addAssumedSpecsToGhcInfos (addAssertedSpecsToGhcInfos ghci gs) gs + +addAssertedSpecsToGhcInfos :: [GhcInfo] -> GeneratedSpecs -> [GhcInfo] +addAssertedSpecsToGhcInfos ghcis = foldr (uncurry addAssertedSpecToGhcInfos) ghcis + . filter (not . allEmptyPAnds . snd) + . M.toList + . assert_specs + +addAssertedSpecToGhcInfos :: G2.Name -> [PolyBound Expr] -> [GhcInfo] -> [GhcInfo] +addAssertedSpecToGhcInfos v e = map (addAssertedSpecToGhcInfo v e) . insertMissingAssertSpec v + +addAssertedSpecToGhcInfo :: G2.Name -> [PolyBound Expr] -> GhcInfo -> GhcInfo +addAssertedSpecToGhcInfo n e = + modifyGsTySigs (\v st -> if varEqName v n then addToSpecType e st else st) + +addAssumedSpecsToGhcInfos :: [GhcInfo] -> GeneratedSpecs -> [GhcInfo] +addAssumedSpecsToGhcInfos ghcis = foldr (uncurry addAssumedSpecToGhcInfos) ghcis . M.toList . assume_specs + +addAssumedSpecToGhcInfos :: G2.Name -> [PolyBound Expr] -> [GhcInfo] -> [GhcInfo] +addAssumedSpecToGhcInfos v e = map (addAssumedSpecToGhcInfo v e) . insertMissingAssumeSpec v + +addAssumedSpecToGhcInfo :: G2.Name -> [PolyBound Expr] -> GhcInfo -> GhcInfo +addAssumedSpecToGhcInfo n e = + modifyGsAsmSigs (\v st -> if varEqName v n then addToSpecType e st else st) + +addQualifiersToGhcInfos :: GeneratedSpecs -> [GhcInfo] -> [GhcInfo] +addQualifiersToGhcInfos gs = map (addQualifiersToGhcInfo gs) + +addQualifiersToGhcInfo :: GeneratedSpecs -> GhcInfo -> GhcInfo +addQualifiersToGhcInfo gs ghci = + let + old_quals = getQualifiers ghci + in + putQualifiers ghci (old_quals ++ qualifiers gs) + +addToSpecType :: [PolyBound Expr] -> SpecType -> SpecType +addToSpecType _ rvar@(RVar {}) = rvar +addToSpecType ees@(e@(PolyBound _ ps):es) rfun@(RFun { rt_in = i, rt_out = out }) + | isFunTy i = rfun { rt_in = addToSpecType ps i, rt_out = addToSpecType es out } + | not (isRVar i) = rfun { rt_in = addToSpecType [e] i, rt_out = addToSpecType es out } + | otherwise = rfun {rt_out = addToSpecType ees out } +addToSpecType es rall@(RAllT { rt_ty = out }) = + rall { rt_ty = addToSpecType es out } +addToSpecType [PolyBound e ps] + rapp@(RApp { rt_reft = u@(MkUReft { ur_reft = Reft (ur_s, ur_e) }), rt_args = ars }) = + let + rt_reft' = u { ur_reft = Reft (ur_s, PAnd [ur_e, e])} + ars' = map (uncurry addToSpecType) $ zipSpecTypes (map (:[]) ps) ars + in + rapp { rt_reft = rt_reft', rt_args = ars' } +addToSpecType [] st = st +addToSpecType _ st = error $ "addToSpecType: Unhandled SpecType " ++ show st + +zipSpecTypes :: [[PolyBound Expr]] -> [SpecType] -> [([PolyBound Expr], SpecType)] +zipSpecTypes [] [] = [] +zipSpecTypes (epb:epbs) (rfun@(RFun {}):sts) = + (epb, rfun):zipSpecTypes epbs sts +zipSpecTypes epbs (rvar@(RVar {}):sts) = + ([PolyBound PTrue []], rvar):zipSpecTypes epbs sts +zipSpecTypes (epb:epbs) (st@(RApp {}):sts) = (epb, st):zipSpecTypes epbs sts +zipSpecTypes [] (st:sts) = ([PolyBound PTrue []], st):zipSpecTypes [] sts +zipSpecTypes es st = error $ "zipSpecTypes: Unhandled case\n" ++ show es ++ "\n" ++ show st + +zeroOutUnq :: G2.Name -> G2.Name +zeroOutUnq (G2.Name n m _ l) = G2.Name n m 0 l + +allEmptyPAnds :: [PolyBound Expr] -> Bool +allEmptyPAnds = all (allPB (\e -> case e of + PAnd [] -> True + _ -> False)) + +-- | If the given variable does not have a specification, create it in the appropriate place +insertMissingAssumeSpec :: G2.Name -> [GhcInfo] -> [GhcInfo] +insertMissingAssumeSpec (G2.Name n _ _ _) = map create + where + create ghci = + let + def_vs = definedVars ghci + has_spec = map fst $ getAssumedSigs ghci + def_no_spec = filter (`notElem` has_spec) def_vs + + def_v = find (\v -> (T.pack . occNameString . nameOccName $ varName v) == n) def_no_spec + in + case def_v of + Just v -> + let + new_spec = dummyLoc $ genSpec' ghci v + in + insertAssumeSig v new_spec ghci + Nothing -> ghci + +insertAssumeSig :: Var -> LocSpecType -> GhcInfo -> GhcInfo +insertAssumeSig v lst ghci = + let + spc = getAssumedSigs ghci + in + putAssumedSigs ghci ((v, lst):spc) + +insertMissingAssertSpec :: G2.Name -> [GhcInfo] -> [GhcInfo] +insertMissingAssertSpec (G2.Name n _ _ _) = map create + where + create ghci = + let + def_vs = definedVars ghci + has_spec = map fst $ getTySigs ghci + def_no_spec = filter (`notElem` has_spec) def_vs + + def_v = find (\v -> (T.pack . occNameString . nameOccName $ varName v) == n) def_no_spec + in + case def_v of + Just v -> + let + new_spec = dummyLoc $ genSpec' ghci v + in + insertTySig v new_spec ghci + Nothing -> ghci + +insertTySig :: Var -> LocSpecType -> GhcInfo -> GhcInfo +insertTySig v lst ghci = + let + spc = getTySigs ghci + in + putTySigs ghci ((v, lst):spc) + +allExprs :: GeneratedSpecs -> [Expr] +allExprs gs = concatMap extractValues . concat $ M.elems (assume_specs gs) ++ M.elems (assert_specs gs) + +genSpec :: [GhcInfo] -> G2.Name -> Maybe SpecType +genSpec ghcis (G2.Name n _ _ _) = foldr mappend Nothing $ map gen ghcis + where + gen ghci = + let + def_vs = definedVars ghci + def_v = find (\v -> (T.pack . occNameString . nameOccName $ varName v) == n) def_vs + + specs = getTySigs ghci + in + case def_v of + Just v + | Just (_, s) <- find ((==) v . fst) specs -> Just (val s) + _ -> fmap (genSpec' ghci) def_v + +genSpec' :: GhcInfo -> Var -> SpecType +genSpec' ghci v = + S.evalState (refreshTy (ofType $ varType v)) $ initCGI (getConfig ghci) ghci + +definedVars :: GhcInfo -> [Var] +#if MIN_VERSION_liquidhaskell(0,8,6) +definedVars = giDefVars . giSrc +#else +definedVars = defVars +#endif + + diff --git a/src/G2/Liquid/Inference/InfStack.hs b/src/G2/Liquid/Inference/InfStack.hs new file mode 100644 --- /dev/null +++ b/src/G2/Liquid/Inference/InfStack.hs @@ -0,0 +1,167 @@ +{-# LANGUAGE LambdaCase #-} + +module G2.Liquid.Inference.InfStack ( InfStack + , runInfStack + , execInfStack + + , infLiftIO + + , incrMaxDepthI + , incrMaxCExI + , incrMaxTimeI + , incrMaxSynthSizeI + + , extraMaxDepthI + , extraMaxCExI + , extraMaxTimeI + , maxSynthCoeffSizeI + , setMaxSynthCoeffSizeI + + , logEventStartM + , logEventEndM + , getLogM + + , startLevelTimer + , endLevelTimer + + , withConfigs + + , Event (..) + , mapEvent + + , Counters (..) + , incrLoopCountLog + , incrBackTrackLog + , incrSearchBelowLog + , incrNegatedModelLog ) where + +import G2.Data.Timer +import G2.Language +import G2.Liquid.Inference.Config + +import Control.Monad.Reader +import Control.Monad.State.Lazy as S + +import qualified Data.HashSet as HS +import qualified Data.HashMap.Strict as HM +import qualified Data.Text as T +import Data.Time.Clock + +data Event n = CExSE + | InfSE n + | Verify + | Synth + | UpdateMeasures + | UpdateEvals + deriving (Eq, Read, Show) + +mapEvent :: (a -> b) -> Event a -> Event b +mapEvent _ CExSE = CExSE +mapEvent f (InfSE n) = InfSE (f n) +mapEvent _ Verify = Verify +mapEvent _ Synth = Synth +mapEvent _ UpdateMeasures = UpdateMeasures +mapEvent _ UpdateEvals = UpdateEvals + +data Counters = Counters { loop_count :: HM.HashMap (HS.HashSet Name) Int + , backtracks :: Int + , searched_below :: Int + , negated_models :: Int } + +type InfStack m = StateT (Timer (Event Name)) + (StateT (Timer (HS.HashSet Name)) + (StateT Counters (ReaderT Configs (StateT Progress m))) + ) + +runInfStack :: MonadIO m => Configs -> Progress -> InfStack m a + -> m (a, Timer (Event Name), Timer (HS.HashSet Name), Counters) +runInfStack configs prog m = do + ev_timer <- liftIO $ newTimer + lvl_timer <- liftIO $ newTimer + (((a, ev_tm), lvl_tm), loops) <- runProgresser + (runConfigs + (runStateT + (runTimer (runTimer m ev_timer) lvl_timer) + newCounter + ) configs + ) prog + return (a, ev_tm, lvl_tm, loops) + +execInfStack :: MonadIO m => Configs -> Progress -> InfStack m a -> m a +execInfStack configs prog s = return . (\(x, _, _, _) -> x) =<< runInfStack configs prog s + +infLiftIO :: MonadIO m => IO a -> InfStack m a +infLiftIO = lift . lift . lift . liftIO + +incrMaxDepthI :: Monad m => InfStack m () +incrMaxDepthI = lift . lift . lift $ incrMaxDepthM + +incrMaxCExI :: Monad m => (T.Text, Maybe T.Text) -> InfStack m () +incrMaxCExI = lift . lift . lift . incrMaxCExM + +incrMaxTimeI :: Monad m => (T.Text, Maybe T.Text) -> InfStack m () +incrMaxTimeI = lift . lift . lift . incrMaxTimeM + +extraMaxCExI :: Monad m => (T.Text, Maybe T.Text) -> InfStack m Int +extraMaxCExI n = lift . lift . lift $ gets (extraMaxCEx n) + +extraMaxDepthI :: Monad m => InfStack m Int +extraMaxDepthI = lift . lift . lift $ gets extraMaxDepth + +extraMaxTimeI :: Monad m => (T.Text, Maybe T.Text) -> InfStack m NominalDiffTime +extraMaxTimeI n = lift . lift . lift $ gets (extraMaxTime n) + +incrMaxSynthSizeI :: Monad m => InfStack m () +incrMaxSynthSizeI = do + lift . lift . lift $ incrMaxSynthFormSizeM + lift . lift . lift $ incrMaxSynthCoeffSizeM + +maxSynthCoeffSizeI :: Monad m => InfStack m MaxSize +maxSynthCoeffSizeI = lift . lift . lift $ maxSynthCoeffSizeM + +setMaxSynthCoeffSizeI :: Monad m => MaxSize -> InfStack m () +setMaxSynthCoeffSizeI max_size = do + lift . lift . lift $ setMaxSynthCoeffSizeM max_size + +startLevelTimer :: MonadIO m => [Name] -> InfStack m () +startLevelTimer = lift . logEventStartM . HS.fromList + +endLevelTimer :: MonadIO m => InfStack m () +endLevelTimer = lift $ logEventEndM + +-- Configurations + +withConfigs :: Monad m => + (Configs -> Configs) + -> InfStack m a + -> InfStack m a +withConfigs f m = do + mapStateT (mapStateT (mapStateT (withReaderT f))) m + +-- Counters +newCounter :: Counters +newCounter = Counters { loop_count = HM.empty, backtracks = 0, searched_below = 0, negated_models = 0 } + +incrLoopCountLog :: Monad m => [Name] -> InfStack m () +incrLoopCountLog ns = + let + hs_ns = HS.fromList ns + in + lift . lift $ S.modify (\c@(Counters { loop_count = lcs }) -> + c { loop_count = HM.alter (\case (Just i) -> Just (i + 1) + Nothing -> Just 0) hs_ns lcs + } + ) +incrBackTrackLog :: Monad m => InfStack m () +incrBackTrackLog = + lift . lift $ S.modify (\c@(Counters { backtracks = i }) -> c { backtracks = i + 1 }) + + +incrSearchBelowLog :: Monad m => InfStack m () +incrSearchBelowLog = + lift . lift $ S.modify (\c@(Counters { searched_below = i }) -> c { searched_below = i + 1 }) + +incrNegatedModelLog :: Monad m => InfStack m () +incrNegatedModelLog = + lift . lift $ S.modify (\c@(Counters { negated_models = i }) -> c { negated_models = i + 1 }) + diff --git a/src/G2/Liquid/Inference/Initalization.hs b/src/G2/Liquid/Inference/Initalization.hs new file mode 100644 --- /dev/null +++ b/src/G2/Liquid/Inference/Initalization.hs @@ -0,0 +1,63 @@ +module G2.Liquid.Inference.Initalization ( initStateAndConfig + , createStateForInference + , getGHCI ) where + +import G2.Config.Config as G2 +import qualified G2.Initialization.Types as IT +import G2.Interface hiding (violated) +import G2.Language +import qualified G2.Language.ExprEnv as E +import G2.Translation + +import G2.Liquid.AddTyVars +import G2.Liquid.Config +import G2.Liquid.Interface +import G2.Liquid.Types +import G2.Liquid.Inference.Config +import G2.Liquid.Inference.Verify + +import Language.Haskell.Liquid.Types as LH hiding (measures) +import qualified Language.Fixpoint.Types.Config as FP + +import qualified Data.Text as T + +initStateAndConfig :: ExtractedG2 -> Maybe T.Text -> G2.Config -> LHConfig -> InferenceConfig -> [GhcInfo] + -> (LiquidReadyState, G2.Config, LHConfig, InferenceConfig) +initStateAndConfig exg2 main_mod g2config lhconfig infconfig ghci = + let + simp_s = initSimpleState exg2 + (g2config', lhconfig', infconfig') = adjustConfig main_mod simp_s g2config lhconfig infconfig ghci + + lrs = createStateForInference simp_s main_mod g2config' lhconfig' ghci + + lh_s = lr_state lrs + lhconfig'' = adjustConfigPostLH main_mod (measures lh_s) (tcvalues lh_s) (state lh_s) ghci lhconfig' + in + (lrs, g2config', lhconfig'', infconfig') + +createStateForInference :: SimpleState -> Maybe T.Text -> G2.Config -> LHConfig -> [GhcInfo] -> LiquidReadyState +createStateForInference simp_s main_mod config lhconfig ghci = + let + (simp_s', ph_tyvars) = if add_tyvars lhconfig + then fmap Just $ addTyVarsEEnvTEnv simp_s + else (simp_s, Nothing) + (s, b) = initStateFromSimpleState simp_s' main_mod True + (\_ ng _ _ _ _ _ -> (Prim Undefined TyBottom, [], [], ng)) + (E.higherOrderExprs . IT.expr_env) + config + in + createLiquidReadyState s b ghci ph_tyvars lhconfig + +getGHCI :: InferenceConfig -> [FilePath] -> [FilePath] -> IO ([GhcInfo], LH.Config) +getGHCI infconfig proj fp = do + lhconfig <- defLHConfig proj + let lhconfig' = lhconfig { pruneUnsorted = True + -- Block qualifiers being auto-generated by LH + , maxParams = if keep_quals infconfig then maxParams lhconfig else 0 + , eliminate = if keep_quals infconfig then eliminate lhconfig else FP.All + , higherorderqs = False + , scrapeImports = False + , scrapeInternals = False + , scrapeUsedImports = False } + ghci <- ghcInfos Nothing lhconfig' fp + return (ghci, lhconfig) diff --git a/src/G2/Liquid/Inference/Interface.hs b/src/G2/Liquid/Inference/Interface.hs new file mode 100644 --- /dev/null +++ b/src/G2/Liquid/Inference/Interface.hs @@ -0,0 +1,777 @@ +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +module G2.Liquid.Inference.Interface ( inferenceCheck + , inference + , getInitState + , getNameLevels ) where + +import G2.Config.Config as G2 +import G2.Data.Timer +import G2.Interface hiding (violated) +import G2.Language.CallGraph +import G2.Language.Expr +import qualified G2.Language.ExprEnv as E +import G2.Language.Naming +import G2.Language.Support +import G2.Language.Syntax +import G2.Language.Typing +import G2.Liquid.Config +import G2.Liquid.ConvertCurrExpr +import G2.Liquid.Helpers +import G2.Liquid.Inference.Config +import G2.Liquid.Inference.FuncConstraint as FC +import G2.Liquid.Inference.G2Calls +import G2.Liquid.Inference.InfStack +import G2.Liquid.Inference.Initalization +import G2.Liquid.Inference.PolyRef +import G2.Liquid.Inference.Sygus +import G2.Liquid.Inference.UnionPoly +import G2.Liquid.Inference.GeneratedSpecs +import G2.Liquid.Inference.Verify +import G2.Liquid.Interface +import G2.Liquid.Types hiding (state) +import qualified G2.Liquid.Types as T +import qualified G2.Liquid.Types as G2LH +import G2.Solver +import G2.Translation + +import Language.Haskell.Liquid.Types as LH + +import Control.Monad.IO.Class +import Control.Monad.Reader +import Data.Either +import qualified Data.HashSet as S +import qualified Data.HashMap.Lazy as HM +import Data.List +import Data.Maybe +import qualified Data.Text as T +import qualified Data.Text.IO as T + +-- Run inference, with an extra, final check of correctness at the end. +-- Assuming inference is working correctly, this check should neve fail. +inferenceCheck :: InferenceConfig -> G2.Config -> LHConfig -> [FilePath] -> [FilePath] -> IO (State [FuncCall], Either [CounterExample] GeneratedSpecs) +inferenceCheck infconfig config g2lhconfig proj fp = do + (ghci, lhconfig) <- getGHCI infconfig proj fp + (s, res, _, loops) <- inference' infconfig config g2lhconfig lhconfig ghci proj fp + print $ loop_count loops + print . sum . HM.elems $ loop_count loops + print $ backtracks loops + print $ searched_below loops + print $ negated_models loops + case res of + Right gs -> do + check_res <- checkGSCorrect infconfig lhconfig ghci gs + case check_res of + Safe -> return (s, res) + _ -> error "inferenceCheck: Check failed" + _ -> return (s, res) + +inference :: InferenceConfig -> G2.Config -> LHConfig -> [FilePath] -> [FilePath] -> IO (State [FuncCall], Either [CounterExample] GeneratedSpecs) +inference infconfig config g2lhconfig proj fp = do + -- Initialize LiquidHaskell + (ghci, lhconfig) <- getGHCI infconfig proj fp + (s, res, timer, _) <- inference' infconfig config g2lhconfig lhconfig ghci proj fp + print . logToSecs . sumLog . getLog $ timer + return (s, res) + +inference' :: InferenceConfig + -> G2.Config + -> LHConfig + -> LH.Config + -> [GhcInfo] + -> [FilePath] + -> [FilePath] + -> IO (State [FuncCall], Either [CounterExample] GeneratedSpecs, Timer (Event Name), Counters) +inference' infconfig config g2lhconfig lhconfig ghci proj fp = do + mapM_ (print . getQualifiers) ghci + + (lrs, g2config', g2lhconfig', infconfig', main_mod) <- getInitState proj fp ghci infconfig config g2lhconfig + let nls = getNameLevels main_mod lrs + + let ut = sharedTyConsEE (concat nls) (expr_env . G2LH.state . lr_state $ lrs) + + let configs = Configs { g2_config = g2config', g2lh_config = g2lhconfig', lh_config = lhconfig, inf_config = infconfig'} + prog = newProgress + + SomeSMTSolver solver <- getSMT g2config' + let infL = iterativeInference solver ghci main_mod lrs nls HM.empty emptyGS emptyFC ut + + (res, ev_timer, lvl_timer, loops) <- runInfStack configs prog infL -- runProgresser (runConfigs (runTimer infL timer) configs) prog + + print . logToSecs . orderLogBySpeed . sumLog . getLog $ lvl_timer + + print . logToSecs . orderLogBySpeed . sumLog . mapLabels (mapEvent nameOcc) . getLog $ ev_timer + print . logToSecs . orderLogBySpeed . sumLog . mapLabels (mapEvent (const ())) . getLog $ ev_timer + return (G2LH.state . lr_state $ lrs, res, ev_timer, loops) + +getInitState :: [FilePath] + -> [FilePath] + -> [GhcInfo] + -> InferenceConfig + -> G2.Config + -> LHConfig + -> IO (LiquidReadyState, G2.Config, LHConfig, InferenceConfig, Maybe T.Text) +getInitState proj fp ghci infconfig config lhconfig = do + let g2config = config { mode = Liquid + , steps = 2000 } + transConfig = simplTranslationConfig { simpl = False } + (main_mod, exg2) <- translateLoaded proj fp transConfig g2config + + let (lrs, g2config', lhconfig', infconfig') = initStateAndConfig exg2 main_mod g2config lhconfig infconfig ghci + return (lrs, g2config', lhconfig', infconfig', main_mod) + +getNameLevels :: Maybe T.Text -> LiquidReadyState -> NameLevels +getNameLevels main_mod = + filter (not . null) + . map nub + . nameLevels + . getCallGraph + . E.filterWithKey (\(Name _ m _ _) _ -> m == main_mod) + . expr_env . G2LH.state . lr_state + + +data InferenceRes = CEx [CounterExample] + | Env GeneratedSpecs FuncConstraints MaxSizeConstraints MeasureExs + | Raise MeasureExs FuncConstraints MaxSizeConstraints + deriving (Show) + +type NameLevels = [[Name]] + +type MaxSizeConstraints = FuncConstraints + +iterativeInference :: (MonadIO m, SMTConverter con) + => con + -> [GhcInfo] + -> Maybe T.Text + -> LiquidReadyState + -> NameLevels + -> MeasureExs + -> GeneratedSpecs + -> FuncConstraints + -> UnionedTypes + -> InfStack m (Either [CounterExample] GeneratedSpecs) +iterativeInference con ghci m_modname lrs nls meas_ex gs fc ut = do + res <- inferenceL con FirstRound ghci m_modname lrs nls emptyEvals meas_ex gs fc emptyFC ut emptyBlockedModels + case res of + CEx cex -> return $ Left cex + Env n_gs _ _ _ -> return $ Right n_gs + Raise _ r_fc _ -> do + incrMaxDepthI + -- We might be missing some internal GHC types from our deep_seq walkers + -- We filter them out to avoid an error + let eenv = expr_env . G2LH.state $ lr_state lrs + chck = filter (\n -> + case E.lookup n eenv of + Just e -> isJust $ + mkStrict_maybe + (deepseq_walkers $ lr_binding lrs) + (Var (Id (Name "" Nothing 0 Nothing) (returnType e))) + Nothing -> False) (head nls) + liftIO . putStrLn $ "head nls = " ++ show (head nls) + + logEventStartM CExSE + ref <- getCEx ghci m_modname lrs gs chck + logEventEndM + case ref of + Left cex -> return $ Left cex + Right fc' -> do + logEventStartM UpdateMeasures + logEventEndM + incrMaxSynthSizeI + r_meas_ex' <- lift . lift . lift $ updateMeasureExs {- r_meas_ex -} HM.empty lrs ghci {- fc' -} (unionFC fc' r_fc) + iterativeInference con ghci m_modname lrs nls r_meas_ex' gs (unionFC fc' r_fc) ut + + +inferenceL :: (MonadIO m, SMTConverter con) + => con + -> Iteration + -> [GhcInfo] + -> Maybe T.Text + -> LiquidReadyState + -> NameLevels + -> Evals Bool + -> MeasureExs + -> GeneratedSpecs + -> FuncConstraints + -> MaxSizeConstraints + -> UnionedTypes + -> BlockedModels + -> InfStack m InferenceRes +inferenceL con iter ghci m_modname lrs nls evals meas_ex senv fc max_fc ut blk_mdls = do + let sf = case nls of + (_:sf_:_) -> sf_ + ([_])-> [] + [] -> [] + + startLevelTimer (case nls of fs_:_ -> fs_; [] -> []) + (resAtL, evals') <- inferenceB con iter ghci m_modname lrs nls evals meas_ex senv fc max_fc ut blk_mdls + endLevelTimer + + liftIO $ do + putStrLn "-------" + putStrLn $ "lengths = " ++ show (HM.map (length . nub) (blockedHashMap blk_mdls)) + putStrLn "-------" + + case resAtL of + Env senv' n_fc n_mfc meas_ex' -> + case nls of + [] -> return resAtL + (_:nls') -> do + liftIO $ putStrLn "Down a level!" + let evals'' = foldr deleteEvalsForFunc evals' sf + inf_res <- inferenceL con FirstRound ghci m_modname lrs nls' evals'' meas_ex' senv' + (unionFC fc n_fc) (unionFC max_fc n_mfc) ut emptyBlockedModels + case inf_res of + Raise r_meas_ex r_fc r_max_fc -> do + liftIO $ putStrLn "Up a level!" + + inferenceL con AfterFirstRound ghci m_modname lrs nls evals' r_meas_ex senv r_fc r_max_fc ut blk_mdls + _ -> return inf_res + _ -> return resAtL + +inferenceB :: (MonadIO m, SMTConverter con) + => con + -> Iteration + -> [GhcInfo] + -> Maybe T.Text + -> LiquidReadyState + -> NameLevels + -> Evals Bool + -> MeasureExs + -> GeneratedSpecs + -> FuncConstraints + -> MaxSizeConstraints + -> UnionedTypes + -> BlockedModels + -> InfStack m (InferenceRes, Evals Bool) +inferenceB con iter ghci m_modname lrs nls evals meas_ex gs fc max_fc ut blk_mdls = do + let (fs, sf, below_sf) = case nls of + (fs_:sf_:be) -> (fs_, sf_, be) + ([fs_])-> (fs_, [], []) + [] -> ([], [], []) + + incrLoopCountLog fs + + let curr_ghci = addSpecsToGhcInfos ghci gs + logEventStartM UpdateEvals + evals' <- updateEvals curr_ghci lrs fc evals + logEventEndM + logEventStartM Synth + synth_gs <- lift . lift . lift $ synthesize con iter curr_ghci lrs evals' meas_ex (unionFC max_fc fc) ut blk_mdls (concat below_sf) sf + logEventEndM + + liftIO $ do + putStrLn "-------" + putStrLn $ "lengths = " ++ show (HM.map (length . nub) (blockedHashMap blk_mdls)) + putStrLn "-------" + + case synth_gs of + SynthEnv envN sz smt_mdl blk_mdls' -> do + let gs' = unionDroppingGS gs envN + ghci' = addSpecsToGhcInfos ghci gs' + liftIO $ do + putStrLn "inferenceB" + putStrLn $ "fs = " ++ show fs + putStrLn $ "init gs' = " ++ show gs' + + logEventStartM Verify + res <- tryToVerify ghci' + logEventEndM + let res' = filterNamesTo fs res + + case res' of + Safe -> return $ (Env gs' fc max_fc meas_ex, evals') + Unsafe bad -> do + inf_con <- infConfigM + ref <- tryToGen (nub bad) ((emptyFC, emptyBlockedModels), emptyFC) + (\(fc1, bm1) (fc2, bm2) -> (fc1 `unionFC` fc2, bm1 `unionBlockedModels` bm2)) + unionFC + [ (\n -> do + logEventStartM (InfSE n) + return $ Right (Nothing, emptyFC)) + , refineUnsafe ghci m_modname lrs gs' + , if use_level_dec inf_con then searchBelowLevel ghci m_modname lrs res sf gs' else genEmp + , if use_negated_models inf_con then adjModel lrs sz smt_mdl else incrCExAndTime ] + logEventEndM + + case ref of + Left cex -> return $ (CEx cex, evals') + Right ((viol_fc, new_blk_mdls), no_viol_fc) -> do + let fc' = viol_fc `unionFC` no_viol_fc + blk_mdls'' = blk_mdls' `unionBlockedModels` new_blk_mdls + liftIO $ putStrLn "Before genMeasureExs" + logEventStartM UpdateMeasures + meas_ex' <- lift . lift . lift $ updateMeasureExs meas_ex lrs ghci fc' + logEventEndM + liftIO $ putStrLn "After genMeasureExs" + + inferenceB con AfterFirstRound ghci m_modname lrs nls evals' meas_ex' gs (unionFC fc fc') max_fc ut blk_mdls'' + + Crash e1 e2 -> error $ "inferenceB: LiquidHaskell crashed" ++ "\n" ++ show e1 ++ "\n" ++ e2 + SynthFail sf_fc -> do + liftIO . T.putStrLn $ "synthfail fc = " <> (printFCs lrs sf_fc) + incrBackTrackLog + return $ (Raise meas_ex fc (unionFC max_fc sf_fc), evals') + +tryToGen :: Monad m => + [n] -- ^ A list of values to produce results for + -> (r, ex) -- ^ A default result, in case none of the strategies work, or we are passed an empty [n] + -> (r -> r -> r) -- ^ Some way of combining results + -> (ex -> ex -> ex) -- ^ Some way of joining extra results + -> [n -> m (Either err (Maybe r, ex))] -- ^ A list of strategies, in order, to try and produce a result + -> m () -- ^ A monadic action to run after each n is processed + -> m (Either err (r, ex)) +tryToGen [] def _ _ _ _= return $ Right def +tryToGen (n:ns) def join_r join_ex fs final_m = do + gen1 <- tryToGen' n def join_ex fs + final_m + case gen1 of + Left err -> return $ Left err + Right (r1, ex1) -> do + gen2 <- tryToGen ns def join_r join_ex fs final_m + case gen2 of + Left err -> return $ Left err + Right (r2, ex2) -> return $ Right (r1 `join_r` r2, ex1 `join_ex` ex2) + +tryToGen' :: Monad m => + n + -> (r, ex) + -> (ex -> ex -> ex) + -> [n -> m (Either err (Maybe r, ex))] + -> m (Either err (r, ex)) +tryToGen' _ def _ [] = return $ Right (def) +tryToGen' n def join_ex (f:fs) = do + gen1 <- f n + case gen1 of + Left err -> return $ Left err + Right (Just r, ex) -> return $ Right (r, ex) + Right (Nothing, ex1) -> do + gen2 <- tryToGen' n def join_ex fs + case gen2 of + Left err -> return $ Left err + Right (r, ex2) -> return $ Right (r, ex1 `join_ex` ex2) + +genEmp :: Monad m => Name -> InfStack m (Either [CounterExample] (Maybe a, FuncConstraints)) +genEmp _ = return $ Right (Nothing, emptyFC) + +refineUnsafeAll :: MonadIO m => + [GhcInfo] + -> Maybe T.Text + -> LiquidReadyState + -> GeneratedSpecs + -> [Name] + -> InfStack m (Either [CounterExample] (Maybe FuncConstraints, FuncConstraints)) +refineUnsafeAll ghci m_modname lrs gs bad = do + res <- mapM (refineUnsafe ghci m_modname lrs gs) (nub bad) + + case fmap unzip $ partitionEithers res of + (cex@(_:_), _) -> return . Left $ concat cex + ([], (new_fcs, no_viol_fcs)) -> + let + new_fcs' = unionsFC . map fst $ catMaybes new_fcs + in + return . Right $ (if nullFC new_fcs' then Nothing else Just new_fcs', unionsFC no_viol_fcs) + +refineUnsafe :: MonadIO m => + [GhcInfo] + -> Maybe T.Text + -> LiquidReadyState + -> GeneratedSpecs + -> Name + -> InfStack m (Either [CounterExample] (Maybe (FuncConstraints, BlockedModels), FuncConstraints)) +refineUnsafe ghci m_modname lrs gs bad = do + let merged_se_ghci = addSpecsToGhcInfos ghci gs + + (res, no_viol) <- genNewConstraints merged_se_ghci m_modname lrs (nameOcc bad) + + liftIO $ do + putStrLn $ "--- Generated Counterexamples and Constraints for " ++ show bad ++ " ---" + putStrLn "res = " + printCE (T.state $ lr_state lrs) res + + let res' = filter (not . hasAbstractedArgError) res + + -- Either converts counterexamples to FuncConstraints, or returns them as errors to + -- show to the user. + new_fc <- checkNewConstraints ghci lrs res' + + case new_fc of + Left cex -> return $ Left cex + Right new_fc' -> do + liftIO . T.putStrLn $ "new_fc' = " <> printFCs lrs new_fc' + return $ Right (if nullFC new_fc' + then Nothing + else Just (new_fc', emptyBlockedModels), fromListFC no_viol) + +searchBelowLevel :: MonadIO m => + [GhcInfo] + -> Maybe T.Text + -> LiquidReadyState + -> VerifyResult Name + -> [Name] + -> GeneratedSpecs + -> Name + -> InfStack m (Either [CounterExample] (Maybe (FuncConstraints, BlockedModels), FuncConstraints)) +searchBelowLevel ghci m_modname lrs verify_res lev_below gs bad = do + incrSearchBelowLog + let called_by_res = calledByFunc lrs bad + case filterNamesTo called_by_res $ filterNamesTo lev_below verify_res of + Unsafe bad_sf -> do + liftIO $ putStrLn "About to run second run of CEx generation" + ref_sf <- withConfigs (limitedCounterfactual $ namesGS gs) $ refineUnsafeAll ghci m_modname lrs gs bad_sf + case ref_sf of + Left cex -> return $ Left cex + Right (viol_fc_sf, no_viol_fc_sf) -> + return $ Right (fmap (, emptyBlockedModels) viol_fc_sf, no_viol_fc_sf) + Safe -> return $ Right (Nothing, emptyFC) + Crash _ _ -> error "inferenceB: LiquidHaskell crashed" + +adjModel :: MonadIO m => + LiquidReadyState + -> Size + -> SMTModel + -> Name + -> InfStack m (Either a (Maybe (FuncConstraints, BlockedModels), FuncConstraints)) +adjModel lrs sz smt_mdl n = do + incrNegatedModelLog + liftIO $ putStrLn "adjModel repeated_fc" + let clls = calledByFunc lrs n + blk_mdls' = insertBlockedModel sz (MNOnly (n:clls)) smt_mdl emptyBlockedModels + + liftIO . putStrLn $ "blocked models = " ++ show blk_mdls' + + _ <- incrCExAndTime n + return . Right $ (Just (emptyFC, blk_mdls'), emptyFC) + +incrCExAndTime :: Monad m => Name -> InfStack m (Either a (Maybe b, FuncConstraints)) +incrCExAndTime (Name n m _ _) = do + incrMaxCExI (n, m) + incrMaxTimeI (n, m) + return $ Right (Nothing, emptyFC) + +calledByFunc :: LiquidReadyState -> Name -> [Name] +calledByFunc lrs n = + let + eenv = expr_env . G2LH.state $ lr_state lrs + in + map zeroOutUnq + . filter (isJust . flip E.lookup eenv) + . maybe [] id + . fmap varNames + . fmap snd + $ E.lookupNameMod (nameOcc n) (nameModule n) eenv + +filterNamesTo :: [Name] -> VerifyResult Name -> VerifyResult Name +filterNamesTo ns (Unsafe unsafe) = + case filter (\n -> toOccMod n `elem` ns_nm) unsafe of + [] -> Safe + unsafe' -> do + Unsafe unsafe' + where + ns_nm = map toOccMod ns + toOccMod (Name n m _ _) = (n, m) +filterNamesTo _ vr = vr + +limitedCounterfactual :: [Name] -> Configs -> Configs +limitedCounterfactual ns cfgs@(Configs { g2lh_config = g2lh_c }) = + cfgs { g2lh_config = g2lh_c { counterfactual = Counterfactual + . CFOnly + . S.fromList + $ map (\(Name n m _ _) -> (n, m)) ns } } + +genNewConstraints :: MonadIO m => + [GhcInfo] + -> Maybe T.Text + -> LiquidReadyState + -> T.Text + -> InfStack m ([CounterExample], [FuncConstraint]) +genNewConstraints ghci m lrs n = do + liftIO . putStrLn $ "Generating constraints for " ++ T.unpack n + infconfig <- infConfigM + + ((exec_res, _), i) <- runLHInferenceCore n m lrs ghci + let (exec_res', no_viol) = partition (true_assert . final_state) exec_res + + allCCons = noAbsStatesToCons i $ exec_res' ++ if use_extra_fcs infconfig then no_viol else [] + return $ (filter (not . hasPreArgError) $ map lhStateToCE exec_res', allCCons) + +getCEx :: MonadIO m => + [GhcInfo] + -> Maybe T.Text + -> LiquidReadyState + -> GeneratedSpecs + -> [Name] + -> InfStack m (Either [CounterExample] FuncConstraints) +getCEx ghci m_modname lrs gs bad = do + let merged_se_ghci = addSpecsToGhcInfos ghci gs + + liftIO $ mapM_ (print . getTySigs) merged_se_ghci + + let bad' = nub $ map nameOcc bad + + res <- mapM (checkForCEx merged_se_ghci m_modname lrs) bad' + + liftIO $ do + putStrLn $ "getCEx res = " + printCE (T.state $ lr_state lrs) $ concat res + + let res' = concat res + + -- Either converts counterexamples to FuncConstraints, or returns them as errors to + -- show to the user. + new_fc <- checkNewConstraints ghci lrs res' + + case new_fc of + Left cex -> return $ Left cex + Right new_fc' -> do + liftIO . T.putStrLn $ "new_fc' = " <> printFCs lrs new_fc' + return $ Right new_fc' + +checkForCEx :: MonadIO m => + [GhcInfo] + -> Maybe T.Text + -> LiquidReadyState + -> T.Text + -> InfStack m [CounterExample] +checkForCEx ghci m lrs n = do + liftIO . putStrLn $ "Checking CEx for " ++ T.unpack n + ((exec_res, _), _) <- runLHCExSearch n m lrs ghci + let exec_res' = filter (true_assert . final_state) exec_res + return $ map lhStateToCE exec_res' + +checkNewConstraints :: (InfConfigM m, MonadIO m) => [GhcInfo] -> LiquidReadyState -> [CounterExample] -> m (Either [CounterExample] FuncConstraints) +checkNewConstraints ghci lrs cexs = do + infconfig <- infConfigM + res <- mapM (cexsToBlockingFC lrs ghci) cexs + res2 <- return . concat =<< mapM cexsToExtraFC cexs + case lefts res of + res'@(_:_) -> return . Left $ res' + _ -> return . Right . unionsFC . map fromSingletonFC $ (rights res) ++ if use_extra_fcs infconfig then res2 else [] + +updateMeasureExs :: (InfConfigM m, ProgresserM m, MonadIO m) => MeasureExs -> LiquidReadyState -> [GhcInfo] -> FuncConstraints -> m MeasureExs +updateMeasureExs meas_ex lrs ghci fcs = + let + es = concatMap (\fc -> + let + clls = concatMap (\(mfc, hfc) -> mfc:hfc) $ allCalls fc + vls = concatMap (\c -> returns c:arguments c) clls + ex_poly = concat . concatMap extractValues . concatMap extractExprPolyBound $ vls + in + vls ++ ex_poly + ) (toListFC fcs) + in + evalMeasures meas_ex lrs ghci es + +synthesize :: (InfConfigM m, ProgresserM m, MonadIO m, SMTConverter con) + => con -> Iteration -> [GhcInfo] -> LiquidReadyState -> Evals Bool -> MeasureExs + -> FuncConstraints -> UnionedTypes -> BlockedModels -> [Name] -> [Name] -> m SynthRes +synthesize con iter ghci lrs evals meas_ex fc ut blk_mdls to_be for_funcs = do + liaSynth con iter ghci lrs evals meas_ex fc ut blk_mdls to_be for_funcs + +updateEvals :: (InfConfigM m, MonadIO m) => [GhcInfo] -> LiquidReadyState -> FuncConstraints -> Evals Bool -> m (Evals Bool) +updateEvals ghci lrs fc evals = do + let cs = allCallsFC fc + + liftIO $ putStrLn "Before check func calls" + evals' <- preEvals evals lrs ghci cs + liftIO $ putStrLn "After pre" + evals'' <- postEvals evals' lrs ghci cs + liftIO $ putStrLn "After check func calls" + + return evals'' + +-- | Converts counterexamples into constraints that block the current specification set +cexsToBlockingFC :: (InfConfigM m, MonadIO m) => LiquidReadyState -> [GhcInfo] -> CounterExample -> m (Either CounterExample FuncConstraint) +cexsToBlockingFC _ _ (DirectCounter dfc fcs@(_:_) higher) + | (_:_, _) <- partition (hasArgError . abstract) fcs = undefined + | isError (returns (abstract dfc)) = do + infconfig <- infConfigM + let fcs' = filter (\fc -> abstractedMod fc `S.member` modules infconfig) fcs + + let rhs = OrFC $ map (\(Abstracted { abstract = fc }) -> + ImpliesFC (Call Pre fc higher) (NotFC (Call Post fc higher))) fcs' + + return . Right $ ImpliesFC (Call Pre (abstract dfc) higher) rhs + | otherwise = do + infconfig <- infConfigM + let fcs' = filter (\fc -> abstractedMod fc `S.member` modules infconfig) fcs + + let lhs = AndFC [Call Pre (abstract dfc) higher, NotFC (Call Post (abstract dfc) higher)] + rhs = OrFC $ map (\(Abstracted { abstract = fc }) -> + ImpliesFC (Call Pre fc higher) (NotFC (Call Post fc higher))) fcs' + + if not . null $ fcs' + then return . Right $ ImpliesFC lhs rhs + else error "cexsToBlockingFC: Unhandled" +cexsToBlockingFC _ _ (CallsCounter dfc cfc fcs@(_:_) higher) + | (_:_, _) <- partition (hasArgError . abstract) fcs = undefined + | isError (returns (abstract cfc)) = do + infconfig <- infConfigM + let fcs' = filter (\fc -> abstractedMod fc `S.member` modules infconfig) fcs + + let lhs = Call Pre (abstract dfc) higher + rhs = OrFC $ map (\(Abstracted { abstract = fc }) -> + ImpliesFC (Call Pre fc higher) (NotFC (Call Post fc higher))) fcs' + + if not . null $ fcs' + then return . Right $ ImpliesFC lhs rhs + else error "cexsToBlockingFC: Should be unreachable! Non-refinable function abstracted!" + + | otherwise = do + infconfig <- infConfigM + let fcs' = filter (\fc -> abstractedMod fc `S.member` modules infconfig) fcs + + let lhs = AndFC [Call Pre (abstract dfc) higher, NotFC (Call Pre (abstract cfc) higher)] + rhs = OrFC $ map (\(Abstracted { abstract = fc }) -> + ImpliesFC (Call Pre fc higher) (NotFC (Call Post fc higher))) fcs' + + if not . null $ fcs' + then return . Right $ ImpliesFC lhs rhs + else error "cexsToBlockingFC: Should be unreachable! Non-refinable function abstracted!" +cexsToBlockingFC lrs ghci cex@(DirectCounter dfc [] higher) + | isError (returns (real dfc)) = do + if isExported lrs (funcName (real dfc)) + then return . Left $ cex + else return . Right . NotFC $ Call Pre (real dfc) higher + | isExported lrs (funcName (real dfc)) = do + post_ref <- checkPost ghci lrs (real dfc) higher + case post_ref of + True -> return $ Right (Call All (real dfc) higher) + False -> return . Left $ cex + | otherwise = return $ Right (Call All (real dfc) higher) +cexsToBlockingFC lrs ghci cex@(CallsCounter dfc cfc [] higher) + | any isError (arguments (abstract cfc)) = do + if + | isExported lrs (funcName (real dfc)) + , isExported lrs (funcName (real cfc)) -> do + called_pr <- checkPre ghci lrs (real cfc) higher -- TODO: Shouldn't be changing this? + case called_pr of + True -> return . Right $ NotFC (Call Pre (real dfc) higher) + False -> return . Left $ cex + | isExported lrs (funcName (real dfc)) -> do + called_pr <- checkPre ghci lrs (real cfc) higher + case called_pr of + True -> return . Right $ NotFC (Call Pre (real dfc) higher) + False -> return . Left $ cex + | otherwise -> return . Right $ NotFC (Call Pre (real dfc) higher) + | otherwise = do + if + | isExported lrs (funcName (real dfc)) + , isExported lrs (funcName (real cfc)) -> do + called_pr <- checkPre ghci lrs (real cfc) higher -- TODO: Shouldn't be changing this? + case called_pr of + True -> return . Right $ ImpliesFC (Call Pre (real dfc) higher) (Call Pre (real cfc) higher) + False -> return . Left $ cex + | isExported lrs (funcName (real dfc)) -> do + called_pr <- checkPre ghci lrs (real cfc) higher + case called_pr of + True -> return . Right $ ImpliesFC (Call Pre (real dfc) higher) (Call Pre (real cfc) higher) + False -> return . Left $ cex + | otherwise -> do + return . Right $ ImpliesFC (Call Pre (real dfc) higher) (Call Pre (real cfc) higher) + +-- Function constraints that don't block the current specification set, but which must be true +-- (i.e. the actual input and output for abstracted functions) +cexsToExtraFC :: InfConfigM m => CounterExample -> m [FuncConstraint] +cexsToExtraFC (DirectCounter dfc fcs@(_:_) higher) = do + infconfig <- infConfigM + let some_pre = ImpliesFC (Call Pre (real dfc) higher) $ OrFC (map (\fc -> Call Pre (real fc) higher) fcs) + fcs' = filter (\fc -> abstractedMod fc `S.member` modules infconfig) fcs + return $ some_pre:mapMaybe (realToMaybeFC higher) fcs' +cexsToExtraFC (CallsCounter dfc cfc fcs@(_:_) higher) = do + infconfig <- infConfigM + let some_pre = ImpliesFC (Call Pre (real dfc) higher) $ OrFC (map (\fc -> Call Pre (real fc) higher) fcs) + let fcs' = filter (\fc -> abstractedMod fc `S.member` modules infconfig) fcs + + let pre_real = maybeToList $ (realToMaybeFC higher) cfc + as = mapMaybe (realToMaybeFC higher) fcs' + clls = if not . isError . returns . real $ cfc + then [Call All (real cfc) higher] + else [] + + return $ some_pre:clls ++ pre_real ++ as +cexsToExtraFC (DirectCounter _ [] _) = return [] +cexsToExtraFC (CallsCounter dfc cfc [] higher) + | isError (returns (real dfc)) = return [] + | isError (returns (real cfc)) = return [] + | any isError (arguments (real cfc)) = return [] + | otherwise = + let + call_all_dfc = Call All (real dfc) higher + call_all_cfc = Call All (real cfc) higher + imp_fc = ImpliesFC (Call Pre (real dfc) higher) (Call Pre (real cfc) higher) + in + return $ [call_all_dfc, call_all_cfc, imp_fc] + +noAbsStatesToCons :: Id -> [ExecRes AbstractedInfo] -> [FuncConstraint] +noAbsStatesToCons i = concatMap (noAbsStatesToCons' i) -- . filter (null . abs_calls . track . final_state) + +noAbsStatesToCons' :: Id -> ExecRes AbstractedInfo -> [FuncConstraint] +noAbsStatesToCons' i@(Id (Name _ m _ _) _) er = + let + higher_calls = erHigherOrder er + + pre_s = lhStateToPreFC i er + clls = filter (\fc -> nameModule (funcName fc) == m) + . map (switchName (idName i)) + . filter (not . hasArgError) + . func_calls_in_real + . init_call + . track + $ final_state er + + preCons = map (ImpliesFC pre_s . flip (Call Pre) higher_calls) clls + -- A function may return error because it was passed an erroring higher order function. + -- In this case, it would be incorrect to add a constraint that the function itself calls error. + -- Thus, we simply get rid of constraints that call error. + callsCons = mapMaybe (\fc -> case isError (returns fc) of + True -> Nothing -- NotFC (Call Pre fc) + False -> Just (Call All fc higher_calls)) clls + callsCons' = if hits_lib_err_in_real (init_call . track . final_state $ er) + then [] + else callsCons + in + preCons ++ callsCons' + +switchName :: Name -> FuncCall -> FuncCall +switchName n fc = if funcName fc == initiallyCalledFuncName then fc { funcName = n } else fc + +-------------------------------------------------------------------- + +realToMaybeFC :: [HigherOrderFuncCall] -> Abstracted -> Maybe FuncConstraint +realToMaybeFC higher a@(Abstracted { real = fc }) + | hits_lib_err_in_real a = Nothing + | isError (returns fc) = Just $ NotFC (Call Pre fc higher) + | otherwise = Just $ ImpliesFC (Call Pre fc higher) (Call Post fc higher) + +isExported :: LiquidReadyState -> Name -> Bool +isExported lrs (Name n m _ _) = + (n, m) `elem` map (\(Name n' m' _ _) -> (n', m')) (exported_funcs (lr_binding lrs)) + +lhStateToPreFC :: Id -> ExecRes AbstractedInfo -> FuncConstraint +lhStateToPreFC i er@(ExecRes { conc_args = inArg + , conc_out = ex}) = Call Pre (FuncCall (idName i) inArg ex) (erHigherOrder er) + +abstractedMod :: Abstracted -> Maybe T.Text +abstractedMod = nameModule . funcName . abstract + +hasPreArgError :: CounterExample -> Bool +hasPreArgError (DirectCounter _ _ _) = False +hasPreArgError (CallsCounter _ calls_f _ _) = hasArgError $ real calls_f + +hasAbstractedArgError :: CounterExample -> Bool +hasAbstractedArgError (DirectCounter _ as _) = any (hasArgError . real) as +hasAbstractedArgError (CallsCounter _ _ as _) = any (hasArgError . real) as + +hasArgError :: FuncCall -> Bool +hasArgError = any isError . arguments + +isError :: Expr -> Bool +isError (Prim Error _) = True +isError (Prim Undefined _) = True +isError _ = False + +erHigherOrder :: ExecRes AbstractedInfo -> [HigherOrderFuncCall] +erHigherOrder = ai_higher_order_calls . track . final_state diff --git a/src/G2/Liquid/Inference/PolyRef.hs b/src/G2/Liquid/Inference/PolyRef.hs new file mode 100644 --- /dev/null +++ b/src/G2/Liquid/Inference/PolyRef.hs @@ -0,0 +1,212 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable#-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TupleSections #-} + +module G2.Liquid.Inference.PolyRef ( PolyBound (.. ) + , RefNamePolyBound + , ExprPolyBound + , extractExprPolyBoundWithRoot + , extractExprPolyBound + , extractTypePolyBound + , extractTypeAppAndFuncPolyBound + + , headValue + , removeHead + , extractValues + , uniqueIds + , mapPB + , filterPB + , allPB + , zipPB + , zipWithPB + , zipWithMaybePB + , zip3PB) where + +import G2.Language + +import qualified Data.HashMap.Lazy as HM +import Data.List +import Data.Maybe + +type RefNamePolyBound = PolyBound String +type ExprPolyBound = PolyBound [Expr] + +type TypePolyBound = PolyBound Type + +-- | The subexpressions of an expression corresponding to the polymorphic +-- arguments. If a polymorphic argument is instantiated with a polymorphic +-- type, these are nested recursively. +data PolyBound v = PolyBound v [PolyBound v] deriving (Eq, Read, Show, Functor, Foldable, Traversable) + +------------------------------- +-- ExprPolyBound +------------------------------- + +extractExprPolyBoundWithRoot :: Expr -> ExprPolyBound +extractExprPolyBoundWithRoot e = PolyBound [e] $ extractExprPolyBound e + +extractExprPolyBound :: Expr -> [ExprPolyBound] +extractExprPolyBound e + | Data dc:_ <- unApp e = + let + bound = leadingTyForAllBindings dc + m = extractExprPolyBound' e + + bound_es = map (\i -> HM.lookupDefault [] i m) bound + in + map (\es -> PolyBound es (mergeExprPolyBound . transpose $ map extractExprPolyBound es)) bound_es + | otherwise = [] + +mergeExprPolyBound :: [[ExprPolyBound]] -> [ExprPolyBound] +mergeExprPolyBound = mapMaybe (\pb -> case pb of + (p:pbb) -> Just $ foldr mergeExprPolyBound' p pbb + [] -> Nothing) + +mergeExprPolyBound' :: ExprPolyBound -> ExprPolyBound -> ExprPolyBound +mergeExprPolyBound' (PolyBound es1 pb1) (PolyBound es2 pb2) = + PolyBound (es1 ++ es2) (map (uncurry mergeExprPolyBound') $ zip pb1 pb2) + +extractExprPolyBound' :: Expr -> HM.HashMap Id [Expr] +extractExprPolyBound' e + | Data dc:es <- unApp e = + let + es' = filter (not . isType) es + + argtys = argumentTypes . PresType . inTyForAlls $ typeOf dc + + argtys_es = zip argtys es' + + (direct, indirect) = partition fstIsTyVar argtys_es + direct' = mapMaybe fstMapTyVar direct + indirect' = map (uncurry substTypes) indirect + + direct_hm = foldr (HM.unionWith (++)) HM.empty + $ map (\(i, e_) -> uncurry HM.singleton (i, e_:[])) direct' + in + foldr (HM.unionWith (++)) direct_hm $ map (extractExprPolyBound' . adjustIndirectTypes) indirect' + | otherwise = HM.empty + where + isType (Type _) = True + isType _ = False + + fstIsTyVar (TyVar _, _) = True + fstIsTyVar _ = False + + fstMapTyVar (TyVar i, x) = Just (i, x) + fstMapTyVar _ = Nothing + +substTypes :: Type -> Expr -> Expr +substTypes t e + | _:ts <- unTyApp t + , e':es <- unApp e = + mkApp $ e':substTypes' ts es +substTypes _ e = e + +substTypes' :: [Type] -> [Expr] -> [Expr] +substTypes' (t:ts) (Type _:es) = Type t:substTypes' ts es +substTypes' _ es = es + +adjustIndirectTypes :: Expr -> Expr +adjustIndirectTypes e + | Data dc:es <- unApp e = + let + tyses = filter (isType) es + tyses' = map (\(Type t) -> t) tyses + + bound = leadingTyForAllBindings dc + bound_tyses = zip bound tyses' + in + mkApp $ Data (foldr (uncurry retype) dc $ bound_tyses):es + | otherwise = e + where + isType (Type _) = True + isType _ = False + + +------------------------------- +-- TypePolyBound +------------------------------- + +-- | Unrolls TyApp'ed args, while also keeping them in the base type +extractTypePolyBound :: Type -> TypePolyBound +extractTypePolyBound t = + let + (_:ts) = unTyApp t + in + PolyBound t $ map extractTypePolyBound ts + +-- | Unrolls TyApp'ed and TyFunc'ed args, while also keeping them in the base type +extractTypeAppAndFuncPolyBound :: Type -> TypePolyBound +extractTypeAppAndFuncPolyBound t@(TyApp _ _) = + let + (_:ts) = unTyApp t + in + PolyBound t $ map extractTypePolyBound ts +extractTypeAppAndFuncPolyBound t@(TyFun _ _) = + let + ts = splitTyFuns t + in + PolyBound t $ map extractTypePolyBound ts +extractTypeAppAndFuncPolyBound t = PolyBound t [] + +------------------------------- +-- Generic PolyBound functions +------------------------------- + +headValue :: PolyBound v -> v +headValue (PolyBound v _) = v + +removeHead :: PolyBound v -> [PolyBound v] +removeHead (PolyBound _ vs) = vs + +extractValues :: PolyBound v -> [v] +extractValues (PolyBound v ps) = v:concatMap extractValues ps + +uniqueIds :: PolyBound v -> PolyBound Int +uniqueIds = snd . uniqueIds' 0 + +uniqueIds' :: Int -> PolyBound v -> (Int, PolyBound Int) +uniqueIds' n (PolyBound _ ps) = + let + (n', ps') = mapAccumR (uniqueIds') (n + 1) ps + in + (n', PolyBound n ps') + +mapPB :: (a -> b) -> PolyBound a -> PolyBound b +mapPB f (PolyBound v ps) = PolyBound (f v) (map (mapPB f) ps) + +filterPB :: (PolyBound a -> Bool) -> PolyBound a -> Maybe (PolyBound a) +filterPB p pb@(PolyBound v xs) = + case p pb of + True -> Just $ PolyBound v (mapMaybe (filterPB p) xs) + False -> Nothing + +allPB :: (a -> Bool) -> PolyBound a -> Bool +allPB p = all p . extractValues + +zipPB :: PolyBound a -> PolyBound b -> PolyBound (a, b) +zipPB (PolyBound a pba) (PolyBound b pbb) = PolyBound (a, b) (zipWith zipPB pba pbb) + +zipWithPB :: (a -> b -> c) -> PolyBound a -> PolyBound b -> PolyBound c +zipWithPB f (PolyBound a pba) (PolyBound b pbb) = PolyBound (f a b) (zipWith (zipWithPB f) pba pbb) + +zipWithMaybePB :: (Maybe a -> Maybe b -> c) -> PolyBound a -> PolyBound b -> PolyBound c +zipWithMaybePB f pba pbb = zipWithMaybePB' f (mapPB Just pba) (mapPB Just pbb) + +zipWithMaybePB' :: (Maybe a -> Maybe b -> c) -> PolyBound (Maybe a) -> PolyBound (Maybe b) -> PolyBound c +zipWithMaybePB' f (PolyBound a pba) (PolyBound b pbb) = + let + c = f a b + + rep_nt = repeat (PolyBound Nothing []) + + pbc = takeWhile (\(x, y) -> isJust (headValue x) || isJust (headValue y)) + $ zip (pba ++ rep_nt) (pbb ++ rep_nt) + in + PolyBound c $ map (uncurry (zipWithMaybePB' f)) pbc + +zip3PB :: PolyBound a -> PolyBound b -> PolyBound c -> PolyBound (a, b, c) +zip3PB (PolyBound a pba) (PolyBound b pbb) (PolyBound c pbc) = + PolyBound (a, b, c) (zipWith3 zip3PB pba pbb pbc) diff --git a/src/G2/Liquid/Inference/QualifGen.hs b/src/G2/Liquid/Inference/QualifGen.hs new file mode 100644 --- /dev/null +++ b/src/G2/Liquid/Inference/QualifGen.hs @@ -0,0 +1,260 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} + +module G2.Liquid.Inference.QualifGen () where -- qualifGen) where + +-- import G2.Language.Naming +-- import G2.Liquid.Inference.Sygus +-- import G2.Liquid.Helpers + +-- import Sygus.LexSygus +-- import Sygus.ParseSygus +-- import Sygus.Print +-- import Sygus.Syntax + +-- import Language.Fixpoint.Types.Constraints +-- import qualified Language.Fixpoint.Types.Names as LH +-- import Language.Fixpoint.Types.PrettyPrint + +-- import qualified Data.HashMap.Lazy as HM +-- import Data.List +-- import qualified Data.Map as M +-- import Data.Maybe +-- import qualified Data.Text as T +-- import Data.Tuple + +-- -- | Mocking measures to generate Qualifs. +-- data QMeasure = QMeasure { m_name :: String +-- , m_in :: Sort +-- , m_out :: Sort +-- , triv_out :: Term } + +-- -- Mocking datatypes +-- data QDataType = QDataType { dt_smt_name :: String +-- , dt_name :: String +-- , dt_cons :: [String] } + +-- data QualifConfig = QualifConfig { max_vars :: Int +-- , max_size :: Int +-- , datatypes :: [QDataType] +-- , measures :: [QMeasure] } + +-- qualifGen :: FilePath -> IO () +-- qualifGen qualif_fp = undefined -- do +{- let qc = QualifConfig + { max_vars = 3 + , max_size = 5 + , datatypes = [ QDataType { dt_smt_name = "List" + , dt_name = "ListQualif.List a" + , dt_cons = ["cons", "nil"] } + , QDataType { dt_smt_name = "List_List" + , dt_name = "ListQualif.List (ListQualif.List b)" + , dt_cons = ["cons_cons", "nil_nil"] }] + , measures = + [ QMeasure { m_name = "size_m__0" + , m_in = listSort + , m_out = intSort + , triv_out = trivOutGen (TermIdent (ISymb "cons")) + (TermLit $ LitNum 0) + (TermLit $ LitNum 2000) + } + , QMeasure { m_name = "sizeXs_m__0" + , m_in = IdentSort (ISymb "List_List") + , m_out = intSort + , triv_out = trivOutGen (TermIdent (ISymb "cons_cons")) + (TermLit $ LitNum 0) + (TermLit $ LitNum 4000) + } + ] + } + + cmds <- qualifCalls qc + + let printable_quals = map (cmdToQualifs (datatypes qc) (measures qc)) cmds + + writeFile qualif_fp (intercalate "\n" printable_quals) + +trivOutGen :: Term -> Term -> Term -> Term +trivOutGen v t1 t2 = + TermCall (ISymb "ite") + [TermCall (ISymb "=") [TermIdent (ISymb "a"), v], t1, t2] + +qualifCalls :: QualifConfig -> IO [Cmd] +qualifCalls (QualifConfig { max_vars = max_v + , max_size = max_s + , datatypes = dt + , measures = meas }) = do + + let srtss = concatMap (flip combinations (possibleDTs dt)) [1..max_v] + + r <- mapM (\srts -> do + let varN = map (\i -> "x" ++ show i) ([0..] :: [Int]) + svs = map (uncurry SortedVar) $ zip varN srts + + let call = qualifCalls' dt meas svs + putStrLn . T.unpack $ printSygus call + res <- runCVC4Stream max_s . T.unpack $ printSygus call + + case res of + Left err -> error "qualifGen: Bad call to CVC4" + Right res' -> do + let p_res = parse . lexSygus $ res' + all_used_res = filter defineFunAllUsed p_res + + return all_used_res + ) srtss + + return $ concat r + +combinations :: Int -> [a] -> [[a]] +combinations 0 _ = [[]] +combinations !n xs = [x:ys | x <- xs, ys <- combinations (n - 1) xs] + +possibleDTs :: [QDataType] -> [Sort] +possibleDTs dts = + let + srts = map (IdentSort . ISymb . dt_smt_name) dts + in + [intSort, boolSort] ++ srts + +qualifCalls' :: [QDataType] -> [QMeasure] -> [SortedVar] -> [Cmd] +qualifCalls' q_dt q_meas sortVars = + let + dt_srts = filter (\s -> s /= intSort && s /= boolSort) + . nub . map (\(SortedVar _ s) -> s) $ sortVars + + gram_names = zip (map (\i -> "G" ++ show i) [0..]) dt_srts + + gram = qualifGrammar gram_names q_meas + gram' = filterGrammar gram + in + [ SmtCmd (SetLogic "ALL")] + ++ + map qDataTypeToDeclareDataType q_dt + ++ + map qMeasureToDefineFun q_meas + ++ + [SynthFun "qualif" sortVars boolSort (Just gram')] + ++ + [ CheckSynth ] + +qualifGrammar :: [(String, Sort)] -> [QMeasure] -> GrammarDef +qualifGrammar dt_gram_names meas = + let + sw_gram_names = map swap dt_gram_names + + brl = GroupedRuleList "B" boolSort + (boolRuleList ++ qualifGramMeasCalls boolSort sw_gram_names meas) + irl = GroupedRuleList "I" intSort + (intRuleList ++ qualifGramMeasCalls intSort sw_gram_names meas) + + dt_rule_lists = map (\(gn, s) -> GroupedRuleList gn s [GVariable s]) dt_gram_names + in + GrammarDef + ([ SortedVar "B" boolSort + , SortedVar "I" intSort ] + ++ map (uncurry SortedVar) dt_gram_names) + ([brl, irl] ++ dt_rule_lists) + +qualifGramMeasCalls :: Sort -> [(Sort, String)] -> [QMeasure] -> [GTerm] +qualifGramMeasCalls srt sort_to_gram = mapMaybe (qualifGramMeasCall srt sort_to_gram) + +qualifGramMeasCall :: Sort -> [(Sort, String)] -> QMeasure -> Maybe GTerm +qualifGramMeasCall srt sort_to_gram meas@(QMeasure { m_name = f, m_in = i, m_out = out }) + | srt == out + , Just g <- lookup i sort_to_gram = + Just . GBfTerm $ BfIdentifierBfs (ISymb f) [BfIdentifier (ISymb g)] + | otherwise = Nothing + +-- | Eliminates or replaces the constant commands to avoid infinite grammars. +-- Eliminates And, since we get that anyway with Qualifs approach +filterGrammar :: GrammarDef -> GrammarDef +filterGrammar (GrammarDef sv grl) = GrammarDef sv $ map filterGrammar' grl + +filterGrammar' :: GroupedRuleList -> GroupedRuleList +filterGrammar' (GroupedRuleList symb srt gterms) = + GroupedRuleList symb srt . filter (not . isAnd) $ filter (not . isConstant) gterms + +isConstant :: GTerm -> Bool +isConstant (GConstant _) = True +isConstant _ = False + +isAnd :: GTerm -> Bool +isAnd (GBfTerm (BfIdentifierBfs (ISymb "and") _)) = True +isAnd _ = False + +-- | Converts a QDataType to a declare-datatype +qDataTypeToDeclareDataType :: QDataType -> Cmd +qDataTypeToDeclareDataType q_dt = + SmtCmd . DeclareDatatype (dt_smt_name q_dt) + . DTDec . map (flip DTConsDec []) $ dt_cons q_dt + +-- | Converts a QMeasure to a define-fun +qMeasureToDefineFun :: QMeasure -> Cmd +qMeasureToDefineFun q_meas = + let + ar = SortedVar "a" (m_in q_meas) + in + SmtCmd $ DefineFun (m_name q_meas) [ar] (m_out q_meas) (triv_out q_meas) + +-- | Returns True if given an SMT define fun command that uses all it's arguments. False otherwise +defineFunAllUsed :: Cmd -> Bool +defineFunAllUsed (SmtCmd (DefineFun _ sv _ t)) = allVariablesUsed sv t +defineFunAllUsed _ = False + +-- | Returns true if all the variable are used in the Term. False otherwise. +allVariablesUsed :: [SortedVar] -> Term -> Bool +allVariablesUsed svs t = + let + vs = map (\(SortedVar i _) -> ISymb i) svs + used = usedIdentifiers t + in + vs \\ used == [] + +usedIdentifiers :: Term -> [Identifier] +usedIdentifiers (TermIdent ind) = [ind] +usedIdentifiers (TermLit _) = [] +usedIdentifiers (TermCall _ ts) = mconcat $ map usedIdentifiers ts +usedIdentifiers (TermExists _ t) = usedIdentifiers t +usedIdentifiers (TermForAll _ t) = usedIdentifiers t +usedIdentifiers (TermLet vb t) = concatMap usedInVarBindings vb ++ usedIdentifiers t + +usedInVarBindings :: VarBinding -> [Identifier] +usedInVarBindings (VarBinding _ t) = usedIdentifiers t + +cmdToQualifs :: [QDataType] -> [QMeasure] -> Cmd -> String +cmdToQualifs dts meas (SmtCmd (DefineFun _ sv _ t)) = + let + sv_str = map sortedVarSymbol sv + sv_to_symb = M.fromList . zip sv_str $ map LH.symbol sv_str + + meas_names = map (nameOcc . strToName . m_name) meas + + lh_expr = termToLHExpr (MeasureSymbols $ map LH.symbol meas_names) sv_to_symb t + lh_expr_str = map (\c -> if c == '\n' then ' ' else c) $ show (pprintTidy Full lh_expr) + in + "qualif Qualif(" ++ bindSortedVars dts sv ++ ") : (" ++ lh_expr_str ++ ")" + +sortedVarSymbol :: SortedVar -> Symbol +sortedVarSymbol (SortedVar v _) = v + +bindSortedVars :: [QDataType] -> [SortedVar] -> String +bindSortedVars dts = intercalate ", " . map (bindSortedVar dts) + +bindSortedVar :: [QDataType] -> SortedVar -> String +bindSortedVar dts (SortedVar v srt) = v ++ ":" ++ sortString dts srt + +sortString :: [QDataType] -> Sort -> String +sortString dts (IdentSort (ISymb s)) + | Just dt <- find (\d -> s == dt_smt_name d) dts = dt_name dt + | otherwise = s +sortString _ _ = error "sortString: Unexpected sort" + + +------------------------------- +-- Various specific sorts +------------------------------- + +listSort :: Sort +listSort = IdentSort (ISymb "List") +-} diff --git a/src/G2/Liquid/Inference/Sygus.hs b/src/G2/Liquid/Inference/Sygus.hs new file mode 100644 --- /dev/null +++ b/src/G2/Liquid/Inference/Sygus.hs @@ -0,0 +1,7 @@ +module G2.Liquid.Inference.Sygus ( module G2.Liquid.Inference.Sygus.SimplifySygus + , module G2.Liquid.Inference.Sygus.LiaSynth + , module G2.Liquid.Inference.Sygus.UnsatCoreElim) where + +import G2.Liquid.Inference.Sygus.SimplifySygus +import G2.Liquid.Inference.Sygus.LiaSynth +import G2.Liquid.Inference.Sygus.UnsatCoreElim diff --git a/src/G2/Liquid/Inference/Sygus/FCConverter.hs b/src/G2/Liquid/Inference/Sygus/FCConverter.hs new file mode 100644 --- /dev/null +++ b/src/G2/Liquid/Inference/Sygus/FCConverter.hs @@ -0,0 +1,299 @@ +{-# LANGUAGE OverloadedStrings #-} + +module G2.Liquid.Inference.Sygus.FCConverter ( NMExprEnv + , convertConstraints) where + +import G2.Language as G2 +import G2.Liquid.Types +import G2.Liquid.Inference.Config +import G2.Liquid.Inference.FuncConstraint +import G2.Liquid.Inference.G2Calls +import G2.Liquid.Inference.PolyRef +import G2.Liquid.Inference.Sygus.SpecInfo + +import qualified Data.HashMap.Lazy as HM +import qualified Data.List as L +import qualified Data.Map as M +import Data.Maybe +import Data.Tuple.Extra + +type ConvertExpr a = G2.Expr -> a +type AndF a = [a] -> a +type OrF a = [a] -> a +type NotF a = a -> a +type ImpliesF a = a -> a -> a + +type Func a = String -> [a] -> a +type KnownFunc a = String -> Integer -> Bool -> a +type ToBeFunc a = String -> Integer -> Bool -> a + +------------------------------------ +-- Building Formulas +------------------------------------ + +mkPreCall :: (InfConfigM m, ProgresserM m) => + ConvertExpr form + -> AndF form + -> Func form + -> KnownFunc form + -> ToBeFunc form + -> NMExprEnv + -> TypeEnv + -> Measures + -> MeasureExs + -> Evals (Integer, Bool) + -> M.Map Name SpecInfo + -> FuncCall + -> [HigherOrderFuncCall] + -> m form +mkPreCall convExpr andF funcF knownF toBeF eenv tenv meas meas_ex evals m_si fc@(FuncCall { funcName = n }) hcalls + | Just si <- M.lookup n m_si + , Just (ev_i, ev_b) <- lookupEvals fc (pre_evals evals) + , Just func_e <- HM.lookup (nameOcc n, nameModule n) eenv = do + sy_body <- mkPreSynthBody convExpr funcF eenv tenv meas meas_ex (s_syn_pre si) (argumentTypes func_e) fc hcalls + let fixed_body = knownF (s_known_pre_name si) ev_i ev_b + to_be_body = toBeF (s_to_be_pre_name si) ev_i ev_b + + case s_status si of + Synth -> return . andF $ fixed_body:sy_body + ToBeSynthed -> return $ andF [fixed_body, to_be_body] + Known -> return $ fixed_body + | otherwise = error "mkPreCall: specification not found" + +mkPreSynthBody :: (InfConfigM m, ProgresserM m) => + ConvertExpr form + -> Func form + -> NMExprEnv + -> TypeEnv + -> Measures + -> MeasureExs + -> [PolyBound SynthSpec] + -> [Type] + -> FuncCall + -> [HigherOrderFuncCall] + -> m [form] +mkPreSynthBody convExpr funcF eenv tenv meas meas_ex pre_spec func_ts (FuncCall { funcName = n, arguments = ars }) hcalls = do + let v_ars = filter (validArgForSMT . thd3) + . filter (\(_, t, _) -> not (isTyVar t)) + . assignNums 1 + $ zip func_ts ars + + sy_body_p <- mapM (\(si_pb, ts_es) -> + let + t_ars = map (\(_, t, e) -> (t, e)) $ init ts_es + + (i, l_rt, l_re) = last ts_es + re_pb = extractExprPolyBoundWithRoot l_re + rt_pb = extractTypePolyBound l_rt + + in + case (i, l_rt) of + (Just i', TyFun _ _) -> do -- error $ "HERE\npre_spec = " ++ show pre_spec ++ "\nts_es = " ++ show ts_es + let arg_tys = argumentTypes $ PresType l_rt + return_ty = returnType $ PresType l_rt + hcalls' = filter (\hfc -> nameOcc (funcName hfc) == nameOcc n && nameUnique (funcName hfc) == i') hcalls + clls <- mapM (mkHigherOrderCall convExpr funcF eenv tenv meas meas_ex (removeHead si_pb) arg_tys return_ty) hcalls' + return $ concat clls + _ -> formCalls convExpr funcF tenv meas meas_ex n t_ars si_pb re_pb rt_pb + ) . zip pre_spec . filter (not . null) $ L.inits v_ars + return $ concat sy_body_p + where + assignNums _ [] = [] + assignNums i ((t@(TyFun _ _), e):ts) = (Just i, t, e):assignNums (i + 1) ts + assignNums i ((t, e):ts) = (Nothing, t, e):assignNums i ts + +mkPostCall :: (InfConfigM m, ProgresserM m) => + ConvertExpr form + -> AndF form + -> Func form + -> KnownFunc form + -> ToBeFunc form + -> NMExprEnv + -> TypeEnv + -> Measures + -> MeasureExs + -> Evals (Integer, Bool) + -> M.Map Name SpecInfo + -> FuncCall + -> m form +mkPostCall convExpr andF funcF knownF toBeF eenv tenv meas meas_ex evals m_si fc@(FuncCall { funcName = n }) + | Just si <- M.lookup n m_si + , Just (ev_i, ev_b) <- lookupEvals fc (post_evals evals) + , Just func_e <- HM.lookup (nameOcc n, nameModule n) eenv = do + let fixed_body = knownF (s_known_post_name si) ev_i ev_b + to_be_body = toBeF (s_to_be_post_name si) ev_i ev_b + + sy_body <- mkPostSynthBody convExpr funcF tenv meas meas_ex (s_syn_post si) (argumentTypes func_e) (returnType func_e) fc + case s_status si of + Synth -> return . andF $ fixed_body:sy_body + ToBeSynthed -> return $ andF [fixed_body, to_be_body] + Known -> return $ fixed_body + | otherwise = error "mkPostCall: specification not found" + +mkPostSynthBody :: (InfConfigM m, ProgresserM m) => + ConvertExpr form + -> Func form + -> TypeEnv + -> Measures + -> MeasureExs + -> PolyBound SynthSpec + -> [Type] + -> Type + -> FuncCall + -> m [form] +mkPostSynthBody convExpr funcF tenv meas meas_ex post_spec func_ts ret_ty (FuncCall { funcName = n, arguments = ars, returns = ret }) = do + let v_ars = filter (\(t, _) -> not (isTyVar t)) + . filter (validArgForSMT . snd) + $ zip func_ts ars + + smt_ret = extractExprPolyBoundWithRoot ret + smt_ret_ty = extractTypePolyBound ret_ty + + formCalls convExpr funcF tenv meas meas_ex n v_ars post_spec smt_ret smt_ret_ty + +mkHigherOrderCall :: (InfConfigM m, ProgresserM m) => + ConvertExpr form + -> Func form + -> NMExprEnv + -> TypeEnv + -> Measures + -> MeasureExs + -> [PolyBound SynthSpec] + -> [Type] -- ^ Argument types + -> Type -- ^ Return Type + -> FuncCall + -> m [form] +mkHigherOrderCall convExpr funcF eenv tenv meas meas_ex pb_synth@(_:_) ar_ts ret_t fc = do + pre <- mkPreSynthBody convExpr funcF eenv tenv meas meas_ex (init pb_synth) ar_ts fc [] + post <- mkPostSynthBody convExpr funcF tenv meas meas_ex (last pb_synth) ar_ts ret_t fc + return $ pre ++ post +mkHigherOrderCall _ _ _ _ _ _ _ _ _ _ = return [] + +formCalls :: (InfConfigM m, ProgresserM m) => ConvertExpr form -> Func form -> TypeEnv -> Measures -> MeasureExs -> Name -> [(Type, Expr)] -> PolyBound SynthSpec -> PolyBound [Expr] -> PolyBound Type -> m [form] +formCalls convExpr funcF tenv meas meas_ex n v_ars si_pb re_pb rt_pb = do + MaxSize mx_meas <- maxSynthFormSizeM + inf_con <- infConfigM + let smt_ars = concatMap (uncurry (adjustArgsWithCare inf_con n convExpr (fromInteger mx_meas) tenv meas meas_ex)) v_ars + si_re_rt_pb = case filterPBByType snd $ zipPB re_pb rt_pb of + Just re_rt_pb -> zipWithPB (\x (y, z) -> (x, y, z)) si_pb re_rt_pb + Nothing -> zipWithPB (\x (y, z) -> (x, y, z)) si_pb $ PolyBound ([], headValue rt_pb) [] -- error $ "formCalls: impossible, the polybound should have already been filtered" ++ "\nsi_pb = " ++ show si_pb ++ "\nre_pb = " ++ show re_pb ++ "\nrt_pb = " ++ show rt_pb + return $ concatMap (\(psi, re, rt) -> + let + f_smt_ars = if null (sy_args psi) then [] else smt_ars + smt_r = map (adjustArgs convExpr (fromInteger mx_meas) tenv meas meas_ex rt) re + in + map (\r -> funcF (sy_name psi) $ take (length (sy_args psi)) f_smt_ars ++ take (length (sy_rets psi)) r) smt_r + ) $ extractValues si_re_rt_pb + +convertConstraints :: (InfConfigM m, ProgresserM m) => + ConvertExpr form + -> AndF form + -> OrF form + -> NotF form + -> ImpliesF form + -> Func form + -> KnownFunc form + -> ToBeFunc form + -> NMExprEnv + -> TypeEnv + -> Measures + -> MeasureExs + -> Evals (Integer, Bool) + -> M.Map Name SpecInfo + -> FuncConstraints + -> m [form] +convertConstraints convExpr andF orF notF impF funcF knownF toBeF eenv tenv meas meas_ex evals si fc = do + let fc' = toListFC fc + mapM (convertConstraint + convExpr + andF + orF + notF + impF + funcF + knownF + toBeF + eenv tenv meas meas_ex evals si) fc' + +convertConstraint :: (InfConfigM m, ProgresserM m) => + ConvertExpr form + -> AndF form + -> OrF form + -> NotF form + -> ImpliesF form + -> Func form + -> KnownFunc form + -> ToBeFunc form + -> NMExprEnv + -> TypeEnv + -> Measures + -> MeasureExs + -> Evals (Integer, Bool) + -> M.Map Name SpecInfo + -> FuncConstraint + -> m form +convertConstraint convExpr andF _ _ impF funcF knownF toBeF eenv tenv meas meas_ex evals si (Call All fc hcalls) = do + pre <- mkPreCall convExpr andF funcF knownF toBeF eenv tenv meas meas_ex evals si fc hcalls + post <- mkPostCall convExpr andF funcF knownF toBeF eenv tenv meas meas_ex evals si fc + return $ pre `impF` post +convertConstraint convExpr andF _ _ _ funcF knownF toBeF eenv tenv meas meas_ex evals si (Call Pre fc hcalls) = + mkPreCall convExpr andF funcF knownF toBeF eenv tenv meas meas_ex evals si fc hcalls +convertConstraint convExpr andF _ _ _ funcF knownF toBeF eenv tenv meas meas_ex evals si (Call Post fc _) = + mkPostCall convExpr andF funcF knownF toBeF eenv tenv meas meas_ex evals si fc +convertConstraint convExpr andF orF notF impF funcF knownF toBeF eenv tenv meas meas_ex evals si (AndFC fs) = + return . andF =<< mapM (convertConstraint convExpr andF orF notF impF funcF knownF toBeF eenv tenv meas meas_ex evals si) fs +convertConstraint convExpr andF orF notF impF funcF knownF toBeF eenv tenv meas meas_ex evals si (OrFC fs) = + return . orF =<< mapM (convertConstraint convExpr andF orF notF impF funcF knownF toBeF eenv tenv meas meas_ex evals si) fs +convertConstraint convExpr andF orF notF impF funcF knownF toBeF eenv tenv meas meas_ex evals si (ImpliesFC fc1 fc2) = do + lhs <- convertConstraint convExpr andF orF notF impF funcF knownF toBeF eenv tenv meas meas_ex evals si fc1 + rhs <- convertConstraint convExpr andF orF notF impF funcF knownF toBeF eenv tenv meas meas_ex evals si fc2 + return $ lhs `impF` rhs +convertConstraint convExpr andF orF notF impF funcF knownF toBeF eenv tenv meas meas_ex evals si (NotFC fc) = + return . notF =<< convertConstraint convExpr andF orF notF impF funcF knownF toBeF eenv tenv meas meas_ex evals si fc + +adjustArgs :: ConvertExpr form -> Int -> TypeEnv -> Measures -> MeasureExs -> Type -> G2.Expr -> [form] +adjustArgs convExpr mx_meas tenv meas meas_ex t = + map convExpr + . map adjustLits + . substMeasures mx_meas tenv meas meas_ex t + +substMeasures :: Int -> TypeEnv -> Measures -> MeasureExs -> Type -> G2.Expr -> [G2.Expr] +substMeasures mx_meas tenv meas meas_ex t e = + case typeToSort t of + Just _ -> [e] + Nothing -> + case HM.lookup e meas_ex of + Just es -> + let + -- Get a list of all measure/output pairs with usable types + es' = filter (isJust . typeToSort . returnType . snd) $ HM.toList es + -- Make sure that es's type is specific enough to be used with the measure + app_meas = applicableMeasures mx_meas tenv meas t + es'' = filter (\(ns, _) -> ns `HM.member` app_meas) es' + in + -- Sort to make sure we get the same order consistently + map snd $ L.sortBy (\(n1, _) (n2, _) -> compare n1 n2) es'' + Nothing -> [] + +adjustArgsWithCare :: InferenceConfig -> Name -> ConvertExpr form -> Int -> TypeEnv -> Measures -> MeasureExs -> Type -> G2.Expr -> [form] +adjustArgsWithCare inf_con n convExpr mx_meas tenv meas meas_ex t + | use_invs inf_con + , specialFunction n = + map convExpr + . map adjustLits + . (\e -> case typeToSort t of Just _ -> [e]; Nothing -> []) + | otherwise = adjustArgs convExpr mx_meas tenv meas meas_ex t + +adjustLits :: G2.Expr -> G2.Expr +adjustLits (App _ l@(Lit _)) = l +adjustLits e = e + +validArgForSMT :: G2.Expr -> Bool +validArgForSMT e = not (isLHDict e) && not (isType e) + where + isType (Type _) = True + isType _ = False + + isLHDict e_ + | (TyCon (Name n _ _ _) _):_ <- unTyApp (typeOf e_) = n == "lh" + | otherwise = False diff --git a/src/G2/Liquid/Inference/Sygus/LiaSynth.hs b/src/G2/Liquid/Inference/Sygus/LiaSynth.hs new file mode 100644 --- /dev/null +++ b/src/G2/Liquid/Inference/Sygus/LiaSynth.hs @@ -0,0 +1,1661 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +module G2.Liquid.Inference.Sygus.LiaSynth ( SynthRes (..) + , Size + , ModelNames (..) + , Iteration (..) + , liaSynth + + , MaxSize + , incrMaxSize + + , BlockedModels + , emptyBlockedModels + , insertBlockedModel + , blockedHashMap + , unionBlockedModels) where + +import G2.Data.Utils +import G2.Language as G2 +import qualified G2.Language.ExprEnv as E +import G2.Liquid.Interface +import G2.Liquid.Types +import G2.Liquid.Inference.Config +import G2.Liquid.Inference.FuncConstraint +import G2.Liquid.Inference.G2Calls +import G2.Liquid.Inference.GeneratedSpecs +import G2.Liquid.Inference.PolyRef +import G2.Liquid.Inference.UnionPoly +import G2.Liquid.Inference.Sygus.FCConverter +import G2.Liquid.Inference.Sygus.SpecInfo + +import G2.Solver as Solver + +import Control.Monad.IO.Class + +import Language.Haskell.Liquid.Types as LH hiding (SP, ms, isBool, diff, fresh) +import Language.Fixpoint.Types.Refinements as LH hiding (pAnd, pOr) +import qualified Language.Fixpoint.Types as LH +import qualified Language.Fixpoint.Types as LHF + +import qualified Data.HashMap.Lazy as HM +import qualified Data.HashSet as HS +import qualified Data.List as L +import qualified Data.Map as M +import Data.Maybe +import qualified Data.Text as T +import qualified Text.Builder as TB +import qualified Data.Text.IO as T + +data SynthRes = SynthEnv + GeneratedSpecs -- ^ The synthesized specifications + Size -- ^ The size that the synthesizer succeeded at + SMTModel -- ^ An SMTModel corresponding to the new specifications + BlockedModels -- ^ SMTModels that should be blocked in the future + | SynthFail FuncConstraints + +type Size = Integer + +data Iteration = FirstRound | AfterFirstRound + +liaSynth :: (InfConfigM m, ProgresserM m, MonadIO m, SMTConverter con) + => con -> Iteration -> [GhcInfo] -> LiquidReadyState -> Evals Bool -> MeasureExs + -> FuncConstraints + -> UnionedTypes + -> BlockedModels -- ^ SMT Models to block being returned by the synthesizer at various sizes + -> ToBeNames -> ToSynthNames -> m SynthRes +liaSynth con iter ghci lrs evals meas_ex fc ut blk_mdls to_be_ns ns_synth = do + + -- Figure out the type of each of the functions we need to synthesize + let eenv = buildNMExprEnv $ expr_env . state $ lr_state lrs + tenv = type_env . state $ lr_state lrs + tc = type_classes . state $ lr_state lrs + meas = lrsMeasures ghci lrs + + si <- buildSpecInfo eenv tenv tc meas ghci fc ut to_be_ns ns_synth + + liftIO . putStrLn $ "si = " ++ show si + + MaxSize max_sz <- maxSynthFormSizeM + + synth con iter ghci eenv tenv meas meas_ex evals si fc blk_mdls max_sz + +liaSynthOfSize :: (InfConfigM m, ProgresserM m) => Integer -> M.Map Name SpecInfo -> m (M.Map Name SpecInfo) +liaSynthOfSize sz m_si = do + inf_c <- infConfigM + MaxSize max_form_sz <- maxSynthFormSizeM + MaxSize max_coeff_sz <- maxSynthCoeffSizeM + let m_si' = + M.map (\si -> + let + s_syn_pre' = + map (mapPB + (\psi -> + psi { sy_coeffs = mkCNF (>= 1) sz (fromInteger max_form_sz) (sy_name psi) psi } + ) + ) (s_syn_pre si) + s_syn_post' = + mapPB (\psi -> + psi { sy_coeffs = mkCNF (>= 1) sz (fromInteger max_form_sz) (sy_name psi) psi } + ) (s_syn_post si) + in + si { s_syn_pre = s_syn_pre' -- (s_syn_pre si) { sy_coeffs = pre_c } + , s_syn_post = s_syn_post' -- (s_syn_post si) { sy_coeffs = post_c } + , s_max_coeff = if restrict_coeffs inf_c then 1 else max_coeff_sz }) m_si + return m_si' + where + +mkCNF :: (Int -> Bool) -> Integer -> Int -> String -> SynthSpec -> CNF +mkCNF prd sz ms s psi_ = + (if length (set_sy_args psi_) + length (set_sy_rets psi_) == 0 + then + [ + ( + s ++ "_c_coeff_act_" ++ show j + , + [ mkCoeffs prd s psi_ j k | k <- [1..sz] ] -- Ors + ) + | j <- [1..sz] ] -- Ands + else []) + ++ + (if length (set_sy_args psi_) + length (set_sy_rets psi_) > 0 + then + [ + ( + s ++ "_c_set_act_" ++ show j + , + [ mkSetForms prd ms s psi_ j k | k <- [1..sz] ] -- Ors + ) + | j <- [1..sz] ] -- Ands + else []) + ++ + (if length (bool_sy_args psi_) + length (bool_sy_rets psi_) > 0 + then + [ + ( + s ++ "_c_bool_act_" ++ show j + , + [ mkBoolForms prd sz ms s psi_ j k | k <- [1..sz] ] -- Ors + ) + | j <- [1..sz] ] -- Ands + else []) + + +mkCoeffs :: (Int -> Bool) -> String -> SynthSpec -> Integer -> Integer -> Forms +mkCoeffs prd s psi j k = + let + ars = length (int_sy_args psi) + rets = length (int_sy_rets psi) + in + LIA + { + c_active = s ++ "_f_act_" ++ show j ++ "_t_" ++ show k + , c_op_branch1 = s ++ "_lia_op1_" ++ show j ++ "_t_" ++ show k + , c_op_branch2 = s ++ "_lia_op2_" ++ show j ++ "_t_" ++ show k + , b0 = s ++ "_b_" ++ show j ++ "_t_" ++ show k + + -- We only want solutions that have one or more return values with a + -- non-zero coefficient. Thus, if we have no return values, we + -- don't need to consider any arguments + , ars_coeffs = + if prd rets + then + [ s ++ "_a_c_" ++ show j ++ "_t_" ++ show k ++ "_a_" ++ show a + | a <- [1..ars]] + else + [] + , rets_coeffs = + [ s ++ "_r_c_" ++ show j ++ "_t_" ++ show k ++ "_a_" ++ show a + | a <- [1..rets]] + } + +mkSetForms :: (Int -> Bool) -> Int -> String -> SynthSpec -> Integer -> Integer -> Forms +mkSetForms prd max_sz s psi j k = + let + int_ars = length (int_sy_args psi) + int_rets = length (int_sy_rets psi) + + ars = length (set_sy_args psi) + rets = length (set_sy_rets psi) + + max_sets = min (ars + rets + int_ars + int_rets) 2 -- + max_sz - 1 + in + Set + { + c_active = s ++ "_s_act_" ++ show j ++ "_t_" ++ show k + , c_op_branch1 = s ++ "_set_op1_" ++ show j ++ "_t_" ++ show k + , c_op_branch2 = s ++ "_set_op2_" ++ show j ++ "_t_" ++ show k + + , int_sing_set_bools_lhs = + if prd rets + then + [ + [ s ++ "_a_set_sing_lhs_" ++ show j ++ "_t_" ++ show k + ++ "_a_" ++ show a ++ "_int_" ++ show inter | inter <- [1..int_ars + int_rets]] + | a <- [1..max_sets]] + else + [] + + , int_sing_set_bools_rhs = + if prd rets + then + [] + {- [ + [ s ++ "_a_set_sing_rhs_" ++ show j ++ "_t_" ++ show k + ++ "_a_" ++ show a ++ "_int_" ++ show inter | inter <- [1..int_ars + int_rets]] + | a <- [1..ars + rets + max_sz - 1]] -} + else + [] + + , ars_bools_lhs = + if prd rets + then + [ + [ s ++ "_a_set_lhs_" ++ show j ++ "_t_" ++ show k + ++ "_a_" ++ show a ++ "_int_" ++ show inter | inter <- [1..ars]] + | a <- [1..max_sets]] + else + [] + , rets_bools_lhs = + [ [ s ++ "_r_set_lhs_" ++ show j ++ "_t_" ++ show k + ++ "_a_" ++ show a ++ "_int_" ++ show inter | inter <- [1..rets]] + | a <- [1..ars + rets + max_sz - 1]] + + , ars_bools_rhs = + if prd rets + then + [ [ s ++ "_a_set_rhs_" ++ show j ++ "_t_" ++ show k + ++ "_a_" ++ show a ++ "_int_" ++ show inter | inter <- [1..ars]] + | a <- [1..max_sets]] + else + [] + , rets_bools_rhs = + [[ s ++ "_r_set_rhs_" ++ show j ++ "_t_" ++ show k + ++ "_a_" ++ show a ++ "_int_" ++ show inter | inter <- [1..rets]] + | a <- [1..max_sets]] + } + +mkBoolForms :: (Int -> Bool) -> Integer -> Int -> String -> SynthSpec -> Integer -> Integer -> Forms +mkBoolForms prd sz max_sz s psi j k = + let + ars = length (bool_sy_args psi) + rets = length (bool_sy_rets psi) + in + BoolForm + { + c_active = s ++ "_bool_act_" ++ show j ++ "_t_" ++ show k + , c_op_branch1 = s ++ "_bool_op1_" ++ show j ++ "_t_" ++ show k + , c_op_branch2 = s ++ "_bool_op2_" ++ show j ++ "_t_" ++ show k + + , ars_bools = + if prd rets + then + [ s ++ "_a_bool_" ++ show j ++ "_t_" ++ show k ++ "_a_" ++ show a + | a <- [1..ars]] + else + [] + , rets_bools = + [ s ++ "_r_bool_" ++ show j ++ "_t_" ++ show k ++ "_a_" ++ show a + | a <- [1..rets]] + + , forms = concat + . map snd + $ mkCNF (const True) sz max_sz (s ++ "_bool_" ++ show j ++ "_t_" ++ show k ++ "_" ) + (psi { sy_args = filter (not . isBool . smt_sort) (sy_args psi) + , sy_rets = filter (not . isBool . smt_sort) (sy_rets psi) }) + } + where + isBool SortBool = True + isBool _ = False + +synth :: (InfConfigM m, ProgresserM m, MonadIO m, SMTConverter con) + => con + -> Iteration + -> [GhcInfo] + -> NMExprEnv + -> TypeEnv + -> Measures + -> MeasureExs + -> Evals Bool + -> M.Map Name SpecInfo + -> FuncConstraints + -> BlockedModels + -> Size + -> m SynthRes +synth con iter ghci eenv tenv meas meas_ex evals si fc blk_mdls sz = do + si' <- liaSynthOfSize sz si + let zero_coeff_hdrs = softCoeffAssertZero si' ++ softClauseActAssertZero si' -- ++ softFuncActAssertZero si' + -- zero_coeff_hdrs = softFuncActAssertZero si' ++ softClauseActAssertZero si' + -- zero_coeff_hdrs = softCoeffAssertZero si' -- softFuncActAssertZero si' ++ softClauseActAssertZero si' + + max_coeffs_cons = maxCoeffConstraints si' + soft_coeff_cons = softCoeffConstraints si' + + soft_set_bool_cons = softSetConstraints si' + + mdls = lookupBlockedModels sz blk_mdls + rel_mdls = map (uncurry (filterModelToRel si')) mdls + block_mdls = map blockModelDirectly rel_mdls + + non_equiv_mdls = lookupNonEquivBlockedModels sz blk_mdls + rel_non_equiv_mdls = map (uncurry (filterModelToRel si')) non_equiv_mdls + fun_block_mdls = concatMap (uncurry (blockModelWithFuns si')) $ zip (map show ([0..] :: [Integer])) rel_non_equiv_mdls + + ex_assrts1 = [Comment "enforce maximal and minimal values for coefficients"] + ++ max_coeffs_cons + + ex_assrts2 = [Comment "favor making coefficients 0"] + ++ zero_coeff_hdrs + ++ [Comment "favor coefficients being -1, 0, or 1"] + ++ soft_coeff_cons + ++ [Comment "favor set booleans being false"] + ++ soft_set_bool_cons + ++ [Comment "block spurious models"] + ++ block_mdls + + ex_assrts = ex_assrts1 ++ ex_assrts2 + + drop_if_unknown = [Comment "stronger blocking of spurious models"] ++ fun_block_mdls + + MaxSize max_sz <- maxSynthFormSizeM + + res <- synth' con ghci eenv tenv meas meas_ex evals si' fc ex_assrts drop_if_unknown blk_mdls sz + case res of + SynthEnv _ _ n_mdl _ -> do + new <- checkModelIsNewFunc con si' n_mdl non_equiv_mdls + case new of + Nothing -> return res + Just (_, eq_mdl) -> do + let sys = concatMap allSynthSpec $ M.elems si' + rel_n_mdl = filterIrrelByConstruction sys n_mdl + rel_eq_mdl = filterIrrelByConstruction sys eq_mdl + + mn = determineRelSynthSpecs si' rel_n_mdl rel_eq_mdl + mdls' = foldr (\n -> insertEquivBlockedModel sz (MNOnlySMTNames [n]) n_mdl) blk_mdls mn + + liftIO . putStrLn $ "mn = " ++ show mn + synth con iter ghci eenv tenv meas meas_ex evals si fc mdls' sz + SynthFail _ + | sz < max_sz -> synth con iter ghci eenv tenv meas meas_ex evals si fc blk_mdls (sz + 1) + | FirstRound <- iter -> do + no_max_res <- synth' con ghci eenv tenv meas meas_ex evals si' fc ex_assrts2 drop_if_unknown blk_mdls sz + case no_max_res of + SynthEnv gs _ _ _ -> do + let lits = concatMap exprIntegers $ allExprs gs + max_lit = maximum $ map abs lits + setMaxSynthCoeffSizeM (MaxSize max_lit) + return no_max_res + _ -> return no_max_res + | otherwise -> return res + +synth' :: (InfConfigM m, ProgresserM m, MonadIO m, SMTConverter con) + => con + -> [GhcInfo] + -> NMExprEnv + -> TypeEnv + -> Measures + -> MeasureExs + -> Evals Bool + -> M.Map Name SpecInfo + -> FuncConstraints + -> [SMTHeader] + -> [SMTHeader] + -> BlockedModels + -> Size + -> m SynthRes +synth' con ghci eenv tenv meas meas_ex evals m_si fc headers drop_if_unknown blk_mdls sz = do + let n_for_m = namesForModel m_si + let consts = arrayConstants m_si + (constraints, nm_fc_map) <- nonMaxCoeffConstraints ghci eenv tenv meas meas_ex evals m_si fc + let hdrs = SetLogic ALL:consts ++ constraints ++ headers ++ drop_if_unknown + + liftIO $ if not (null drop_if_unknown) then putStrLn "non empty drop_if_unknown" else return () + + result <- return . adjustRes =<< runConstraintsForSynth hdrs n_for_m + + case result of + SAT mdl -> do + let gs' = modelToGS m_si mdl + liftIO $ print gs' + return (SynthEnv gs' sz mdl blk_mdls) + UNSAT uc -> + let + fc_uc = fromSingletonFC . NotFC . AndFC . map (nm_fc_map HM.!) $ HS.toList uc + in + return (SynthFail fc_uc) + Unknown _ maybe_mdl + | not (null drop_if_unknown) -> + synth' con ghci eenv tenv meas meas_ex evals m_si fc headers [] blk_mdls sz + | Just mdl <- maybe_mdl -> do + liftIO $ putStrLn "Unknown model!" + let gs' = modelToGS m_si mdl + liftIO $ print gs' + return (SynthEnv gs' sz mdl blk_mdls) + | otherwise -> error "synth': Unknown" + where + adjustRes (SAT m) = SAT m + adjustRes (UNSAT uc) = UNSAT uc + adjustRes (Unknown e ()) = Unknown e Nothing + +runConstraintsForSynth :: (InfConfigM m, MonadIO m) + => [SMTHeader] -> [(SMTName, Sort)] -> m (Result SMTModel UnsatCore ()) +runConstraintsForSynth headers vs = do + inf_con <- infConfigM + if use_binary_minimization inf_con + then do + z3_dir <- liftIO $ getZ3 100000 + z3_max <-liftIO $ mkMaximizeSolver =<< getZ3 50000 + + liftIO $ setProduceUnsatCores z3_dir + liftIO $ setProduceUnsatCores z3_max + + -- liftIO $ T.putStrLn (TB.run $ toSolverText headers) + liftIO $ addFormula z3_dir headers + liftIO $ addFormula z3_max headers + + liftIO $ checkSatInstr z3_dir + liftIO $ checkSatInstr z3_max + + res <- liftIO $ waitForRes2 Nothing Nothing z3_dir z3_max vs + + liftIO $ closeIO z3_dir + liftIO $ closeIO z3_max + + return res + else do + z3_dir <- liftIO $ getZ3 100000 + + liftIO $ setProduceUnsatCores z3_dir + liftIO $ addFormula z3_dir headers + liftIO $ checkSatInstr z3_dir + + res <- liftIO $ waitForRes z3_dir vs + + liftIO $ closeIO z3_dir + + return res + +waitForRes2 :: (SMTConverter s1, SMTConverter s2) => + Maybe (Result () () ()) -- ^ Nothing, or an unknown returned by Solver 1 + -> Maybe (Result () () ()) -- ^ Nothing, or an unknown returned by Solver 2 + -> s1 + -> s2 + -> [(SMTName, Sort)] + -> IO (Result SMTModel UnsatCore ()) +waitForRes2 m_res1 m_res2 s1 s2 vs = do + res1 <- maybe (maybeCheckSatResult s1) (return . Just) m_res1 + res2 <- maybe (maybeCheckSatResult s2) (return . Just) m_res2 + + case (res1, res2) of + (Just res1', _) | isSatOrUnsat res1' -> do + putStrLn $ "res1 = " ++ show res1 + putStrLn $ "res2 = " ++ show res2 + getModelOrUnsatCore s1 vs res1' + (_, Just res2') | isSatOrUnsat res2' -> do + putStrLn $ "res1 = " ++ show res1 + putStrLn $ "res2 = " ++ show res2 + getModelOrUnsatCore s2 vs res2' + (Just (Unknown err1 ()), Just (Unknown err2 ())) -> do + return $ Unknown (err1 ++ "\n" ++ err2) () + _ -> waitForRes2 res1 res2 s1 s2 vs + where + isSatOrUnsat (SAT _) = True + isSatOrUnsat (UNSAT _) = True + isSatOrUnsat _ = False + +waitForRes :: SMTConverter s => + s + -> [(SMTName, Sort)] + -> IO (Result SMTModel UnsatCore ()) +waitForRes s vs = do + res <- maybeCheckSatResult s + + case res of + Just res' -> getModelOrUnsatCore s vs res' + _ -> waitForRes s vs + +getModelOrUnsatCore :: SMTConverter smt => smt -> [(SMTName, Sort)] -> Result () () () -> IO (Result SMTModel UnsatCore ()) +getModelOrUnsatCore con vs (SAT ()) = do + mdl <- getModelInstrResult con vs + return (SAT mdl) +getModelOrUnsatCore con _ (UNSAT ()) = do + uc <- getUnsatCoreInstrResult con + return (UNSAT uc) +getModelOrUnsatCore _ _ (Unknown err ()) = return (Unknown err ()) + +-- | Extract Integer literals from a LH expression +exprIntegers :: LHF.Expr -> [Integer] +exprIntegers (ESym _) = [] +exprIntegers (ECon (I i)) = [i] +exprIntegers (ECon _) = [] +exprIntegers (EVar _) = [] +exprIntegers (EApp e1 e2) = exprIntegers e1 ++ exprIntegers e2 +exprIntegers (ENeg e) = exprIntegers e +exprIntegers (EBin _ e1 e2) = exprIntegers e1 ++ exprIntegers e2 +exprIntegers (EIte e1 e2 e3) = exprIntegers e1 ++ exprIntegers e2 ++ exprIntegers e3 +exprIntegers (ECst e _) = exprIntegers e +exprIntegers (ELam _ e) = exprIntegers e +exprIntegers (ETApp e _) = exprIntegers e +exprIntegers (ETAbs e _) = exprIntegers e +exprIntegers (PAnd es) = concatMap exprIntegers es +exprIntegers (POr es) = concatMap exprIntegers es +exprIntegers (PNot e) = exprIntegers e +exprIntegers (PImp e1 e2) = exprIntegers e1 ++ exprIntegers e2 +exprIntegers (PIff e1 e2) = exprIntegers e1 ++ exprIntegers e2 +exprIntegers (PAtom _ e1 e2) = exprIntegers e1 ++ exprIntegers e2 +exprIntegers _ = error "exprIntegers: unsupported" + +------------------------------------ +-- Handling Models +------------------------------------ + +---------------------------------------------------------------------------- +-- Blocking Models directly +data BlockedModels = Block { blocked :: HM.HashMap Size [(ModelNames, SMTModel)] + , blocked_equiv :: HM.HashMap Size [(ModelNames, SMTModel)] -- ^ Models that should be blocked, and represent the same specification as a model in `blocked` + } + deriving (Show) + +data ModelNames = MNAll | MNOnly [Name] | MNOnlySMTNames [SMTName] + deriving (Eq, Show, Read) + +emptyBlockedModels :: BlockedModels +emptyBlockedModels = Block HM.empty HM.empty + +insertBlockedModel :: Size -> ModelNames -> SMTModel -> BlockedModels -> BlockedModels +insertBlockedModel sz mdl_nms mdl blk_mdls = + blk_mdls { blocked = HM.insertWith (++) sz [(mdl_nms, mdl)] (blocked blk_mdls) } + +insertEquivBlockedModel :: Size -> ModelNames -> SMTModel -> BlockedModels -> BlockedModels +insertEquivBlockedModel sz mdl_nms mdl blk_mdls = + blk_mdls { blocked_equiv = HM.insertWith (++) sz [(mdl_nms, mdl)] (blocked_equiv blk_mdls) } + +lookupBlockedModels :: Size -> BlockedModels -> [(ModelNames, SMTModel)] +lookupBlockedModels sz blk_mdls = + HM.lookupDefault [] sz (blocked blk_mdls) ++ HM.lookupDefault [] sz (blocked_equiv blk_mdls) + +lookupNonEquivBlockedModels :: Size -> BlockedModels -> [(ModelNames, SMTModel)] +lookupNonEquivBlockedModels sz blk_mdls = + HM.lookupDefault [] sz (blocked blk_mdls) + +blockedHashMap :: BlockedModels -> HM.HashMap Size [(ModelNames, SMTModel)] +blockedHashMap blk_mdls = HM.unionWith (++) (blocked blk_mdls) (blocked_equiv blk_mdls) + +unionBlockedModels :: BlockedModels -> BlockedModels -> BlockedModels +unionBlockedModels bm1 bm2 = + Block { blocked = HM.unionWith (++) (blocked bm1) (blocked bm2) + , blocked_equiv = HM.unionWith (++) (blocked_equiv bm1) (blocked_equiv bm2) } + +---------------------------------------------------------------------------- +-- Blocking Models building/manipulation + +namesForModel :: M.Map Name SpecInfo -> [(SMTName, Sort)] +namesForModel = concat . map siNamesForModel . M.elems + +siNamesForModel :: SpecInfo -> [(SMTName, Sort)] +siNamesForModel si + | s_status si == Synth = concatMap sySpecNamesForModel $ allSynthSpec si + | otherwise = [] + +sySpecNamesForModel :: SynthSpec -> [(SMTName, Sort)] +sySpecNamesForModel sys = + let + all_coeffs = zip (sySpecGetCoeffs sys) (repeat SortInt) + all_set_bools = zip (sySpecGetSetBools sys) (repeat SortBool) + all_bool_bools = zip (sySpecGetBoolBools sys) (repeat SortBool) + all_acts = zip (sySpecGetActs sys) (repeat SortInt) + all_op_branch = zip (sySpecGetOpBranches sys) (repeat SortBool) + in + all_coeffs ++ all_set_bools ++ all_bool_bools ++ all_acts ++ all_op_branch + +modelToGS :: M.Map Name SpecInfo -> SMTModel -> GeneratedSpecs +modelToGS m_si mdl = + let + lh_spec = M.map (\si -> buildLIA_LH si mdl) . M.filter (\si -> s_status si == Synth) $ m_si + in + M.foldrWithKey insertAssertGS emptyGS lh_spec + +-- | Generates an Assert that, when added to a formula with the relevant variables, +-- blocks it from returning the model +blockModelDirectly :: SMTModel -> SMTHeader +blockModelDirectly = Solver.Assert . (:!) . foldr (.&&.) (VBool True) . map (\(n, v) -> V n (sortOf v) := v) . M.toList + +-- | Filters a model to only those variable bindings relevant to the functions listed in the name bindings +filterModelToRel :: M.Map Name SpecInfo -> ModelNames -> SMTModel -> SMTModel +filterModelToRel m_si ns mdl = + let + sys = case ns of + MNAll -> concatMap allSynthSpec $ M.elems m_si + MNOnly ns' -> concatMap allSynthSpec $ mapMaybe (flip M.lookup m_si) ns' + MNOnlySMTNames ns' -> filter (\sy -> sy_name sy `elem` ns') + . concatMap allSynthSpec + $ M.elems m_si + vs = map fst $ concatMap sySpecNamesForModel sys + in + filterIrrelByConstruction sys $ M.filterWithKey (\n _ -> n `elem` vs) mdl + +filterIrrelByConstruction :: Foldable f => f SynthSpec -> SMTModel -> SMTModel +filterIrrelByConstruction = flip (foldr filterIrrelByConstruction') + +filterIrrelByConstruction' :: SynthSpec -> SMTModel -> SMTModel +filterIrrelByConstruction' sys = + filterClauseActiveBooleans sys + . filterCoeffActiveBooleans sys + . filterRelOpBranch sys + +-- If the clause level boolean is set to true, we remove all the +-- formula level active booleans, since the formulas are +-- irrelevant. +filterClauseActiveBooleans :: SynthSpec -> SMTModel -> SMTModel +filterClauseActiveBooleans si mdl = + let + clauses = sy_coeffs si + in + foldr (\(cl_act, cfs) mdl_ -> if + | M.lookup cl_act mdl_ == Just (VBool True) -> + foldr (\c -> M.delete (c_active c)) mdl_ cfs + | otherwise -> mdl_) mdl clauses + +-- If the formula level active booleans are set to false, we remove all the +-- coefficients in the formula, since the formula is now irrelevant. +filterCoeffActiveBooleans :: SynthSpec -> SMTModel -> SMTModel +filterCoeffActiveBooleans si mdl = + let + clauses = sy_coeffs si + cffs = concatMap snd clauses + in + foldr (\cf mdl_ -> if + | M.lookup (c_active cf) mdl_ == Just (VBool False) -> + foldr M.delete mdl_ (coeffs cf) + | otherwise -> mdl_) mdl cffs + + +filterRelOpBranch :: SynthSpec -> SMTModel -> SMTModel +filterRelOpBranch si mdl = + let + clauses = sy_coeffs si + coeff_nms = concatMap snd clauses + in + -- If we are not using a clause, we don't care about c_op_branch1 and c_op_branch2 + -- If we are using a clause but c_op_branch1 is true, we don't care about c_op_branch2 + foldr (\form mdl_ -> if + | M.lookup (c_active form) mdl == Just (VBool False) -> + M.delete (c_op_branch2 form) $ M.delete (c_op_branch1 form) mdl_ + | M.lookup (c_op_branch1 form) mdl == Just (VBool True) -> + M.delete (c_op_branch2 form) mdl_ + | otherwise -> mdl) mdl coeff_nms + +-- | Create specification definitions corresponding to previously rejected models, +-- and add assertions that the new synthesized specification definition must +-- have a different output than the old specifications at at least one point. +-- Because this requires a symbolic point being input into the synthesized function +-- (with symbolic coefficients) this requires (undecidable) non linear arithmetic (NIA). +blockModelWithFuns :: M.Map Name SpecInfo -> String -> SMTModel -> [SMTHeader] +blockModelWithFuns si s mdl = + let + e_si = M.elems $ M.filter (\si' -> s_status si' == Synth) si + + vrs = map (uncurry blockVars) $ zip (map (\i -> s ++ "_" ++ show i) ([0..] :: [Integer])) e_si + var_defs = concatMap varDefs vrs + + si_nsi = map (\(i, si') -> (si', renameByAdding i si')) + . zip (map (\i -> s ++ "_" ++ show i) ([0..] :: [Integer])) + $ e_si + + fun_defs = concatMap (defineModelLIAFuns mdl . snd) si_nsi + + eqs = map (\(vs, (si', nsi')) -> mkEqualityAST vs si' nsi') $ zip vrs si_nsi + + neq = [Solver.Assert . (:!) $ mkSMTAnd eqs] + + in + var_defs ++ fun_defs ++ neq + +---------------------------------------------------------------------------- +-- Blocking Models via checking after the fact + +-- | Checks that the first model and each model in the list have at least +-- one point that they classifies differently, +-- i.e. for each model in the list, there must be at least one point that is +-- classified as true by that model, but false by the first model (or vice versa.) +-- As opposed to `blockModelWithFuns`, which enforced this as a constraint when +-- synthesizing the new specification, this function acts as a check on a newly +-- synthesized specification. +-- This avoids the need for non linear arithmetic, but allows us to quickly +-- reject newly synthesized specifications that are identical to some previous +-- specifications. +checkModelIsNewFunc :: (MonadIO m, SMTConverter con) => con -> M.Map Name SpecInfo -> SMTModel -> [(ModelNames, SMTModel)] -> m (Maybe (ModelNames, SMTModel)) +checkModelIsNewFunc _ _ _ [] = return Nothing +checkModelIsNewFunc con si mdl ((mdl_nm, mdl'):mdls) = do + b' <- checkModelIsNewFunc' con si mdl mdl' + case b' of + True -> checkModelIsNewFunc con si mdl mdls + False -> do + liftIO $ do + putStrLn "Equiv!" + print mdl_nm + print mdl + print mdl' + putStrLn $ "diff 1 = " ++ show (M.toList mdl' L.\\ M.toList mdl) + putStrLn $ "diff 2 = " ++ show (M.toList mdl L.\\ M.toList mdl') + return (Just (mdl_nm, mdl')) + +checkModelIsNewFunc' :: (MonadIO m, SMTConverter con) => con -> M.Map Name SpecInfo -> SMTModel -> SMTModel -> m Bool +checkModelIsNewFunc' con si mdl1 mdl2 = do + let e_si = M.elems $ M.filter (\si' -> s_status si' == Synth) si + + vrs = map (uncurry blockVars) $ zip (map (\i -> "_c_" ++ show i) ([0..] :: [Integer])) e_si + var_defs = concatMap varDefs vrs + + si_nsi = map (\(i, si') -> (si', renameByAdding i si')) + . zip (map (\i -> "_c_" ++ show i) ([0..] :: [Integer])) + $ e_si + + fun_defs1 = concatMap (defineModelLIAFuns mdl1 . fst) si_nsi + fun_defs2 = concatMap (defineModelLIAFuns mdl2 . snd) si_nsi + + eqs = map (\(vs, (si', nsi')) -> mkEqualityAST vs si' nsi') $ zip vrs si_nsi + + neq = [Solver.Assert . (:!) $ mkSMTAnd eqs] + + hdrs = arrayConstants si ++ var_defs ++ fun_defs1 ++ fun_defs2 ++ neq + + r <- liftIO $ checkConstraints con hdrs + case r of + SAT _ -> return True + UNSAT _ -> return False + -- If we get a result of Unknown, we might as well optimistically assume that the model is new + Unknown _ _ -> do + liftIO $ putStrLn "checkModelIsNewFunc' unknown result" + return True + +defineModelLIAFuns :: SMTModel -> SpecInfo -> [SMTHeader] +defineModelLIAFuns mdl si = + let + fs = L.nubBy (\si1 si2 -> sy_name si1 == sy_name si2) + $ (extractValues $ s_syn_post si) ++ (concatMap extractValues $ s_syn_pre si) + in + if s_status si == Synth + then map (defineModelLIAFuncSF mdl) fs + else [] + +defineModelLIAFuncSF :: SMTModel -> SynthSpec -> SMTHeader +defineModelLIAFuncSF mdl sf = + let + ars_nm = map smt_var (sy_args_and_ret sf) + ars = zip ars_nm (map smt_sort $ sy_args_and_ret sf) + in + DefineFun (sy_name sf) ars SortBool (buildLIA_SMT_fromModel mdl sf) + +renameByAdding :: String -> SpecInfo -> SpecInfo +renameByAdding i si = + si { s_syn_pre = map (mapPB rn) $ s_syn_pre si + , s_syn_post = mapPB rn $ s_syn_post si + } + where + rn s = s { sy_name = sy_name s ++ "_MDL_" ++ i } + +buildLIA_SMT_fromModel :: SMTModel -> SynthSpec -> SMTAST +buildLIA_SMT_fromModel mdl sf = + buildSpec (:+) (:*) (.=.) (.=.) (:>) (:>=) Ite Ite + mkSMTAnd mkSMTAnd mkSMTOr + mkSMTUnion mkSMTIntersection smtSingleton + mkSMTIsSubsetOf (flip ArraySelect) + vint VInt vbool vset + falseArray + trueArray + sf + where + vint n + | Just v <- M.lookup n mdl = v + | otherwise = V n SortInt + + vbool n + | Just v <- M.lookup n mdl = v + | otherwise = V n SortBool + + vset n + | Just v <- M.lookup n mdl = v + | otherwise = V n (SortArray SortInt SortBool) + +smtSingleton :: SMTAST -> SMTAST +smtSingleton mem = ArrayStore falseArray mem (VBool True) + +blockVars :: String -> SpecInfo -> ([PolyBound [(SMTName, Sort)]], PolyBound [(SMTName, Sort)]) +blockVars str si = ( map (uncurry mk_blk_vars) . zip (map show ([0..] :: [Integer])) $ s_syn_pre si + , mk_blk_vars "r" $ s_syn_post si) + where + mk_blk_vars i sy_s = + mapPB (\(j, s) -> + map (\(k, sa) -> + ("x_MDL_" ++ str ++ "_" ++ i ++ "_" ++ show j ++ "_" ++ show k, smt_sort sa)) + . zip ([0..] :: [Integer]) + $ sy_args_and_ret s + ) + $ zipPB (uniqueIds sy_s) sy_s + +varDefs :: ([PolyBound [(SMTName, Sort)]], PolyBound [(SMTName, Sort)]) -> [SMTHeader] +varDefs = map (\(n, srt) -> VarDecl (TB.text . T.pack $ n) srt) + . concat + . concatMap extractValues + . (\(x, y) -> y:x) + +mkEqualityAST :: ([PolyBound [(SMTName, Sort)]], PolyBound [(SMTName, Sort)]) -> SpecInfo -> SpecInfo -> SMTAST +mkEqualityAST (avs, rvs) si nsi = + let + avs' = map (mapPB (map fst)) avs + rvs' = mapPB (map fst) rvs + + pre_eq = + map (mapPB (uncurry3 mkFuncEq) . uncurry3 zip3PB) + $ zip3 avs' (s_syn_pre si) (s_syn_pre nsi) + + pre_eq' = concatMap extractValues pre_eq + + post_eq = + mapPB (uncurry3 mkFuncEq) $ zip3PB rvs' (s_syn_post si) (s_syn_post nsi) + + post_eq' = extractValues post_eq + in + mkSMTAnd (post_eq' ++ pre_eq') + +mkFuncEq :: [SMTName] -> SynthSpec -> SynthSpec -> SMTAST +mkFuncEq vs s_sp ns_sp = + let + smt_vs = map (flip V SortInt) vs + in + Func (sy_name s_sp) smt_vs := Func (sy_name ns_sp) smt_vs + +-- Determines which SynthSpecs have been assigned different values in the two models. +determineRelSynthSpecs :: M.Map Name SpecInfo -> SMTModel -> SMTModel -> [SMTName] +determineRelSynthSpecs m_si mdl1 mdl2 = + let + diff = M.keys + $ M.differenceWith (\v1 v2 -> case v1 == v2 of + True -> Nothing + False -> Just v1) mdl1 mdl2 + in + map sy_name + . filter + (\sys -> any (\n -> n `elem` diff) . map fst $ sySpecNamesForModel sys) + . concatMap allSynthSpec + $ M.elems m_si + +-- computing F_{Fixed}, i.e. what is the value of known specifications at known points +envToSMT :: Evals (Integer, Bool) -> M.Map Name SpecInfo -> Int -> FuncConstraints + -> ([SMTHeader], HM.HashMap SMTName FuncConstraint) +envToSMT evals si fresh fc = + let + nm_fc = zip ["f" ++ show i ++ "_" ++ show fresh | i <- ([1..] :: [Integer])] + . L.nub + . map fst + $ allCallsFC fc + + calls = concatMap (uncurry (flip (envToSMT' evals si))) nm_fc + + known_id_calls = map fst calls + real_calls = map snd calls + + assrts = map Solver.Assert known_id_calls + + in + (assrts, HM.fromList real_calls) + +envToSMT' :: Evals (Integer, Bool) -> M.Map Name SpecInfo -> FuncCall -> SMTName -> [(SMTAST, (SMTName, FuncConstraint))] +envToSMT' (Evals {pre_evals = pre_ev, post_evals = post_ev}) m_si fc@(FuncCall { funcName = f }) uc_n = + case M.lookup f m_si of + Just si -> + let + (pre_i, pre_res) = case lookupEvals fc pre_ev of + Just b -> b + Nothing -> error "envToSMT': pre not found" + + (post_i, post_res) = case lookupEvals fc post_ev of + Just b -> b + Nothing -> error "envToSMT': post not found" + + (pre_op, pre_op_fc) = if pre_res then (id, id) else ((:!), NotFC) + (post_op, post_op_fc) = if post_res then (id, id) else ((:!), NotFC) + + pre = pre_op $ Func (s_known_pre_name si) [VInt pre_i] + post = post_op $ Func (s_known_post_name si) [VInt post_i] + + pre_real = pre_op_fc (Call Pre fc []) + post_real = post_op_fc (Call Post fc []) + + pre_name = "pre_" ++ uc_n + post_name = "post_" ++ uc_n + + -- In the case that we get an unsat core, we are only interested in knowing which specifications + -- that have already been chosen must be changed. Thus, we only name those pieeces of the environment. + named_sp = case s_status si of + Known -> Named + _ -> \x _ -> x + in + [ (named_sp pre pre_name, (pre_name, pre_real)) + , (named_sp post post_name, (post_name, post_real))] + Nothing -> error "envToSMT': function not found" + +mkRetNonZero :: M.Map Name SpecInfo -> [SMTHeader] +mkRetNonZero = concatMap mkRetNonZero' . filter (\si -> s_status si == Synth) . M.elems + +mkRetNonZero' :: SpecInfo -> [SMTHeader] +mkRetNonZero' si = + let + sy_sps = allSynthSpec si + in + concatMap (\sys -> + let + cffs = sy_coeffs sys + in + map + (\(act, cff) -> + Solver.Assert (((:!) $ V act SortBool) + :=> + mkSMTOr (concatMap (\c -> mkCoeffRetNonZero c) cff)) + ) cffs + ) sy_sps + +mkCoeffRetNonZero :: Forms -> [SMTAST] +mkCoeffRetNonZero cffs@(LIA {}) = + let + act = c_active cffs + ret_cffs = rets_coeffs cffs + in + case null ret_cffs of + True -> [VBool True] + False -> + [V act SortBool :=> mkSMTOr (map (\r -> V r SortInt :/= VInt 0) ret_cffs)] +mkCoeffRetNonZero cffs@(Set {}) = + let + act = c_active cffs + ret_bools = concat $ rets_bools_lhs cffs ++ rets_bools_rhs cffs + in + case null ret_bools of + True -> [VBool True] + False -> + [V act SortBool :=> mkSMTOr (map (\r -> V r SortBool) ret_bools)] +mkCoeffRetNonZero cffs@(BoolForm {}) = + let + act = c_active cffs + ret_bools = rets_bools cffs + in + case null ret_bools of + True -> [VBool True] + False -> + [V act SortBool :=> mkSMTOr (map (\r -> (:!) (V r SortBool)) ret_bools)] + +-- This function aims to limit the number of different models that can be produced +-- that result in equivalent specifications. +-- This is important, because as a fallback when counterexamples are not +-- blocking bad solutions, we instead negate SMT models. So we want as +-- few different, but ultimately equivalent, models as possible. +-- In particualar: +-- (1) If the formula level active booleans are set to false, we force all the +-- coefficients in the formula to be 0, since the formula is now irrelevant. +-- (2) Similarly, if the clause level boolean is set to true, we force all the +-- formula level active booleans to be false, since the formulas are +-- irrelevant. +-- (3) If the n^th "or" is deactivated (by it's boolean being true), +-- then the n + 1^th "or" must also be deactivated +-- (4) If the n^th "and" is deactivated (by it's boolean being false), +-- then the n + 1^th "and" must also be deactivated +limitEquivModels :: M.Map Name SpecInfo -> [SMTHeader] +limitEquivModels m_si = + let + a_si = filter (\si -> s_status si == Synth) $ M.elems m_si + -- (1) + clauses = concatMap allCNFs a_si + cl_imp_coeff = concatMap + (\(cl_act, cff) -> + map (\cf -> V cl_act SortBool :=> ((:!) $ V (c_active cf) SortBool)) cff + ) clauses + + -- (2) + cffs = concatMap snd clauses + coeff_act_imp_zero = concatMap + (\cf -> + map (\c -> ((:!) $ V (c_active cf) SortBool) :=> (V c SortInt := VInt 0)) (coeffs cf) + ) cffs + + -- (3) + or_acts = map (map (map fst) . allCNFsSeparated) a_si :: [[[SMTName]]] + or_neighbors_deact = + concatMap + (concatMap + (map (\(n1, n2) -> ((:!) $ V n2 SortBool) :=> ((:!) $ V n1 SortBool)) . neighbors) + ) $ or_acts + + -- (4) + and_neighbors_deact = and_block (\case LIA {} -> True; _ -> False) a_si + ++ and_block (\case Set {} -> True; _ -> False) a_si + in + map Solver.Assert $ cl_imp_coeff ++ coeff_act_imp_zero -- ++ or_neighbors_deact ++ and_neighbors_deact + where + neighbors [] = [] + neighbors [_] = [] + neighbors (x:xs@(y:_)) = (x, y):neighbors xs + + and_block p a_si' = + let + and_acts = concatMap (map (map snd) . allCNFsSeparated) a_si' + in + concatMap + (concatMap + ( mapMaybe + (\(n1, n2) -> if p n1 && p n2 + then Just (V (c_active n2) SortBool :=> V (c_active n1) SortBool) + else Nothing) + . neighbors + ) + ) $ and_acts + +softCoeffAssertZero :: M.Map Name SpecInfo -> [SMTHeader] +softCoeffAssertZero = map (\n -> AssertSoft (V n SortInt := VInt 0) (Just "minimal_size")) . getCoeffs + +softFuncActAssertZero :: M.Map Name SpecInfo -> [SMTHeader] +softFuncActAssertZero = map (\n -> AssertSoft ((:!) $ V n SortBool) (Just "minimal_size")) . getFuncActs + +softClauseActAssertZero :: M.Map Name SpecInfo -> [SMTHeader] +softClauseActAssertZero = map (\n -> AssertSoft (V n SortBool) (Just "minimal_size")) . getClauseActs + +maxCoeffConstraints :: M.Map Name SpecInfo -> [SMTHeader] +maxCoeffConstraints = maxCoeffConstraints' Solver.Assert s_max_coeff + +softCoeffConstraints :: M.Map Name SpecInfo -> [SMTHeader] +softCoeffConstraints = maxCoeffConstraints' (flip Solver.AssertSoft (Just "coeff")) (const 1) + +maxCoeffConstraints' :: (SMTAST -> SMTHeader) -> (SpecInfo -> Integer) -> M.Map Name SpecInfo -> [SMTHeader] +maxCoeffConstraints' to_header max_c = + map to_header + . concatMap + (\si -> + let + cffs = concatMap coeffs . concatMap snd $ allPreCoeffs si ++ allPostCoeffs si + in + if s_status si == Synth + then map (\c -> (Neg (VInt (max_c si)) :<= V c SortInt) + .&&. (V c SortInt :<= VInt (max_c si))) cffs + else []) . M.elems + +softSetConstraints :: M.Map Name SpecInfo -> [SMTHeader] +softSetConstraints = + map (\n -> AssertSoft ((:!) (V n SortBool)) (Just "minimal_sets")) . getSetBools + +arrayConstants :: M.Map Name SpecInfo -> [SMTHeader] +arrayConstants si = + let + frms = concatMap allForms $ M.elems si + in + if any (\case Set {} -> True; _ -> False) frms + then + [ VarDecl (TB.text "true_array") (SortArray SortInt SortBool) + , Solver.Assert (trueArray := (mkSMTUniversalArray SortInt SortBool)) + , VarDecl (TB.text "false_array") (SortArray SortInt SortBool) + , Solver.Assert (falseArray := (mkSMTEmptyArray SortInt SortBool))] + else [] + +trueArray :: SMTAST +trueArray = V "true_array" (SortArray SortInt SortBool) + +falseArray :: SMTAST +falseArray = V "false_array" (SortArray SortInt SortBool) + +nonMaxCoeffConstraints :: (InfConfigM m, ProgresserM m) => [GhcInfo] -> NMExprEnv -> TypeEnv -> Measures -> MeasureExs -> Evals Bool -> M.Map Name SpecInfo -> FuncConstraints + -> m ([SMTHeader], HM.HashMap SMTName FuncConstraint) +nonMaxCoeffConstraints ghci eenv tenv meas meas_ex evals m_si fc = do + synth_fresh <- synthFreshM + incrSynthFreshM + let evals' = assignIds evals + + all_acts = getActs m_si + all_coeffs = getCoeffs m_si + all_set_bools = getSetBools m_si + all_bool_bools = getBoolBools m_si + get_ops = getOpBranches m_si + + var_act_hdrs = map (flip VarDecl SortBool . TB.text . T.pack) $ L.nub all_acts + var_int_hdrs = map (flip VarDecl SortInt . TB.text . T.pack) $ L.nub all_coeffs + var_bool_set_hdrs = map (flip VarDecl SortBool . TB.text . T.pack) $ L.nub all_set_bools + var_bool_bool_hdrs = map (flip VarDecl SortBool . TB.text . T.pack) $ L.nub all_bool_bools + var_op_hdrs = map (flip VarDecl SortBool . TB.text . T.pack) $ L.nub get_ops + + def_funs = concatMap defineLIAFuns $ M.elems m_si + (env_smt, nm_fc) = envToSMT evals' m_si synth_fresh fc + + ret_is_non_zero = mkRetNonZero m_si + + lim_equiv_smt = limitEquivModels m_si + + poly_access = polyAccessConstraints2 ghci meas m_si + + fc_smt <- constraintsToSMT eenv tenv meas meas_ex evals' m_si fc + + return + ( var_act_hdrs + ++ var_int_hdrs + ++ var_bool_set_hdrs + ++ var_bool_bool_hdrs + ++ var_op_hdrs + ++ def_funs + ++ [Comment "encode specification constraints"] + ++ fc_smt + ++ [Comment "encode the environment"] + ++ env_smt + ++ [Comment "force return values to be nonzero"] + ++ ret_is_non_zero + ++ [Comment "block equivalent formulas"] + ++ lim_equiv_smt + ++ [Comment "polymorphic access constraints"] + ++ poly_access + , nm_fc) + +constraintsToSMT :: (InfConfigM m, ProgresserM m) => + NMExprEnv + -> TypeEnv + -> Measures + -> MeasureExs + -> Evals (Integer, Bool) + -> M.Map Name SpecInfo + -> FuncConstraints + -> m [SMTHeader] +constraintsToSMT eenv tenv meas meas_ex evals si fc = + return . map (Solver.Assert) =<< + convertConstraints + convertExprToSMT + (ifNotNull mkSMTAnd (VBool True)) + (ifNotNull mkSMTOr (VBool False)) + (:!) + (:=>) + Func + (\n i _ -> Func n [VInt i]) + (\n i _ -> Func n [VInt i]) + eenv tenv meas meas_ex evals si fc + where + ifNotNull _ def [] = def + ifNotNull f _ xs = f xs + +convertExprToSMT :: G2.Expr -> SMTAST +convertExprToSMT e = + case e of + (App (App (Data (DataCon _ _)) _) ls) + | Just is <- extractInts ls -> + foldr (\i arr -> ArrayStore arr (VInt i) (VBool True)) falseArray is + _ -> exprToSMT e + +extractInts :: G2.Expr -> Maybe [Integer] +extractInts (App (App (App (Data _ ) (Type _)) (App _ (Lit (LitInt i)))) xs) = + return . (i:) =<< extractInts xs +extractInts (App (Data _) _) = Just [] +extractInts _ = Nothing + +--- + +getCoeffs :: M.Map Name SpecInfo -> [SMTName] +getCoeffs = concatMap siGetCoeffs . M.elems + +sySpecGetCoeffsNoB :: SynthSpec -> [SMTName] +sySpecGetCoeffsNoB = concatMap coeffsNoB . concatMap snd . sy_coeffs + +siGetCoeffs :: SpecInfo -> [SMTName] +siGetCoeffs si + | s_status si == Synth = concatMap sySpecGetCoeffs $ allSynthSpec si + | otherwise = [] + +sySpecGetCoeffs :: SynthSpec -> [SMTName] +sySpecGetCoeffs = concatMap coeffs . concatMap snd . sy_coeffs + +getSetBools :: M.Map Name SpecInfo -> [SMTName] +getSetBools = concatMap siGetSetBools . M.elems + +siGetSetBools :: SpecInfo -> [SMTName] +siGetSetBools si + | s_status si == Synth = concatMap sySpecGetSetBools $ allSynthSpec si + | otherwise = [] + +sySpecGetSetBools :: SynthSpec -> [SMTName] +sySpecGetSetBools = concatMap setBools . concatMap snd . sy_coeffs + +getBoolBools :: M.Map Name SpecInfo -> [SMTName] +getBoolBools = concatMap siGetBoolBools . M.elems + +siGetBoolBools :: SpecInfo -> [SMTName] +siGetBoolBools si + | s_status si == Synth = concatMap sySpecGetBoolBools $ allSynthSpec si + | otherwise = [] + +sySpecGetBoolBools :: SynthSpec -> [SMTName] +sySpecGetBoolBools = concatMap boolBools . concatMap snd . sy_coeffs + +--- + +getOpBranches:: M.Map Name SpecInfo -> [SMTName] +getOpBranches = concatMap siGetOpBranches . M.elems + +siGetOpBranches :: SpecInfo -> [SMTName] +siGetOpBranches si + | s_status si == Synth = + concatMap sySpecGetOpBranches $ allSynthSpec si + | otherwise = [] + +sySpecGetOpBranches :: SynthSpec -> [SMTName] +sySpecGetOpBranches = concatMap sySpecGetOpBranchesForm . concatMap snd . sy_coeffs + +sySpecGetOpBranchesForm :: Forms -> [SMTName] +sySpecGetOpBranchesForm c@(BoolForm {}) = + [c_op_branch1 c, c_op_branch2 c] ++ concatMap sySpecGetOpBranchesForm (forms c) +sySpecGetOpBranchesForm c = [c_op_branch1 c, c_op_branch2 c] +--- + +sySpecGetActs :: SynthSpec -> [SMTName] +sySpecGetActs sys = sySpecGetClauseActs sys ++ sySpecGetFuncActs sys + +sySpecGetClauseActs :: SynthSpec -> [SMTName] +sySpecGetClauseActs = map fst . sy_coeffs + +sySpecGetFuncActs :: SynthSpec -> [SMTName] +sySpecGetFuncActs = concatMap formActives . concatMap snd . sy_coeffs + +getActs :: M.Map Name SpecInfo -> [SMTName] +getActs si = getClauseActs si ++ getFuncActs si + +getClauseActs :: M.Map Name SpecInfo -> [SMTName] +getClauseActs m_si = + concatMap siGetClauseActs $ M.elems m_si + +siGetClauseActs :: SpecInfo -> [SMTName] +siGetClauseActs si + | s_status si == Synth = map fst $ allCNFs si + | otherwise = [] + +getFuncActs :: M.Map Name SpecInfo -> [SMTName] +getFuncActs m_si = + concatMap siGetFuncActs $ M.elems m_si + +siGetFuncActs :: SpecInfo -> [SMTName] +siGetFuncActs si + | s_status si == Synth = concatMap formActives . concatMap snd $ allCNFs si + | otherwise = [] + +formActives :: Forms -> [SMTName] +formActives cffs@(BoolForm {}) = c_active cffs:concatMap formActives (forms cffs) +formActives cffs = [c_active cffs] + +defineLIAFuns :: SpecInfo -> [SMTHeader] +defineLIAFuns si = + (if s_status si == Synth + then + let + funcs = L.nubBy (\si1 si2 -> sy_name si1 == sy_name si2) + $ (extractValues $ s_syn_post si) ++ (concatMap extractValues $ s_syn_pre si) + in + map defineSynthLIAFuncSF funcs + else []) + ++ + [ defineFixedLIAFuncSF (s_known_pre si) + , defineFixedLIAFuncSF (s_known_post si) + , defineToBeFuncSF (s_to_be_pre si) + , defineToBeFuncSF (s_to_be_post si)] + +defineFixedLIAFuncSF :: FixedSpec -> SMTHeader +defineFixedLIAFuncSF fs = + DeclareFun (fs_name fs) [SortInt] SortBool + +defineToBeFuncSF :: ToBeSpec -> SMTHeader +defineToBeFuncSF tb = + DeclareFun (tb_name tb) [SortInt] SortBool + +defineSynthLIAFuncSF :: SynthSpec -> SMTHeader +defineSynthLIAFuncSF sf = + let + ars_nm = map smt_var (sy_args_and_ret sf) + ars = zip ars_nm (map smt_sort $ sy_args_and_ret sf) + in + DefineFun (sy_name sf) ars SortBool (buildLIA_SMT sf) + +------------------------------------ +-- Building LIA Formulas +------------------------------------ + +type Plus a = a -> a -> a +type Mult a = a -> a -> a +type EqF a b = a -> a -> b +type Gt a b = a -> a -> b +type GEq a b = a -> a -> b +type Ite b a = b -> a -> a -> a +type And b c = [b] -> c +type Or b = [b] -> b + +type IsSubsetOf a b = a -> a -> b +type IsMember a b = a -> a -> b + +type Union a = a -> a -> a +type Intersection a = a -> a -> a + +type Singleton a = a -> a + +type VInt a = SMTName -> a +type CInt a = Integer -> a +type VBool b = SMTName -> b +type VSet s = SMTName -> s +type EmptySet s = s +type UniversalSet s = s + +buildLIA_SMT :: SynthSpec -> SMTAST +buildLIA_SMT sf = + buildSpec (:+) (:*) (.=.) (.=.) (:>) (:>=) Ite Ite + mkSMTAnd mkSMTAnd mkSMTOr mkSMTUnion mkSMTIntersection smtSingleton + mkSMTIsSubsetOf (flip ArraySelect) + (flip V SortInt) VInt (flip V SortBool) (flip V $ SortArray SortInt SortBool) + falseArray + trueArray + sf + +-- Get a list of all LIA formulas. We raise these as high in a PolyBound as possible, +-- because checking leaves is more expensive. Also, checking leaves only happens if those +-- leaves exists, i.e. consider a refinement on the elements of a list [{x:a | p x}], +-- p is only checked in the nonempty case. +buildLIA_LH :: SpecInfo -> SMTModel -> [PolyBound LHF.Expr] +buildLIA_LH si mv = map (mapPB pAnd) {- . map (uncurry raiseSpecs) . zip synth_specs -} $ buildLIA_LH' si mv + where + pAnd xs = + case any (== PFalse) xs of + True -> PFalse + False -> PAnd $ filter (/= PTrue) xs + +buildLIA_LH' :: SpecInfo -> SMTModel -> [PolyBound [LH.Expr]] +buildLIA_LH' si mv = + let + post_ars = allPostSpecArgs si + + build ars = buildSpec ePlus eTimes + bEq bIff bGt bGeq + eIte eIte id + pAnd pOr + eUnion eIntersection eSingleton + bIsSubset bIsMember + (detVar ars) (ECon . I) (detBool ars) + (detSet ars) eEmptySet eUnivSet + pre = map (mapPB (\psi -> build (all_sy_args_and_ret psi) psi)) $ s_syn_pre si + post = mapPB (build post_ars) $ s_syn_post si + in + pre ++ [post] + where + detVar ars v + | Just (VInt c) <- M.lookup v mv = ECon (I c) + | Just sa <- L.find (\sa_ -> v == smt_var sa_) ars = lh_rep sa + | otherwise = error "detVar: variable not found" + + detBool ars v + | Just (VBool b) <- M.lookup v mv = if b then PTrue else PFalse + | Just sa <- L.find (\sa_ -> v == smt_var sa_) ars = lh_rep sa + | otherwise = error $ "detBool: variable not found" ++ " " ++ show v ++ "\nars = " ++ show ars + + detSet ars v + | Just sa <- L.find (\sa_ -> v == smt_var sa_) ars = lh_rep sa + | otherwise = error "detSet: variable not found" + + eTimes (ECon (I 0)) _ = ECon (I 0) + eTimes _ (ECon (I 0)) = ECon (I 0) + eTimes (ECon (I 1)) x = x + eTimes x (ECon (I 1)) = x + eTimes (ECon (I (-1))) x = ENeg x + eTimes x (ECon (I (-1))) = ENeg x + eTimes x y = EBin LH.Times x y + + ePlus (ECon (I 0)) x = x + ePlus x (ECon (I 0)) = x + ePlus x (ENeg y) = EBin LH.Minus x y + ePlus (ENeg x) y = EBin LH.Minus y x + ePlus (ENeg x) y = EBin LH.Minus y x + ePlus x (EBin LH.Times (ECon (I i)) y) | i < 0 = EBin LH.Minus x (EBin LH.Times (ECon (I $ - i)) y) + ePlus (EBin LH.Times (ECon (I i)) x) y | i < 0 = EBin LH.Minus y (EBin LH.Times (ECon (I $ - i)) x) + ePlus x y = EBin LH.Plus x y + + eIte PTrue x _ = x + eIte PFalse _ y = y + eIte _ _ _ = error "eIte: Should never have non-concrete bool" + + pAnd xs = + case any (== PFalse) xs of + True -> PFalse + False -> PAnd $ filter (/= PTrue) xs + + pOr xs = + case any (== PTrue) xs of + True -> PTrue + False -> POr $ filter (/= PFalse) xs + + bEq (ECon (I x)) (ECon (I y)) = + if x == y then PTrue else PFalse + bEq x y + | x == y = PTrue + | x == eUnivSet + , y == eUnivSet = PTrue + | x == eUnivSet || y == eUnivSet = PFalse + | EBin LH.Minus e1 e2 <- x + , ECon (I 0) <- y = PAtom LH.Eq e1 e2 + | otherwise = PAtom LH.Eq x y + + bIff x y + | x == y = PTrue + | otherwise = PIff x y + + + bGt (ECon (I x)) (ECon (I y)) = + if x > y then PTrue else PFalse + bGt x y + | x == y = PFalse + | EBin LH.Minus e1 e2 <- x + , ECon (I 0) <- y = PAtom LH.Gt e1 e2 + | otherwise = PAtom LH.Gt x y + + bGeq (ECon (I x)) (ECon (I y)) = + if x >= y then PTrue else PFalse + bGeq x y + | x == y = PTrue + | EBin LH.Minus e1 e2 <- x + , ECon (I 0) <- y = PAtom LH.Ge e1 e2 + | otherwise = PAtom LH.Ge x y + + eUnion x y + | x == eEmptySet = y + | y == eEmptySet = x + | x == eUnivSet = eUnivSet + | y == eUnivSet = eUnivSet + | x == y = x + | otherwise = EApp (EApp (EVar "Set_cup") x) y + + eIntersection x y + | x == eUnivSet = y + | y == eUnivSet = x + | x == eEmptySet = eEmptySet + | y == eEmptySet = eEmptySet + | x == y = x + | otherwise = EApp (EApp (EVar "Set_cap") x) y + + eSingleton = EApp (EVar "Set_sng") + + bIsSubset x y + | x == eEmptySet = PTrue + | y == eUnivSet = PTrue + | x == eUnivSet = PFalse + | x == y = PTrue + | otherwise = EApp (EApp (EVar "Set_sub") x) y + + bIsMember x y + | y == eEmptySet = PFalse + | y == eUnivSet = PTrue + | otherwise = EApp (EApp (EVar "Set_mem") x) y + + eEmptySet = EApp (EVar "Set_empty") (ECon (I 0)) + eUnivSet = EVar ("Set_univ") + +buildSpec :: Show b => Plus a + -> Mult a + -> EqF a b + -> EqF b b + -> Gt a b + -> GEq a b + -> Ite b b + -> Ite b a + -> And b c + -> And b b + -> Or b + + -> Union a + -> Intersection a + -> Singleton a + -> IsSubsetOf a b + -> IsMember a b + + -> VInt a + -> CInt a + -> VBool b + -> VSet a + -> EmptySet a + -> UniversalSet a + -> SynthSpec + -> c +buildSpec plus mult eq eq_bool gt geq ite ite_set mk_and_sp mk_and mk_or mk_union mk_intersection mk_sing is_subset is_member vint cint vbool vset cemptyset cunivset sf = + let + all_coeffs = sy_coeffs sf + lin_ineqs = map (\(cl_act, cl) -> vbool cl_act:map toLinInEqs cl) all_coeffs + in + mk_and_sp . map mk_or $ lin_ineqs + where + int_args = map smt_var (int_sy_args_and_ret sf) + set_args = map smt_var (set_sy_args_and_ret sf) + bool_args = map smt_var (bool_sy_args_and_ret sf) + + toLinInEqs (LIA { c_active = act + , c_op_branch1 = op_br1 + , c_op_branch2 = op_br2 + , b0 = b + , ars_coeffs = acs + , rets_coeffs = rcs }) = + let + sm = lia_form acs rcs + in + mk_and [vbool act, ite (vbool op_br1) + (sm `eq` vint b) + (ite (vbool op_br2) (sm `gt` vint b) + (sm `geq` vint b) + ) + ] + toLinInEqs (Set { c_active = act + + , int_sing_set_bools_lhs = int_sing_bools_lhs + , int_sing_set_bools_rhs = int_sing_bools_rhs + + , ars_bools_lhs = ars_b1 + , rets_bools_lhs = rets_b1 + , ars_bools_rhs = ars_b2 + , rets_bools_rhs = rets_b2 }) = + let + sm1 = set_form ars_b1 rets_b1 int_sing_bools_lhs + sm2 = set_form ars_b2 rets_b2 int_sing_bools_rhs + in + mk_and [vbool act, sm1 `eq` sm2] + toLinInEqs (BoolForm { c_active = act + , ars_bools = as + , rets_bools = rs + , forms = frms }) = + let + bb = zipWith (\x y -> mk_or [x, y]) (map vbool $ as ++ rs) (map vbool bool_args) + in + mk_and [vbool act, mk_and bb `eq_bool` mk_and (map toLinInEqs frms)] + + lia_form acs rcs = foldr plus (cint 0) + . map (uncurry mult) + $ zip (map vint $ acs ++ rcs) (map vint int_args) + + set_form ars rts is_bools = + let + sets = map vset set_args + ars_rts = map (map vbool) $ zipWith (++) ars rts + + ite_sets = map (zipWith (\s a -> ite_set a s cunivset) sets) ars_rts + + ints = map vint int_args + ite_sing_sets = map (:[]) $ map (foldr (\(i, b) -> ite_set (vbool b) (mk_sing i)) cunivset . zip ints) is_bools -- map (zipWith (\s a -> ite_set (vbool a) (mk_sing s) cunivset) ints) is_bools + + ite_sets' = if not (null ite_sing_sets) + then zipWith (++) ite_sets ite_sing_sets + else ite_sets + in + if not (null ite_sets') && any (not . null) ite_sets' + then foldr1 mk_union + . map (foldr1 mk_intersection) + $ ite_sets' + else cemptyset + -- foldr mk_union cemptyset + -- . map (\(b, s) -> ite_set b s cemptyset) + -- $ zip (map vbool $ ars ++ rts) (map vset set_args) + + +---------------------------------------------------------------------------- +-- Polymorphic access measures +-- A measure is a polymorphic access measure if it returns a value of a polymorphic type. +-- For example, `fst :: (a, b) -> a`. +-- Specifications that use both tuple style specs i.e. ( {x:Int > 0 }, Int) +-- and measure style specs i.e. { t:(Int, Int) | fst t > 0 } together can cause strange +-- errors from LH. Thus, we add softer assertions to, when possible, +-- avoid using polymorphic access measures. + +polyAccessConstraints2 :: [GhcInfo] -> Measures -> M.Map Name SpecInfo -> [SMTHeader] +polyAccessConstraints2 ghci meas = + let + pa_meas = getPolyAccessMeasures ghci meas + in + map (flip AssertSoft Nothing) + . polyAccessConstraints2' pa_meas + . M.filter (\si -> s_status si == Synth) + +polyAccessConstraints2' :: [(LH.Symbol, Type, Type)] -> M.Map Name SpecInfo -> [SMTAST] +polyAccessConstraints2' meas = concatMap (polyAccessConstraints2'' meas) . M.elems + +polyAccessConstraints2'' :: [(LH.Symbol, Type, Type)] -> SpecInfo -> [SMTAST] +polyAccessConstraints2'' meas si = + let + poly = allSynthSpecPoly si + in + concatMap (polyAccessConstraints2''' meas) $ concatMap extractValues poly + +polyAccessConstraints2''' :: [(LH.Symbol, Type, Type)] -> SynthSpec -> [SMTAST] +polyAccessConstraints2''' meas sys = + let + cffs = sySpecGetCoeffsNoB sys + ars_cffs = + if not (null (sy_args sys)) || not (null (sy_rets sys)) + then zip (cycle (sy_args sys ++ sy_rets sys)) cffs + else [] + in + concatMap (\(sy, c) -> if usesPolyAcc (lh_rep sy) + then [V c SortInt := VInt 0] + else []) ars_cffs + where + meas' = map (\(m, _, _) -> m) meas + + usesPolyAcc (EApp (EVar lh) e) = lh `elem` meas' || usesPolyAcc e + usesPolyAcc _ = False + +getPolyAccessMeasures :: [GhcInfo] -> Measures -> [(LH.Symbol, Type, Type)] +getPolyAccessMeasures ghci = + map (\(n, at, rt) -> (getLHMeasureName ghci n, at, rt)) + . mapMaybe (\(n, (t:ts, rt)) -> if null ts then Just (n, t, rt) else Nothing) + . HM.toList + . E.map' (\e -> (filter (not . isLHDict) $ anonArgumentTypes e, returnType e)) + . E.filter (isTyVar . returnType) + where + isLHDict t + | (TyCon (Name n _ _ _) _):_ <- unTyApp t = n == "lh" + | otherwise = False + +---------------------------------------------------------------------------- + +-- Helpers for SynthInfo +allSynthSpec :: SpecInfo -> [SynthSpec] +allSynthSpec si = allPreSynthSpec si ++ allPostSynthSpec si + +allPreSynthSpec :: SpecInfo -> [SynthSpec] +allPreSynthSpec = concatMap extractValues . s_syn_pre + +allPostSynthSpec :: SpecInfo -> [SynthSpec] +allPostSynthSpec = extractValues . s_syn_post + +allSynthSpecPoly :: SpecInfo -> [PolyBound SynthSpec] +allSynthSpecPoly si = s_syn_pre si ++ [s_syn_post si] + +allCNFs :: SpecInfo -> CNF +allCNFs si = allPreCoeffs si ++ allPostCoeffs si + +allPreCoeffs :: SpecInfo -> CNF +allPreCoeffs = concatMap sy_coeffs . allPreSynthSpec + +allPostCoeffs :: SpecInfo -> CNF +allPostCoeffs = concatMap sy_coeffs . allPostSynthSpec + +allPostSpecArgs :: SpecInfo -> [SpecArg] +allPostSpecArgs = concatMap sy_args_and_ret . allPostSynthSpec + +allCNFsSeparated :: SpecInfo -> [CNF] +allCNFsSeparated si = allPreCoeffsSeparated si ++ allPostCoeffsSeparated si + +allPreCoeffsSeparated :: SpecInfo -> [CNF] +allPreCoeffsSeparated = map sy_coeffs . allPreSynthSpec + +allPostCoeffsSeparated :: SpecInfo -> [CNF] +allPostCoeffsSeparated = map sy_coeffs . allPostSynthSpec + +allForms :: SpecInfo -> [Forms] +allForms = concatMap allFormsFromForm + . concatMap snd + . allCNFs + +allFormsFromForm :: Forms -> [Forms] +allFormsFromForm frm@(BoolForm { forms = frms }) = frm:concatMap allFormsFromForm frms +allFormsFromForm frm = [frm] diff --git a/src/G2/Liquid/Inference/Sygus/RefSynth.hs b/src/G2/Liquid/Inference/Sygus/RefSynth.hs new file mode 100644 --- /dev/null +++ b/src/G2/Liquid/Inference/Sygus/RefSynth.hs @@ -0,0 +1,1531 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} + +module G2.Liquid.Inference.Sygus.RefSynth ( -- refSynth + + -- , grammar + -- , intRuleList + -- , boolRuleList + + -- , intSort + -- , boolSort + + -- , termToLHExpr + + -- , runCVC4 + -- , runCVC4Stream + ) where + +-- import G2.Language.Expr +-- import qualified G2.Language.ExprEnv as E +-- import G2.Language.Naming +-- import G2.Language.Support +-- import G2.Language.Syntax as G2 +-- import G2.Language.TypeClasses +-- import G2.Language.Typing +-- import G2.Liquid.Conversion +-- import G2.Liquid.Helpers +-- import G2.Liquid.Interface +-- import G2.Liquid.Types +-- import G2.Liquid.Inference.Config +-- import G2.Liquid.Inference.FuncConstraint +-- import G2.Liquid.Inference.G2Calls +-- import G2.Liquid.Inference.GeneratedSpecs +-- import G2.Liquid.Inference.PolyRef +-- import G2.Liquid.Inference.Sygus.SimplifySygus +-- import G2.Liquid.Inference.Sygus.UnsatCoreElim + +-- import Sygus.LexSygus +-- import Sygus.ParseSygus +-- import Sygus.Print +-- import Sygus.Syntax as Sy +-- import Language.Haskell.Liquid.Types as LH +-- import Language.Haskell.Liquid.Types.RefType +-- import Language.Fixpoint.Types.Constraints +-- import Language.Fixpoint.Types.Refinements as LH +-- import qualified Language.Fixpoint.Types as LH +-- import qualified Language.Fixpoint.Types as LHF + +-- import Control.Exception +-- import Control.Monad.IO.Class +-- import qualified Control.Monad.State as S +-- import Data.Coerce +-- import Data.List +-- import Data.Hashable +-- import qualified Data.HashMap.Lazy as HM +-- import qualified Data.HashSet as HS +-- import qualified Data.Map as M +-- import Data.Maybe +-- import Data.Monoid +-- import Data.Ratio +-- import qualified Data.Text as T +-- import Data.Tuple +-- import Data.Tuple.Extra +-- import System.Directory +-- import System.IO +-- import System.IO.Temp +-- import qualified System.Process as P + +-- import TyCon +-- import qualified Var as V + +-- import Debug.Trace + +-- refSynth :: (InfConfigM m, MonadIO m) => [GhcInfo] -> LiquidReadyState -> MeasureExs +-- -> FuncConstraints -> Name -> m (Maybe ([PolyBound LH.Expr], [Qualifier])) +-- refSynth ghci lrs meas_ex fc n@(Name n' _ _ _) = undefined -- do +{- + let eenv = expr_env . state $ lr_state lrs + tc = type_classes . state $ lr_state lrs + + fc_of_n = lookupFC n fc + fspec = case genSpec ghci n of + Just spec' -> spec' + _ -> error $ "synthesize: No spec found for " ++ show n + e = case E.occLookup (nameOcc n) (nameModule n) eenv of + Just e' -> e' + Nothing -> error $ "synthesize: No expr found" + + meas = lrsMeasures ghci lrs + + liftIO . print $ "Synthesize spec for " ++ show n + let tcemb = foldr (<>) mempty $ map (gsTcEmbeds . spec) ghci + refSynth' fspec e tc meas meas_ex fc_of_n (measureSymbols ghci) tcemb + +refSynth' :: (InfConfigM m, MonadIO m) => SpecType -> G2.Expr -> TypeClasses -> Measures + -> MeasureExs -> [FuncConstraint] -> MeasureSymbols -> LH.TCEmb TyCon -> m (Maybe ([PolyBound LH.Expr], [Qualifier])) +refSynth' spc e tc meas meas_ex fc meas_sym tycons = do + infconfig <- infConfigM + liftIO $ do + putStrLn "refSynth" + let (call, f_num, arg_pb, ret_pb) = sygusCall e tc meas meas_ex fc + s_call = nub + . simplifyNegatedAnds + . simplifyImpliesExistentials + . elimNegatedExistential + . simplifyImpliesLHS + . splitAnds + . elimRedundantAnds $ call + (es_dt, s_call2) = elimSimpleDTs s_call + no_unsat_call = unsatCoreElim s_call2 + + let sygus = printSygus no_unsat_call + putStrLn . T.unpack $ sygus + + res <- runCVC4 infconfig (T.unpack sygus) + -- res <- runCVC4StreamSolutions infconfig f_num (T.unpack sygus) + + case res of + Left _ -> do + putStrLn "Timeout" + return Nothing + -- error "refSynth: Bad call to CVC4" + Right smt_st -> do + let smt_st' = restoreSimpleDTs es_dt smt_st + + putStrLn . T.unpack $ printSygus smt_st' + + let lh_st = refToLHExpr spc arg_pb ret_pb smt_st' meas_sym + lh_quals = refToQualifiers spc arg_pb ret_pb smt_st' meas_sym tycons + + print lh_st + print lh_quals + + return $ Just (lh_st, lh_quals) + +------------------------------- +-- Constructing Sygus Formula +------------------------------- + +sygusCall :: G2.Expr -> TypeClasses -> Measures -> MeasureExs -> [FuncConstraint] -> ([Cmd], Int, [RefNamePolyBound], RefNamePolyBound) +sygusCall e tc meas meas_ex fcs@(_:_) = + let + -- Figure out what measures we need to/can consider + (arg_ty_c, ret_ty_c, ex_ty_c) = generateRelTypes tc e + func_ty_c = arg_ty_c ++ [ret_ty_c] + all_ty_c = func_ty_c ++ ex_ty_c + + rel_arg_ty_c = filter relTy arg_ty_c + rel_fcs = map (relArgs tc arg_ty_c) fcs + + sorts = typesToSort meas meas_ex all_ty_c + + declare_dts = sortsToDeclareDTs sorts + + (grams, cons, arg_pb, ret_pb) = generateGrammarsAndConstraints sorts meas_ex rel_arg_ty_c ret_ty_c rel_fcs + + call = [ SmtCmd (SetLogic "ALL")] + ++ + declare_dts + ++ + [ safeModDecl + , clampIntDecl clampUpper + , clampDoubleDecl clampUpper ] + ++ + grams + ++ + cons + ++ + [ CheckSynth ] + in + (call, length grams, arg_pb, ret_pb) +sygusCall _ _ _ _ _ = error "sygusCall: empty list" + +applicableMeasures :: Measures -> Type -> [Name] +applicableMeasures meas t = + E.keys $ E.filter (applicableMeasure t) meas + +applicableMeasure :: Type -> G2.Expr -> Bool +applicableMeasure t e = + let + te = filter notLH . argumentTypes . PresType . inTyForAlls $ typeOf e + in + case te of + [te'] -> PresType t .:: te' + _ -> False + where + notLH ty + | TyCon (Name n _ _ _) _ <- tyAppCenter ty = n /= "lh" + | otherwise = False + +generateGrammarsAndConstraints :: TypesToSorts -> MeasureExs -> [Type] -> Type -> [FuncConstraint] -> ([Cmd], [Cmd], [RefNamePolyBound], RefNamePolyBound) +generateGrammarsAndConstraints sorts meas_ex arg_tys ret_ty fcs@(fc:_) = + let + ret_names = refinementNames "ret" (typeOf . returns $ constraint fc) + ret_gram_cmds = generateGrammars extGrammar sorts ret_names meas_ex arg_tys ret_ty + + arg_names_grams = generateParamRefGrammars fc sorts meas_ex arg_tys + (arg_names, arg_grams_cmds) = unzip arg_names_grams + + cons = generateConstraints sorts meas_ex arg_names ret_names arg_tys ret_ty fcs + in + (concat arg_grams_cmds ++ ret_gram_cmds, cons, arg_names, ret_names) + +refinementNames :: String -> G2.Type -> RefNamePolyBound +refinementNames prefix t = + let + poly_bd = extractTypePolyBound t + in + mapPB (\i -> prefix ++ "_refinement_" ++ show i) $ uniqueIds poly_bd + +generateParamRefGrammars :: FuncConstraint -> TypesToSorts -> MeasureExs -> [Type] -> [(RefNamePolyBound, [Cmd])] +generateParamRefGrammars fc sorts meas_ex arg_tys = + map (\(i, as@((_, a):_)) -> + let + arg_tys = map fst $ init as + ret_ty = fst $ last as + + arg_ref_names = refinementNames ("args_" ++ show i) ret_ty -- a + arg_gram_cmds = generateGrammars regGrammar sorts arg_ref_names meas_ex arg_tys ret_ty + in + (arg_ref_names, arg_gram_cmds)) + (zip [0..] . map (zip arg_tys) . filter (not . null) . inits . arguments $ constraint fc) + +generateGrammars :: GrammarGen -> TypesToSorts -> RefNamePolyBound -> MeasureExs -> [Type] -> Type -> [Cmd] +generateGrammars g sorts ref_names meas_ex arg_tys ret_ty = + let + rt_bound = extractTypePolyBound ret_ty + ns_rt = zipPB ref_names rt_bound + in + map (uncurry (generateSynthFun g sorts arg_tys)) + . filter (relTy . snd) + $ extractValues ns_rt + +generateSynthFun :: GrammarGen + -> TypesToSorts + -> [Type] -- ^ Argument types + -> String -- ^ Name of function to synthesize + -> Type -- ^ Return type + -> Cmd +generateSynthFun g sorts arg_tys n rt = + let + param_vars = generateParams sorts arg_tys + + ret_sort_var = SortedVar "r" (typeToSort sorts rt) + sort_vars = param_vars ++ [ret_sort_var] + + gram = g param_vars ret_sort_var sorts + in + SynthFun n sort_vars boolSort (Just gram) + +generateParams :: TypesToSorts -> [Type] -> [SortedVar] +generateParams sorts arg_tys = + let + varN = map (\i -> "x" ++ show i) ([0..] :: [Integer]) + in + map (uncurry SortedVar) . zip varN + . map (typeToSort sorts) . filter (not . isLHDict) $ arg_tys + where + isLHDict e + | (TyCon (Name n _ _ _) _):_ <- unTyApp e = n == "lh" + | otherwise = False + +------------------------------- +-- define-fun +------------------------------- + +-- We define a function safe-mod, which forces the denominator of mod to be positive. + +safeModSymb :: Symbol +safeModSymb = "safe-mod" + +safeModDecl :: Cmd +safeModDecl = + SmtCmd + . DefineFun safeModSymb [SortedVar "x" intSort, SortedVar "y" intSort] intSort + $ TermCall (ISymb "mod") + [ TermIdent (ISymb "x") + , TermCall (ISymb "+") [TermLit (LitNum 1), TermCall (ISymb "abs") [TermIdent (ISymb "y")]] + ] + +-- We define a function clamp, which forces (Constant sort) to fall only in a fixed range +clampIntSymb :: Symbol +clampIntSymb = clampSymb "int" + +clampIntDecl :: Integer -> Cmd +clampIntDecl = clampDecl clampIntSymb intSort + +clampDoubleSymb :: Symbol +clampDoubleSymb = clampSymb "double" + +clampDoubleDecl :: Integer -> Cmd +clampDoubleDecl = clampDecl clampDoubleSymb doubleSort + +clampSymb :: Symbol -> Symbol +clampSymb = (++) "clamp-" + +clampDecl :: Symbol -> Sort -> Integer -> Cmd +clampDecl fn srt mx = + SmtCmd + . DefineFun fn [SortedVar "x" srt] srt + $ TermCall (ISymb "ite") + [ TermCall (ISymb "<") [TermLit $ LitNum mx, TermIdent (ISymb "x")] + , TermLit $ LitNum mx + , TermCall (ISymb "ite") + [ TermCall (ISymb "<") [TermIdent (ISymb "x"), TermLit $ LitNum 0] + , TermLit $ LitNum 0 + , TermIdent (ISymb "x") + ] + ] + +clampUpper :: Num a => a +clampUpper = 5 + +------------------------------- +-- Grammar +------------------------------- + +type GrammarGen = [SortedVar] -> SortedVar -> TypesToSorts -> GrammarDef + +regGrammar :: GrammarGen +regGrammar = grammar intRuleList doubleRuleList + +extGrammar :: GrammarGen +extGrammar = grammar extIntRuleList extDoubleRuleList + +grammar :: [GTerm] -- Int Rules + -> [GTerm] -- Double Rules + -> GrammarGen +grammar intRules doubleRules arg_sort_vars ret_sorted_var@(SortedVar _ (IdentSort (ISymb ret_srt_symb))) sorts = + let + sorted_vars = arg_sort_vars ++ [ret_sorted_var] + + rel_to_ret = + case ret_srt_symb of + "Bool" -> arg_sort_vars + _ -> maybe [ret_sorted_var] meas_names $ lookupSortInfoBySort ret_srt_symb sorts + + sorts' = filterToSorts (map (\(SortedVar _ s) -> sortSymb s) sorted_vars) sorts + + gramNames = zip (map (\i -> "G" ++ show i) ([0..] :: [Integer])) (allSortNames sorts') + grams = map (\(g, s_symb) -> (g, IdentSort . ISymb $ s_symb)) gramNames + sortsToGN = HM.fromList $ map swap gramNames + + irl = GroupedRuleList "I" intSort + (intRules ++ addSelectors sortsToGN intSort sorts') + + clamp_int = GroupedRuleList "IClamp" intSort [GBfTerm $ BfIdentifierBfs (ISymb clampIntSymb) [BfIdentifier (ISymb "IConst")]] + + const_int = GroupedRuleList "IConst" intSort [GConstant intSort] + + (bool_int, decl_int, grl_int) = + adjustTypeUsage rel_to_ret + intSort + boolIntArgRuleList + [SortedVar "I" intSort, SortedVar "IClamp" intSort, SortedVar "IConst" intSort] + [ ("I", intRules, addSelectors sortsToGN intSort sorts') + , ("IClamp", [GBfTerm $ BfIdentifierBfs (ISymb clampIntSymb) [BfIdentifier (ISymb "IConst")]], []) + , ("IConst", [GConstant intSort], []) ] + + (bool_double, decl_double, grl_double) = + adjustTypeUsage rel_to_ret + doubleSort + boolDoubleArgRuleList + [SortedVar "D" doubleSort, SortedVar "DClamp" doubleSort, SortedVar "DConst" doubleSort] + [ ("D", doubleRules, addSelectors sortsToGN doubleSort sorts') + , ("DClamp", [GBfTerm $ BfIdentifierBfs (ISymb clampDoubleSymb) [BfIdentifier (ISymb "DConst")]], []) + , ("DConst", [GConstant doubleSort], []) ] + + bool_rl = boolTrueRuleList ++ if not (null bool_int) || not (null bool_double) + then boolOpRuleList + else [] + brl = GroupedRuleList "B" boolSort + (bool_rl ++ bool_int ++ bool_double + ++ addSelectors sortsToGN boolSort sorts') + + grm = GrammarDef + ([ SortedVar "B" boolSort ] + ++ decl_int + ++ decl_double + ++ map (uncurry SortedVar) grams) + ([ brl ] + ++ grl_int + ++ grl_double + ++ map (uncurry dtGroupRuleList) grams) + in + forceVarInGrammar ret_sorted_var arg_sort_vars grm + where + sortSymb (IdentSort (ISymb s)) = s + sortSymb _ = error "grammar: sortSymb" + +-- | Including doubles/ints in the grammar increases CVC4s runtime, and is not +-- needed if there are no variables of the given type, or selectors that return +-- the given type. This function checks if any variables/selectors exists, +-- and either returns the needed grammar elements if they do, or returns +-- empty lists if they do not. +adjustTypeUsage :: [SortedVar] -- ^ The function parameters + -> Sort -- ^ The type under consideration + -> [GTerm] -- ^ A set of terminals relating the given type to Bool + -> [SortedVar] -- ^ Declarations for the terminals for the given type + -> [(Symbol, [GTerm], [GTerm])] -- ^ The symbols, set(s) of default + -- terminals, and sets of selector terminals + -- for the given type + -> ( [GTerm] -- ^ The set of terminals to add to add to Bool + , [SortedVar] -- ^ Declarations for the terminals for the + -- given type to add to the grammar + , [GroupedRuleList] -- ^ The GRL(s) to add to the grammar + ) +adjustTypeUsage params srt bool_trms decls type_trms = + let + param_typs = filter (\(SortedVar _ s) -> s == srt) params + sels = concatMap (\(_, _, sel) -> sel) type_trms + + type_grl = map (\(s, def, sel) -> GroupedRuleList s srt (def ++ sel)) type_trms + in + if param_typs /= [] -- || sels /= [] + then (bool_trms, decls, type_grl) + else ([], [], []) + +-- For some reason, CVC4 seems better at handling * when both sides are intBf, +-- instead of one side being intConstBf +extIntRuleList :: [GTerm] +extIntRuleList = intRuleList ++ + [ GBfTerm $ BfIdentifierBfs (ISymb "*") [intBf, intBf] + , GBfTerm $ BfIdentifierBfs (ISymb safeModSymb) [intBf, intConstBf] + ] + +intRuleList :: [GTerm] +intRuleList = + [ GVariable intSort + , GBfTerm $ BfIdentifier (ISymb "IClamp") -- , GConstant intSort + , GBfTerm $ BfIdentifierBfs (ISymb "+") [intBf, intBf] + , GBfTerm $ BfIdentifierBfs (ISymb "-") [intBf, intBf] + ] + -- ++ [GBfTerm . BfLiteral . LitNum $ x | x <- [0..0]] + +extDoubleRuleList :: [GTerm] +extDoubleRuleList = doubleRuleList ++ [GBfTerm $ BfIdentifierBfs (ISymb "*") [doubleConstBf, doubleBf]] + +doubleRuleList :: [GTerm] +doubleRuleList = + [ GVariable doubleSort + , GBfTerm $ BfIdentifier (ISymb "DClamp") -- GConstant doubleSort + , GBfTerm $ BfIdentifierBfs (ISymb "+") [doubleBf, doubleBf] + , GBfTerm $ BfIdentifierBfs (ISymb "-") [doubleBf, doubleBf] + ] + -- ++ [GBfTerm . BfLiteral . LitNum $ x | x <- [0..0]] + +boolRuleList :: [GTerm] +boolRuleList = boolDefRuleList ++ boolIntArgRuleList ++ boolDoubleArgRuleList + +boolDefRuleList :: [GTerm] +boolDefRuleList = + boolTrueRuleList ++ boolOpRuleList + +boolTrueRuleList :: [GTerm] +boolTrueRuleList = + [ + -- (GConstant boolSort) is significantly slower than just enumerating the bools + -- , GConstant boolSort + GBfTerm $ BfLiteral (LitBool True) + ] + +boolOpRuleList :: [GTerm] +boolOpRuleList = + [ GVariable boolSort + + , GBfTerm $ BfIdentifierBfs (ISymb "=>") [boolBf, boolBf] + , GBfTerm $ BfIdentifierBfs (ISymb "and") [boolBf, boolBf] + -- , GBfTerm $ BfIdentifierBfs (ISymb "or") [boolBf, boolBf] + , GBfTerm $ BfIdentifierBfs (ISymb "not") [boolBf] + ] + +boolIntArgRuleList :: [GTerm] +boolIntArgRuleList = + [ GBfTerm $ BfIdentifierBfs (ISymb "=") [intBf, intBf] + , GBfTerm $ BfIdentifierBfs (ISymb "<") [intBf, intBf] + , GBfTerm $ BfIdentifierBfs (ISymb "<=") [intBf, intBf] + ] + +boolDoubleArgRuleList :: [GTerm] +boolDoubleArgRuleList = + [ GBfTerm $ BfIdentifierBfs (ISymb "=") [doubleBf, doubleBf] + , GBfTerm $ BfIdentifierBfs (ISymb "<") [doubleBf, doubleBf] + , GBfTerm $ BfIdentifierBfs (ISymb "<=") [doubleBf, doubleBf] + ] + +elimHigherOrderArgs :: FuncConstraint -> FuncConstraint +elimHigherOrderArgs fc = + let + cons = constraint fc + as = arguments cons + as' = filter (not . isTyFun . typeOf) as + in + fc { constraint = cons { arguments = as' }} + +dtGroupRuleList :: Symbol -> Sort -> GroupedRuleList +dtGroupRuleList symb srt = GroupedRuleList symb srt [GVariable srt] + +intBf :: BfTerm +intBf = BfIdentifier (ISymb "I") + +intConstBf :: BfTerm +intConstBf = BfIdentifier (ISymb "IConst") + +doubleBf :: BfTerm +doubleBf = BfIdentifier (ISymb "D") + +doubleConstBf :: BfTerm +doubleConstBf = BfIdentifier (ISymb "DConst") + +boolBf :: BfTerm +boolBf = BfIdentifier (ISymb "B") + +intSort :: Sort +intSort = IdentSort (ISymb "Int") + +doubleSort :: Sort +doubleSort = IdentSort (ISymb "Real") + +boolSort :: Sort +boolSort = IdentSort (ISymb "Bool") + + +charSort :: Sort +charSort = IdentSort (ISymb "String") + +relArgs :: TypeClasses -> [Type] -> FuncConstraint -> FuncConstraint +relArgs tc ts fc = + let + cons = constraint fc + as = filter (relArg tc) $ arguments cons + ts_as = zip ts as + as' = map snd $ filter (relTy . fst) ts_as + in + fc { constraint = cons { arguments = as' }} + +relArg :: TypeClasses -> G2.Expr -> Bool +relArg tc e = (not . isTypeClass tc . typeOf $ e) && (not . isType $ e) + where + isType (Type _) = True + isType _ = False + +type ArgTys = [Type] +type RetType = Type +type PolyTypes = [Type] + +generateRelTypes :: TypeClasses -> G2.Expr -> (ArgTys, RetType, PolyTypes) +generateRelTypes tc e = + let + ty_e = PresType $ inTyForAlls (typeOf e) + arg_ty_c = filter (not . isTYPE) + . filter (not . isTypeClass tc) + $ argumentTypes ty_e + ret_ty_c = returnType ty_e + + ex_ty_c = concatMap unTyApp $ ret_ty_c:arg_ty_c + in + (arg_ty_c, ret_ty_c, ex_ty_c) + +-- | Is the given type usable by SyGuS? +relTy :: Type -> Bool +relTy (TyVar _) = False +relTy (TyFun _ _) = False +relTy _ = True + + +------------------------------- +-- Constraints +------------------------------- + +-- | Constraints expresessed as "anded" terms +data TermConstraint = TC { pos_term :: Bool, tc_violated :: Violated, param_ret_connector :: Symbol, param_terms :: [Term], ret_terms :: [Term] } + deriving (Show, Read) + +modifyParamTC :: ([Term] -> [Term]) -> TermConstraint -> TermConstraint +modifyParamTC f tc = tc { param_terms = f (param_terms tc) } + +modifyRetTC :: ([Term] -> [Term]) -> TermConstraint -> TermConstraint +modifyRetTC f tc = tc { ret_terms = f (ret_terms tc) } + +-- | Convert constraints. Measures cause us to lose information about the data, so after +-- conversion we can have a constraint both postively and negatively. We know that the postive +-- constraint corresponds to an actual execution, so we keep that one, adnd drop the negative constraint. + +generateConstraints :: TypesToSorts -> MeasureExs -> [RefNamePolyBound] -> RefNamePolyBound -> [Type] -> Type -> [FuncConstraint] -> [Cmd] +generateConstraints sorts meas_ex arg_poly_names ret_poly_names arg_tys ret_ty fcs = + let + cons = map (termConstraints sorts meas_ex arg_poly_names ret_poly_names arg_tys ret_ty) fcs + cons' = cons -- filterPosAndNegConstraints cons + cons'' = map termConstraintToConstraint cons' + + exists_args = concatMap (\(pn, ars) -> existentialConstraints sorts meas_ex pn (init ars) (last ars)) + $ zip arg_poly_names (filter (not . null) $ inits arg_tys) + exists_ret = existentialConstraints sorts meas_ex ret_poly_names arg_tys ret_ty + in + {- exists_args ++ exists_ret ++ -} cons'' + +-- | Prevents any refinements from being set to "False" (or equivalent, i.e. 0 < 0) +existentialConstraints :: TypesToSorts -> MeasureExs -> RefNamePolyBound -> [Type] -> Type -> [Cmd] +existentialConstraints sorts meas_ex poly_names arg_tys ret_ty = + let + rt_bound = extractTypePolyBound ret_ty + ns_rt = zipPB rt_bound poly_names + in + mapMaybe (fmap Constraint . uncurry (existentialTerms sorts meas_ex arg_tys)) $ extractValues ns_rt + + +existentialTerms :: TypesToSorts -> MeasureExs -> [Type] -> Type -> String -> Maybe Term +existentialTerms _ _ _ (TyVar _) _ = Nothing +existentialTerms sorts meas_ex arg_tys ret_ty fn = + let + ar_vs = map (\(i, t) -> ("arg" ++ show i, typeToSort sorts t)) $ zip [0..] (arg_tys) + srt_v = ("e_ret", typeToSort sorts ret_ty) + in + Just . TermExists (map (uncurry SortedVar) $ srt_v:ar_vs) + $ TermCall (ISymb fn) (map (TermIdent . ISymb . fst) ar_vs ++ [TermIdent (ISymb "e_ret")]) + +termConstraints :: TypesToSorts -> MeasureExs -> [RefNamePolyBound] -> RefNamePolyBound -> [Type] -> Type -> FuncConstraint -> TermConstraint +termConstraints sorts meas_ex arg_poly_names ret_poly_names arg_tys ret_ty (FC { polarity = p + , violated = v + , bool_rel = br + , constraint = fc }) = + TC { pos_term = p == Pos + , tc_violated = v + , param_ret_connector = if br == BRAnd then "and" else "=>" + , param_terms = funcParamTerms sorts meas_ex arg_poly_names arg_tys (arguments fc) + , ret_terms = funcCallRetTerm sorts meas_ex ret_poly_names arg_tys ret_ty (arguments fc) (returns fc) } + +-- When polymorphic arguments are instantiated with values, we use those as +-- arguments for the polymorphic refinement functions. However, even when they +-- do not have values, we still want to enforce that (for some value) the polymorphic +-- refinement function is true. Thus, given arguments a_1, ..., a_n, we need to add +-- an expression of the form: +-- exists x . r(a_1, ..., a_n, x) + +data ValOrExistential v = Val v | Existential + +funcParamTerms :: TypesToSorts -> MeasureExs -> [RefNamePolyBound] -> [Type] -> [G2.Expr] -> [Term] +funcParamTerms sorts meas_ex poly_names arg_tys ars = + let + inits_arg_tys = filter (not . null) $ inits arg_tys + init_ars = filter (not . null) $ inits ars + in + concatMap (\(pn, at, as) -> + funcCallTerm sorts meas_ex pn (init at) (last at) (init as) (last as) + ) + $ zip3 poly_names inits_arg_tys init_ars + +funcCallRetTerm :: TypesToSorts -> MeasureExs -> RefNamePolyBound -> [Type] -> Type -> [G2.Expr] -> G2.Expr -> [Term] +funcCallRetTerm _ _ _ _ _ _ (Prim Error _) = [TermLit $ LitBool True] +funcCallRetTerm sorts meas_ex poly_names arg_tys ret_ty ars r = funcCallTerm sorts meas_ex poly_names arg_tys ret_ty ars r + +funcCallTerm :: TypesToSorts -> MeasureExs -> RefNamePolyBound -> [Type] -> Type -> [G2.Expr] -> G2.Expr -> [Term] +funcCallTerm sorts meas_ex poly_names arg_tys ret_ty ars r = + let + r_bound = extractExprPolyBoundWithRoot r + rt_bound = extractTypePolyBound ret_ty + ns_r_bound = zip3PB r_bound rt_bound poly_names + ns_r_bound' = concatMap expand1 (extractValues ns_r_bound) + in + mapMaybe (\(r, rt, n) -> funcCallTerm' sorts meas_ex arg_tys ars r rt n) $ ns_r_bound' -- r + where + expand1 :: ([a], b, c) -> [(ValOrExistential a, b, c)] + expand1 ([], b, c) = [(Existential, b, c)] + expand1 (as, b, c) = map (\a -> (Val a, b, c)) as + +funcCallTerm' :: TypesToSorts -> MeasureExs -> [Type] -> [G2.Expr] -> ValOrExistential G2.Expr -> Type -> String -> Maybe Term +funcCallTerm' sorts meas_ex arg_tys ars r ret_ty fn + | Val r' <- r + , relTy ret_ty = + let + trm_ret = exprToTerm sorts meas_ex ret_ty r' + in + Just $ TermCall (ISymb fn) (trm_ars ++ [trm_ret]) + | Existential <- r + , relTy ret_ty = + let + srt_v = SortedVar "e_ret" $ typeToSort sorts ret_ty + in + Just . TermExists [srt_v] $ TermCall (ISymb fn) (trm_ars ++ [TermIdent (ISymb "e_ret")]) + | otherwise = Nothing + where + trm_ars = map (uncurry (exprToTerm sorts meas_ex)) (zip arg_tys ars) + +exprToTerm :: TypesToSorts -> MeasureExs -> Type -> G2.Expr -> Term +exprToTerm _ _ (TyCon (Name "Bool" _ _ _) _) (Data (DataCon (Name n _ _ _) _)) + | "True" <- n = TermLit $ LitBool True + | "False" <- n =TermLit $ LitBool False +exprToTerm _ _ (TyCon (Name n _ _ _) _) (App _ (Lit l)) + | n == "Int" + || n == "Float" + || n == "Double" + || n == "Char" = litToTerm l +exprToTerm _ _ _ (Lit l) = litToTerm l +exprToTerm sorts meas_ex t e = exprToDTTerm sorts meas_ex t e +exprToTerm _ _ _ e = error $ "exprToTerm: Unhandled Expr " ++ show e + +litToTerm :: G2.Lit -> Term +litToTerm (LitInt i) = TermLit (LitNum i) +litToTerm (LitDouble d) = TermCall (ISymb "/") [ TermLit . LitNum $ numerator d + , TermLit . LitNum $ denominator d] +litToTerm (LitChar c) = TermLit (LitStr [c]) +litToTerm _ = error "litToTerm: Unhandled Lit" + +exprToDTTerm :: TypesToSorts -> MeasureExs -> Type -> G2.Expr -> Term +exprToDTTerm sorts meas_ex t e = + case lookupSort t sorts of + Just si + | not . null $ meas_names si -> + TermCall (ISymb (dt_name si)) $ map (measVal sorts meas_ex e) (meas_names si) + | otherwise -> TermIdent (ISymb (dt_name si)) + Nothing -> error $ "exprToDTTerm: No sort found" ++ "\nsorts = " ++ show sorts ++ "\nt = " ++ show t ++ "\ne = " ++ show e + +filterPosAndNegConstraints :: [TermConstraint] -> [TermConstraint] +filterPosAndNegConstraints ts = + let + tre = concatMap ret_terms $ filter isForcedRet ts + in + filter (\t -> (not . null $ ret_terms t) || param_ret_connector t == "=>" || tc_violated t == Pre) + $ map (\t -> if pos_term t || param_ret_connector t == "=>" then t else modifyRetTC (filter (not . flip elem tre)) t) ts + where + -- Does ths post-condition HAVE to hold? + isForcedRet t = pos_term t && param_ret_connector t == "and" + +termConstraintToConstraint :: TermConstraint -> Cmd +termConstraintToConstraint (TC p v pr_con param_ts ret_ts) = + let + param_tc = case param_ts of + [] -> TermLit (LitBool True) + _ -> TermCall (ISymb "and") param_ts + ret_tc = case ret_ts of + [] -> TermLit (LitBool True) + _ -> TermCall (ISymb "and") ret_ts + ret_tc' = case p of + True -> ret_tc + False -> TermCall (ISymb "not") [ret_tc] + tc = TermCall (ISymb pr_con) [param_tc, ret_tc'] + in + Constraint tc + +typeToSort :: TypesToSorts -> Type -> Sort +typeToSort _ (TyCon (Name n _ _ _) _) + | n == "Int" = intSort + | n == "Double" = doubleSort + | n == "Bool" = boolSort + | n == "Char" = charSort +typeToSort sm t + | Just si <- lookupSort t sm = IdentSort (ISymb $ sort_name si) +typeToSort sm t = error $ "Unknown Type\n" ++ show t ++ "\nsm = " ++ show sm + +------------------------------- +-- Measures +------------------------------- + +measVal :: TypesToSorts -> MeasureExs -> G2.Expr -> SortedVar -> Term +measVal sorts meas_ex e (SortedVar mn _) = + let + meas_n = strToName mn + in + case HM.lookup e meas_ex of + Just meas_out + | Just (_, v) <- find (\(n', _) -> nameOcc meas_n == nameOcc n') meas_out -> exprToTerm sorts meas_ex (typeOf v) v + Nothing -> error $ "measVal: Expr not found\nmeas_ex = " ++ show meas_ex ++ "\ne = " ++ show e + +newtype TypesToSorts = TypesToSorts { types_to_sorts :: [(Type, SortInfo)] } + deriving (Show, Read) + +data SortInfo = SortInfo { sort_name :: Symbol + , dt_name :: Symbol + , meas_names :: [SortedVar]} + deriving (Show, Read) + +typesToSort :: Measures -> MeasureExs -> [Type] -> TypesToSorts +typesToSort meas meas_ex ty_c = + let + rel_ty_c = filter relTy ty_c + + rel_ty_c' = nubBy (\t1 t2 -> t1 .::. t2) rel_ty_c + dt_ts = filter (not . isPrimTy) rel_ty_c' + + ns = concatMap (map fst) . HM.elems $ meas_ex + applic_meas = map (applicableMeasures meas) dt_ts + applic_meas' = map (filter (\m -> m `elem` ns)) applic_meas + meas_ids = map (map (\n -> Id n (returnType (case E.lookup n meas of + Just e -> e + Nothing -> error "sygusCall: No type found")))) applic_meas' + + meas_ids' = filterNonPrimMeasure meas_ids + + ts_applic_meas = zip dt_ts meas_ids' + in + typesToSort' ts_applic_meas + +isPrimTy :: Type -> Bool +isPrimTy (TyCon (Name "Int" _ _ _) _) = True +isPrimTy (TyCon (Name "Double" _ _ _) _) = True +isPrimTy (TyCon (Name "Bool" _ _ _) _) = True +isPrimTy _ = False + +typesToSort' :: [(Type, [Id])] -> TypesToSorts +typesToSort' ts = + let + ts_s = map (\(i, (t, ns)) -> typesToSort'' i t ns) $ zip [0..] ts + in + TypesToSorts ts_s + +typesToSort'' :: Int -> Type -> [Id] -> (Type, SortInfo) +typesToSort'' i t ns = + let + srt = "Sort_" ++ show i + dt = "DT_" ++ show i + sel_svs = map (\is@(Id (Name n m _ _) _) -> SortedVar + (nameToStr (Name n m i Nothing)) (typeToSort (TypesToSorts []) + (typeOf is)) + ) ns + in + (t, SortInfo { sort_name = srt, dt_name = dt, meas_names = sel_svs }) + +lookupSort :: Type -> TypesToSorts -> Maybe SortInfo +lookupSort t (TypesToSorts sorts) = + let + sis = filter (\(t', _) -> PresType t .:: t') sorts + min_sis = filter (\(t', _) -> all (\(t'', _) -> PresType t' .:: t'') sis) sis + in + case min_sis of + [(_, si)] -> Just si + [] -> Nothing + _ -> error $ "t = " ++ show t ++ "\nmin_sis = " ++ show min_sis + + -- = fmap (snd) . find (\(t', _) -> PresType t .:: t') . types_to_sorts + +lookupSortInfoBySort :: Symbol -> TypesToSorts -> Maybe SortInfo +lookupSortInfoBySort symb (TypesToSorts ts) = find (\s -> symb == sort_name s) $ map snd ts + +sortsToDeclareDTs :: TypesToSorts -> [Cmd] +sortsToDeclareDTs = map (sortToDeclareDT) . map snd . types_to_sorts + +sortToDeclareDT :: SortInfo -> Cmd +sortToDeclareDT (SortInfo {sort_name = srt, dt_name = dtn, meas_names = sels}) = + SmtCmd . DeclareDatatype srt $ DTDec [DTConsDec dtn sels] + +filterNonPrimMeasure :: [[Id]] -> [[Id]] +filterNonPrimMeasure = map (filter isPrimMeasure) + +isPrimMeasure :: Id -> Bool +isPrimMeasure = isPrimTy . typeOf + +allSorts :: TypesToSorts -> [Sort] +allSorts = map (IdentSort . ISymb) . allSortNames + +allSortNames :: TypesToSorts -> [Symbol] +allSortNames = map (sort_name . snd) . types_to_sorts + +addSelectors :: HM.HashMap Symbol String -> Sort -> TypesToSorts -> [GTerm] +addSelectors grams s = + concatMap (\si -> + case HM.lookup (sort_name si) grams of + Just gn -> mapMaybe (addSelector gn s) (meas_names si) + Nothing -> error "addSelectors: Grammar name not found") . map snd . types_to_sorts + +addSelector :: Symbol -> Sort -> SortedVar -> Maybe GTerm +addSelector gn s (SortedVar ident vs) + | s == vs = Just . GBfTerm $ BfIdentifierBfs (ISymb ident) [BfIdentifier (ISymb gn)] + | otherwise = Nothing + +filterToSorts :: [Symbol] -> TypesToSorts -> TypesToSorts +filterToSorts xs (TypesToSorts sorts) = + TypesToSorts $ filter (\(_, s) -> any (sort_name s ==) xs) sorts + +------------------------------- +-- Enforcing return value use +------------------------------- + +-- Adjusts a grammar to force using a given GTerm + +forceVarInGrammar :: SortedVar -- ^ The variable to force + -> [SortedVar] -- ^ All other variables + -> GrammarDef + -> GrammarDef +forceVarInGrammar var params (GrammarDef sv grls) = + let + prod_srt = mapMaybe (\grl@(GroupedRuleList grl_symb srt' _) -> + if any (flip canProduceVar grl) (var:params) + then Just grl_symb + else Nothing ) grls + + reach = gramSymbReachableFrom prod_srt grls + + sv_reach = concatMap (grammarDefSortedVars reach) sv + + (sv_final, grl_final) = elimNonTermGRL var (forceVarInGRLList var reach grls) sv_reach + in + GrammarDef sv_final grl_final + +forceVarInGRLList :: SortedVar -> [Symbol] -> [GroupedRuleList] -> [GroupedRuleList] +forceVarInGRLList var reach grls = + let + fv_map = HM.fromList $ map (\n -> (toBf n, toBf $ forcedVarSymb n)) reach + + in + concatMap (forceVarInGRL var reach fv_map) grls + where + toBf = BfIdentifier . ISymb + +forceVarInGRL :: SortedVar -> [Symbol] -> HM.HashMap BfTerm BfTerm -> GroupedRuleList -> [GroupedRuleList] +forceVarInGRL (SortedVar sv_symb sv_srt) reach fv_map grl@(GroupedRuleList grl_symb grl_srt gtrms) + | grl_symb `elem` reach = + let + bf_var = BfIdentifier (ISymb sv_symb) + fv_gtrms' = if sv_srt == grl_srt + then GBfTerm bf_var:(filter (not . isClamp) $ elimVariable fv_gtrms) + else filter (not . isClamp) $ elimVariable fv_gtrms + in + [GroupedRuleList fv_symb grl_srt fv_gtrms', grl] + | otherwise = [grl] + where + fv_symb = forcedVarSymb grl_symb + fv_gtrms = substOnceGTerms fv_map gtrms + + +forcedVarSymb :: Symbol -> Symbol +forcedVarSymb = ("fv_" ++) + +elimVariable :: [GTerm] -> [GTerm] +elimVariable = filter (\t -> case t of + GVariable _ -> False + _ -> True) + +isClamp :: GTerm -> Bool +isClamp (GBfTerm (BfIdentifier (ISymb "IClamp"))) = True +isClamp (GBfTerm (BfIdentifier (ISymb "DClamp"))) = True +isClamp _ = False + +----------------------------------------------------- + +elimNonTermGRL :: SortedVar -> [GroupedRuleList] -> [SortedVar] -> ([SortedVar], [GroupedRuleList]) +elimNonTermGRL (SortedVar sv_n _) grls sv = + let + has_term = hasTermFix (HS.singleton sv_n) grls + + sv' = filter (\(SortedVar n _) -> n `elem` has_term) sv + grls' = map (elimRules has_term) + $ filter (\(GroupedRuleList n _ _) -> n `elem` has_term) grls + in + trace "-----" + (sv', grls') + +hasTermFix :: HS.HashSet Symbol -> [GroupedRuleList] -> [Symbol] +hasTermFix ht grl = + let + ht' = HS.fromList + . map (\(GroupedRuleList n _ _) -> n) + $ filter (hasTermGRL ht) grl + + + ht_all = HS.union ht ht' + in + if ht == ht_all then HS.toList ht_all else hasTermFix ht_all grl + +hasTermGRL :: HS.HashSet Symbol -> GroupedRuleList -> Bool +hasTermGRL ht (GroupedRuleList n _ r) = n `HS.member` ht || any (hasTermGTerm ht) r + +hasTermGTerm :: HS.HashSet Symbol -> GTerm -> Bool +hasTermGTerm _ (GConstant _) = True +hasTermGTerm _ (GVariable _) = True +hasTermGTerm ht (GBfTerm bft) = hasTermBfTerm ht bft + +hasTermBfTerm :: HS.HashSet Symbol -> BfTerm -> Bool +hasTermBfTerm ht (BfIdentifier (ISymb i)) = i `HS.member` ht +hasTermBfTerm _ (BfLiteral _) = True +hasTermBfTerm ht (BfIdentifierBfs _ bfs) = all (hasTermBfTerm ht) bfs + +----------------------------------------------------- + +-- elimEmptyGRL :: [GroupedRuleList] -> [GroupedRuleList] +-- elimEmptyGRL grl = +-- let +-- emp_grl = map (\(GroupedRuleList n _ _) -> n) +-- $ filter (\(GroupedRuleList _ _ r) -> null r) grl + +-- in +-- filter (\(GroupedRuleList _ _ r) -> not $ null r) $ map (elimRules emp_grl) grl + +elimRules :: [Symbol] -> GroupedRuleList -> GroupedRuleList +elimRules grls (GroupedRuleList symb srt r) = + GroupedRuleList symb srt $ filter (elimRules' grls) r + +elimRules' :: [Symbol] -> GTerm -> Bool +elimRules' _ (GConstant _) = True +elimRules' _ (GVariable _) = True +elimRules' grls (GBfTerm bft) = elimRulesBfT grls bft + +elimRulesBfT :: [Symbol] -> BfTerm -> Bool +elimRulesBfT grls (BfIdentifier (ISymb i)) = i `elem` grls +elimRulesBfT _ (BfLiteral _) = True +elimRulesBfT grls (BfIdentifierBfs _ bfs) = all (elimRulesBfT grls) bfs + +----------------------------------------------------- + +grammarDefSortedVars :: [Symbol] -> SortedVar -> [SortedVar] +grammarDefSortedVars symbs sv@(SortedVar n srt) + | n `elem` symbs = [SortedVar (forcedVarSymb n) srt, sv] + | otherwise = [sv] + +-- Can a GroupedRuleList produce a given variable? + +canProduceVar :: SortedVar -> GroupedRuleList -> Bool +canProduceVar var@(SortedVar symb sv_srt) (GroupedRuleList _ grl_srt gtrms) + | sv_srt == grl_srt = any (canProduceVarGTerm var) gtrms + | otherwise = False + +canProduceVarGTerm :: SortedVar -> GTerm -> Bool +canProduceVarGTerm (SortedVar _ sv_srt) (GVariable gv_srt) = sv_srt == gv_srt +canProduceVarGTerm (SortedVar s _) (GBfTerm (BfIdentifier (ISymb is))) = s == is +canProduceVarGTerm s (GBfTerm (BfIdentifierBfs _ bfs)) = any (canProduceVarGTerm s) $ map GBfTerm bfs +canProduceVarGTerm _ (GBfTerm (BfLiteral _)) = False +canProduceVarGTerm _ (GConstant _) = False +canProduceVarGTerm _ t = error $ "Unhandled term" ++ show t + +-- Reachability checks + +gramSymbReachableFrom :: [Symbol] -> [GroupedRuleList] -> [Symbol] +gramSymbReachableFrom = gramSymbReachableFrom' HS.empty + +gramSymbReachableFrom' :: HS.HashSet Symbol -> [Symbol] -> [GroupedRuleList] -> [Symbol] +gramSymbReachableFrom' searched [] _ = HS.toList searched +gramSymbReachableFrom' searched (x:xs) grls + | x `HS.member` searched = gramSymbReachableFrom' searched xs grls + | otherwise = + let + contains_x = map (\(GroupedRuleList s _ _) -> s) + $ filter (containsSymbol x) grls + in + gramSymbReachableFrom' (HS.insert x searched) (contains_x ++ xs) grls + +containsSymbol :: Symbol -> GroupedRuleList -> Bool +containsSymbol symb (GroupedRuleList _ _ gtrms) = any (containsSymbolGTerm symb) gtrms + +containsSymbolGTerm :: Symbol -> GTerm -> Bool +containsSymbolGTerm symb (GBfTerm bf) = containsSymbolBfTerm symb bf +containsSymbolGTerm _ _ = False + +containsSymbolBfTerm :: Symbol -> BfTerm -> Bool +containsSymbolBfTerm symb (BfIdentifier ident) = containsSymbolIdent symb ident +containsSymbolBfTerm symb (BfIdentifierBfs ident bfs) = + containsSymbolIdent symb ident || any (containsSymbolBfTerm symb) bfs +containsSymbolBfTerm _ (BfLiteral _) = False + +containsSymbolIdent :: Symbol -> Identifier -> Bool +containsSymbolIdent symb (ISymb symb') = symb == symb' +containsSymbolIdent symb _ = False + +-- Substitution functions + +substOnceGRL :: HM.HashMap BfTerm BfTerm -> GroupedRuleList -> GroupedRuleList +substOnceGRL m (GroupedRuleList symb srt gtrms) = + GroupedRuleList symb srt $ substOnceGTerms m gtrms + +substOnceGTerms :: HM.HashMap BfTerm BfTerm -> [GTerm] -> [GTerm] +substOnceGTerms m = concatMap (substOnceGTerm m) + +substOnceGTerm :: HM.HashMap BfTerm BfTerm -> GTerm -> [GTerm] +substOnceGTerm m (GBfTerm bf) = map GBfTerm $ substOnceBfTerm m bf +substOnceGTerm _ gt = [gt] + +substOnceBfTerm :: HM.HashMap BfTerm BfTerm -> BfTerm -> [BfTerm] +substOnceBfTerm m (BfIdentifierBfs c bfs) = elimRedundant . map (BfIdentifierBfs c) $ substsOnces m bfs +substOnceBfTerm _ bf = [bf] + +substOnceTerm :: HM.HashMap Term Term -> Term -> [Term] +substOnceTerm m (TermCall c ts) = map (TermCall c) $ substsOnces m ts +substOnceTerm _ t = [t] + +elimRedundant :: [BfTerm] -> [BfTerm] +elimRedundant (b@(BfIdentifierBfs (ISymb s) [b1, b2]):xs) = + let + xs' = if isCommutative s + then delete (BfIdentifierBfs (ISymb s) [b2, b1]) xs + else xs + in + b:elimRedundant xs' +elimRedundant (x:xs) = x:elimRedundant xs +elimRedundant [] = [] + +isCommutative :: Symbol -> Bool +isCommutative "and" = True +isCommutative "=" = True +isCommutative "+" = True +isCommutative _ = False + +-- | Given: +-- * A mapping of list element to be replaced, to new elements +-- * A list, xs +-- returns a list of new lists. Each new list is xs, but with exactly one +-- occurence of an old element replaced by the corresponding new element. +substsOnces :: (Eq a, Hashable a) => HM.HashMap a a -> [a] -> [[a]] +substsOnces m = substsOnces' m [] + +substsOnces' :: (Eq a, Hashable a) => HM.HashMap a a -> [a] -> [a] -> [[a]] +substsOnces' m rv [] = [] +substsOnces' m rv (x:xs) + | Just new <- HM.lookup x m = (reverse rv ++ new:xs):rst + | otherwise = rst + where + rst = substsOnces' m (x:rv) xs + +------------------------------- +-- Converting to refinement +------------------------------- + +stripUnsat :: String -> String +stripUnsat ('u':'n':'s':'a':'t':xs) = xs +stripUnsat xs = xs + +refToQualifiers :: SpecType -> [RefNamePolyBound] -> RefNamePolyBound -> [Cmd] -> MeasureSymbols -> LH.TCEmb TyCon -> [Qualifier] +refToQualifiers st arg_pb ret_pb cmds meas_sym tycons = + let + arg_termsPB = map (defineFunsPB cmds) arg_pb + ret_termsPB = defineFunsPB cmds ret_pb + + lh_e = refToLHExpr' st arg_termsPB ret_termsPB meas_sym + in + map (uncurry (refToQualifier tycons)) (concatMap extractValues lh_e) + +refToQualifier :: LH.TCEmb TyCon -> [(LH.Symbol, SpecType)] -> LH.Expr -> Qualifier +refToQualifier tycons params e = + Q { qName = "G2" + , qParams = map (mkParam tycons) (last params:init params) + , qBody = e + , qPos = LH.dummyPos "G2" } + +mkParam :: LH.TCEmb TyCon -> (LH.Symbol, SpecType) -> QualParam +mkParam tycons (symb, st) = + QP { qpSym = symb, qpPat = PatNone, qpSort = funcHead $ rTypeSort tycons st } + where + funcHead (LH.FFunc h _) = h + funcHead s = s + +refToLHExpr :: SpecType -> [RefNamePolyBound] -> RefNamePolyBound -> [Cmd] -> MeasureSymbols -> [PolyBound LH.Expr] +refToLHExpr st arg_pb ret_pb cmds meas_sym = + let + arg_termsPB = map (defineFunsPB cmds) arg_pb + ret_termsPB = defineFunsPB cmds ret_pb + + lh_e = refToLHExpr' st arg_termsPB ret_termsPB meas_sym + in + map (mapPB snd) lh_e + +defineFunsPB :: [Cmd] -> RefNamePolyBound -> PolyBound ([SortedVar], Term) +defineFunsPB cmds = mapPB (defineFunsPB' cmds) + +defineFunsPB' :: [Cmd] -> String -> ([SortedVar], Term) +defineFunsPB' cmds fn + | Just (SmtCmd (DefineFun _ ars _ trm)) <- find (\(SmtCmd (DefineFun n _ _ _)) -> n == fn) cmds = + (ars, trm) + | otherwise = ([], TermLit (LitBool True)) + +-- | Shift all terms up as much as possible. This avoids expressions being nested more deeply- +-- and thus (in G2) checked more frequently- than needed. +shiftPB :: PolyBound ([SortedVar], Term) -> PolyBound ([SortedVar], Term) +shiftPB pb = + let + pb' = shiftPB' pb + in + if pb == pb' then pb else shiftPB pb' + +shiftPB' :: PolyBound ([SortedVar], Term) -> PolyBound ([SortedVar], Term) +shiftPB' (PolyBound svt@(sv, t) svts) = + let + (shift, leave) = + partition + (\(PolyBound (sv', t') _) -> + let + t_syms = termSymbols t' + in + case sv' of + [] -> False + _ -> let SortedVar s _ = (last sv') in s `notElem` t_syms) svts + + sv_new = nub $ sv ++ concatMap (\(PolyBound (sv', _) _) -> sv') shift + t_new = + case shift of + [] -> t + _ -> TermCall (ISymb "and") $ t:map (\(PolyBound (_, t') _) -> t') shift + + shift_new = map (\(PolyBound _ pb) -> PolyBound ([], TermLit (LitBool True)) pb) shift + in + PolyBound (sv_new, t_new) (shift_new ++ leave) + +refToLHExpr' :: SpecType + -> [PolyBound ([SortedVar], Term)] -- ^ Arguments + -> PolyBound ([SortedVar], Term) -- ^ Returns + -> MeasureSymbols + -> [PolyBound ([(LH.Symbol, SpecType)], LH.Expr)] +refToLHExpr' st sygus_args sygus_ret meas_sym = + let + pieces = specTypePieces st + + -- This is a bit of a dirty hack. The relArgs function drops typeclasses, + -- so that we don't have to deal with them in the SyGuS solver. But we still + -- gather the bindings for the typeclasses with specTypeSymbols. + -- Fortunately, the typeclasses are always the first arguments in the list, + -- so we can simply take the correct number of arguments from the end of the list. + -- Then, we fill up the front of the returned PolyBound list with true + rel_pieces_len = length sygus_args + 1 + tc_num = length pieces - rel_pieces_len + tc_pb_exprs = map (\st -> PolyBound ([(specTypeSymbol st, st)], PTrue) []) $ take tc_num pieces + last_pieces = reverse . take rel_pieces_len $ reverse pieces + + sygus_all = sygus_args ++ [sygus_ret] + sygus_all_inits = filter (not . null) $ inits sygus_all + pieces_inits = filter (not . null) $ inits last_pieces + + pb_expr = map (uncurry (refToLHExpr'' meas_sym)) $ zip sygus_all_inits pieces_inits + in + tc_pb_exprs ++ pb_expr + + +refToLHExpr'' :: MeasureSymbols -> [PolyBound ([SortedVar], Term)] -> [SpecType] -> PolyBound ([(LH.Symbol, SpecType)], LH.Expr) +refToLHExpr'' meas_sym sygus_in st = + let + sygus_args = map headValue $ init sygus_in + sygus_ret = last sygus_in + + st_args = map (\st -> (specTypeSymbol st, st)) $ init st + st_ret = last st + + st_ret_pb = specTypeRAppPiecesInFunc st_ret + in + mapPB (\(st, (sv, t)) -> refToLHExpr''' meas_sym (st_args ++ [(specTypeSymbol st, st)]) sv t) $ zipPB st_ret_pb sygus_ret + +refToLHExpr''' :: MeasureSymbols -> [(LH.Symbol, SpecType)] -> [SortedVar] -> Term -> ([(LH.Symbol, SpecType)], LH.Expr) +refToLHExpr''' meas_sym symbs_st ars trm = + let + ars' = map (\(SortedVar sym _) -> sym) ars + + symbs = map fst symbs_st + + symbsArgs = M.fromList $ zip ars' symbs + in + (symbs_st, termToLHExpr meas_sym symbsArgs trm) + +termToLHExpr :: MeasureSymbols -> M.Map Sy.Symbol LH.Symbol -> Term -> LH.Expr +termToLHExpr _ m_args (TermIdent (ISymb v)) = + case M.lookup v m_args of + Just v' -> EVar v' + Nothing -> error "termToLHExpr: Variable not found" +termToLHExpr _ _ (TermLit l) = litToLHConstant l +termToLHExpr meas_sym@(MeasureSymbols meas_sym') m_args (TermCall (ISymb v) ts) + -- Measures + | Just meas <- find (\meas' -> Just (symbolName meas') == fmap zeroName (maybe_StrToName v)) meas_sym' = + foldl' EApp (EVar meas) $ map (termToLHExpr meas_sym m_args) ts + -- Clamped numbers + | clampIntSymb == v + , [TermLit l] <- ts = clampedInt l + | clampDoubleSymb == v + , [TermCall (ISymb "/") [t1, t2]] <- ts = clampedDouble t1 t2 + | clampDoubleSymb == v + , [t] <- ts = clampedDouble t (TermLit $ LitNum 1) + -- EBin + | "+" <- v + , [t1, t2] <- ts = EBin LH.Plus (termToLHExpr meas_sym m_args t1) (termToLHExpr meas_sym m_args t2) + | "-" <- v + , [t1] <- ts = ENeg (termToLHExpr meas_sym m_args t1) + | "-" <- v + , [t1, t2] <- ts = EBin LH.Minus (termToLHExpr meas_sym m_args t1) (termToLHExpr meas_sym m_args t2) + | "*" <- v + , [t1, t2] <- ts = EBin LH.Times (termToLHExpr meas_sym m_args t1) (termToLHExpr meas_sym m_args t2) + | "/" <- v + , [t1, t2] <- ts + , Just n1 <- getInteger t1 + , Just n2 <- getInteger t2 = ECon . LHF.R $ fromRational (n1 % n2) + | "mod" <- v + , [t1, t2] <- ts = EBin LH.Mod (termToLHExpr meas_sym m_args t1) (termToLHExpr meas_sym m_args t2) + -- Special handling for safe-mod. We enforce via the grammar that the denominator is an Integer + | "safe-mod" <- v + , [t1, t2] <- ts + , TermLit (LitNum n) <- t2 = EBin LH.Mod (termToLHExpr meas_sym m_args t1) (ECon (I ((abs n) + 1))) + -- More EBin... + | "and" <- v = PAnd $ map (termToLHExpr meas_sym m_args) ts + | "or" <- v = POr $ map (termToLHExpr meas_sym m_args) ts + | "not" <- v, [t1] <- ts = PNot (termToLHExpr meas_sym m_args t1) + | "=>" <- v + , [t1, t2] <- ts = PImp (termToLHExpr meas_sym m_args t1) (termToLHExpr meas_sym m_args t2) + -- PAtom + | "=" <- v + , [t1, t2] <- ts = PAtom LH.Eq (termToLHExpr meas_sym m_args t1) (termToLHExpr meas_sym m_args t2) + | ">" <- v + , [t1, t2] <- ts = PAtom LH.Gt (termToLHExpr meas_sym m_args t1) (termToLHExpr meas_sym m_args t2) + | ">=" <- v + , [t1, t2] <- ts = PAtom LH.Ge (termToLHExpr meas_sym m_args t1) (termToLHExpr meas_sym m_args t2) + | "<" <- v + , [t1, t2] <- ts = PAtom LH.Lt (termToLHExpr meas_sym m_args t1) (termToLHExpr meas_sym m_args t2) + | "<=" <- v + , [t1, t2] <- ts = PAtom LH.Le (termToLHExpr meas_sym m_args t1) (termToLHExpr meas_sym m_args t2) + -- More PAtom... +termToLHExpr meas_sym@(MeasureSymbols meas_sym') m_args (TermCall (ISymb v) ts) = + error $ "v = " ++ show v ++ "\nts = " ++ show ts ++ "\nmaybe_StrToName v = " ++ show (maybe_StrToName v) ++ "\nmeas_syms' = " ++ show (map symbolName meas_sym') +termToLHExpr (_) _ t = error $ "termToLHExpr meas_sym m_args: unhandled " ++ show t + +getInteger :: Term -> Maybe Integer +getInteger (TermLit (LitNum n)) = Just n +getInteger (TermCall (ISymb "-") [TermLit (LitNum n)]) = Just (- n) +getInteger _ = Nothing + +zeroName :: Name -> Name +zeroName (Name n m _ l) = Name n m 0 l + +litToLHConstant :: Sy.Lit -> LH.Expr +litToLHConstant (LitNum n) = ECon (I n) +litToLHConstant (LitBool b) = if b then PTrue else PFalse +litToLHConstant l = error $ "litToLHConstant: Unhandled literal " ++ show l + +clampedInt :: Sy.Lit -> LH.Expr +clampedInt (LitNum n) + | n < 0 = ECon (LHF.I 0) + | n > clampUpper = ECon (LHF.I clampUpper) + | otherwise = ECon (LHF.I n) +clampedInt _ = error $ "clampedInt: Unhandled literals" + +clampedDouble :: Term -> Term -> LH.Expr +clampedDouble t1 t2 + | n < 0 = ECon (LHF.R 0) + | n > clampUpper = ECon (LHF.R clampUpper) + | otherwise = ECon (LHF.R n) + where + d1 = termToInteger t1 + d2 = termToInteger t2 + + n = fromInteger d1 / fromInteger d2 +clampedDouble _ _ = error $ "clampedDouble: Unhandled literals" + +termToInteger :: Term -> Integer +termToInteger (TermLit (LitNum d)) = d +termToInteger (TermCall (ISymb "-") [t]) = - (termToInteger t) + +------------------- + +specTypeNestedSymbol :: SpecType -> LH.Symbol +specTypeNestedSymbol (RFun { rt_in = i }) = specTypeNestedSymbol i +specTypeNestedSymbol st = specTypeSymbol st + +specTypeSymbol :: SpecType -> LH.Symbol +specTypeSymbol (RFun { rt_bind = b }) = b +specTypeSymbol rapp@(RApp { rt_reft = ref }) = reftSymbol $ ur_reft ref +specTypeSymbol (RVar { rt_reft = ref }) = reftSymbol $ ur_reft ref +specTypeSymbol _ = error $ "specTypeSymbol: SpecType not handled" + +specTypePieces :: SpecType -> [SpecType] +specTypePieces st = specTypePieces' [] st + +specTypePieces' :: [SpecType] -> SpecType -> [SpecType] +specTypePieces' sts rfun@(RFun { rt_in = i, rt_out = out }) = + case i of + RVar {} -> specTypePieces' sts out + RFun {} -> specTypePieces' sts out + _ -> specTypePieces' (rfun:sts) out +specTypePieces' sts rapp@(RApp {}) = reverse (rapp:sts) +specTypePieces' sts rvar@(RVar {}) = reverse (rvar:sts) +specTypePieces' sts (RAllT { rt_ty = out }) = specTypePieces' sts out + +specTypeRAppPiecesInFunc :: SpecType -> PolyBound SpecType +specTypeRAppPiecesInFunc (RFun {rt_in = i}) = specTypeRAppPiecesInFunc i +specTypeRAppPiecesInFunc st = specTypeRAppPieces st + +specTypeRAppPieces :: SpecType -> PolyBound SpecType +specTypeRAppPieces rapp@(RApp { rt_reft = ref, rt_args = ars }) = + PolyBound rapp $ map specTypeRAppPieces ars +specTypeRAppPieces rvar@(RVar {}) = PolyBound rvar [] +specTypeRAppPieces r = error $ "specTypeRAppPieces: Unexpected SpecType" ++ "\n" ++ show r + +------------------- + +reftSymbol :: Reft -> LH.Symbol +reftSymbol = fst . unpackReft + +unpackReft :: Reft -> (LH.Symbol, LH.Expr) +unpackReft = coerce + +-- | Collects all the symbols from a term +termSymbols :: Term -> [Symbol] +termSymbols (TermIdent i) = identifierSymbols i +termSymbols (TermLit _) = [] +termSymbols (TermCall i ts) = identifierSymbols i ++ concatMap termSymbols ts +termSymbols (TermExists sv t) = map svSymbol sv ++ termSymbols t +termSymbols (TermForAll sv t) = map svSymbol sv ++ termSymbols t +termSymbols (TermLet vb t) = concatMap vbSymbols vb ++ termSymbols t + +identifierSymbols :: Identifier -> [Symbol] +identifierSymbols (ISymb s) = [s] +identifierSymbol (Indexed s inds) = s:mapMaybe indexSymbol inds + +indexSymbol :: Index -> Maybe Symbol +indexSymbol (IndSymb s) = Just s +indexSymbol _ = Nothing + +svSymbol :: SortedVar -> Symbol +svSymbol (SortedVar s _) = s + +vbSymbols :: VarBinding -> [Symbol] +vbSymbols (VarBinding s t) = s:termSymbols t + +------------------------------- +-- Calling SyGuS +------------------------------- + +runCVC4 :: InferenceConfig -> String -> IO (Either SomeException [Cmd]) +runCVC4 infconfig sygus = + try ( + withSystemTempFile ("cvc4_input.sy") + (\fp h -> do + hPutStr h sygus + -- We call hFlush to prevent hPutStr from buffering + hFlush h + + toCommandOSX <- findExecutable "gtimeout" + let toCommand = case toCommandOSX of + Just c -> c -- Mac + Nothing -> "timeout" -- Linux + + sol <- P.readProcess toCommand ([show (timeout_sygus infconfig), "cvc4", fp, "--lang=sygus2"]) "" + + let sol' = case stripPrefix "unsat" sol of { Just s -> s; Nothing -> error "runCVC4: non-unsat result" } + + return . parse . lexSygus $ sol') + ) + +runCVC4StreamSolutions :: InferenceConfig -> Int -> String -> IO (Either SomeException [Cmd]) +runCVC4StreamSolutions infconfig grouped sygus = + try ( + withSystemTempFile ("cvc4_input.sy") + (\fp h -> do + hPutStr h sygus + -- We call hFlush to prevent hPutStr from buffering + hFlush h + + timeout <- timeOutCommand + + -- --no-sygus-fair-max searches for functions that minimize the sum of the sizes of all functions + (inp, outp, errp, _) <- P.runInteractiveCommand + $ timeout ++ " " ++ show (timeout_sygus infconfig) + ++ " cvc4 " ++ fp ++ " --lang=sygus2 --sygus-stream --no-sygus-fair-max" + + lnes <- checkIfSolution grouped outp + + hClose inp + hClose outp + hClose errp + + return lnes + ) + ) + +checkIfSolution :: Int -> Handle -> IO [Cmd] +checkIfSolution grouped h = do + sol <- getSolution grouped h + let sol' = concatMap (parse . lexSygus) $ sol + if all (\c -> rInCmd c || noVarInCmd c) sol' then return sol' else checkIfSolution grouped h + +getSolution :: Int -> Handle -> IO [String] +getSolution 0 _ = return [] +getSolution !n h = do + lne <- hGetLine h + lnes <- getSolution (n - 1) h + return $ lne:lnes + +rInCmd :: Cmd -> Bool +rInCmd (SmtCmd (DefineFun _ _ _ t)) = rInTerm t +rInCmd _ = False + +rInTerm :: Term -> Bool +rInTerm (TermIdent (ISymb n)) = n == "r" +rInTerm (TermIdent _) = False +rInTerm (TermLit _) = False +rInTerm (TermCall _ ts) = any rInTerm ts +rInTerm (TermExists _ t) = rInTerm t +rInTerm (TermForAll _ t) = rInTerm t +rInTerm (TermLet vs t) = any (\(VarBinding _ t') -> rInTerm t') vs || rInTerm t + +noVarInCmd :: Cmd -> Bool +noVarInCmd (SmtCmd (DefineFun _ _ _ t)) = noVarInTerm t +noVarInCmd _ = False + +noVarInTerm :: Term -> Bool +noVarInTerm (TermIdent _) = False +noVarInTerm (TermLit _) = True +noVarInTerm (TermCall _ ts) = all noVarInTerm ts +noVarInTerm (TermExists _ t) = noVarInTerm t +noVarInTerm (TermForAll _ t) = noVarInTerm t +noVarInTerm (TermLet vs t) = all (\(VarBinding _ t') -> noVarInTerm t') vs && noVarInTerm t + +runCVC4Stream :: Int -> String -> IO (Either SomeException String) +runCVC4Stream max_size sygus = + try ( + withSystemTempFile ("cvc4_input.sy") + (\fp h -> do + hPutStr h sygus + -- We call hFlush to prevent hPutStr from buffering + hFlush h + + (inp, outp, errp, _) <- P.runInteractiveCommand + $ "cvc4 " ++ fp ++ " --lang=sygus2 --sygus-stream --sygus-abort-size=" ++ show max_size + + lnes <- readLines outp [] + + hClose inp + hClose outp + hClose errp + + return lnes + ) + ) + +readLines :: Handle -> [String] -> IO String +readLines h lnes = do + b <- hIsEOF h + if b + then return . concat . reverse $ lnes + else do + lne <- hGetLine h + if "(error" `isInfixOf` lne + then readLines h lnes + else readLines h (lne:lnes) + +timeOutCommand :: IO String +timeOutCommand = do + cmdMacOS <- findExecutable "gtimeout" + case cmdMacOS of + Just c -> return c + Nothing -> return "timeout" +-} diff --git a/src/G2/Liquid/Inference/Sygus/SimplifySygus.hs b/src/G2/Liquid/Inference/Sygus/SimplifySygus.hs new file mode 100644 --- /dev/null +++ b/src/G2/Liquid/Inference/Sygus/SimplifySygus.hs @@ -0,0 +1,440 @@ +{-# LANGUAGE LambdaCase #-} + +module G2.Liquid.Inference.Sygus.SimplifySygus ( EliminatedSimple + , elimSimpleDTs + , restoreSimpleDTs + + , elimRedundantAnds + , splitAnds + , simplifyImpliesLHS + , simplifyNegatedAnds + + , EliminatedTrivTrue + , simplifyToTrue + , restoreSimplifiedToTrue + + , elimNegatedExistential + , simplifyImpliesExistentials) where + +import Sygus.Syntax + +import Data.List +import qualified Data.HashMap.Lazy as M +import Data.Maybe +import qualified Data.Set as S + +-- | Maps a tuple of a (1) function name and (2) function param to selector calls and variables +-- with ADTs sorts +data EliminatedSimple = EliminatedSimple { func_args :: M.HashMap Symbol [SortedVar] + , vars_to_terms :: M.HashMap (Symbol, Symbol) Term } + +emptyES :: EliminatedSimple +emptyES = EliminatedSimple M.empty M.empty + +insertArgsES :: Symbol -> [SortedVar] -> EliminatedSimple -> EliminatedSimple +insertArgsES fn sv es = es { func_args = M.insert fn sv (func_args es) } + +insertTermES :: (Symbol, Symbol) -> Term -> EliminatedSimple -> EliminatedSimple +insertTermES fn_p t es = es { vars_to_terms = M.insert fn_p t (vars_to_terms es) } + +lookupArgsES :: Symbol -> EliminatedSimple -> Maybe [SortedVar] +lookupArgsES fn = M.lookup fn . func_args + +lookupTermES :: (Symbol, Symbol) -> EliminatedSimple -> Maybe Term +lookupTermES fn_p = M.lookup fn_p . vars_to_terms + +selectorToVar :: Symbol -> Symbol -> EliminatedSimple -> Maybe Symbol +selectorToVar fn tn = + fmap (\((_, v), _) -> v) + . listToMaybe + . filter (\((fn', _), t) -> + case t of + TermCall (ISymb tn') _ -> fn == fn' && tn == tn' + _ -> False + ) + . M.toList + . vars_to_terms + +----------------------------------------- + +-- | We define a simple datatype as a datatype that exists only as a wrapper on primitive datatypes +-- This function takes a SyGuS problem containing simple datatypes, and eliminates them. +-- It also returns a mapping, which can be used by `restoreSimpleDTs`, to bring back those datatypes +-- in a solution. +elimSimpleDTs :: [Cmd] -> (EliminatedSimple, [Cmd]) +elimSimpleDTs cmds = + let + simple_srts = getSimpleSorts cmds + in + mapAccumL (elimSimpleDTs' simple_srts) emptyES + $ filter (not . droppableDTDecl simple_srts) cmds + +elimSimpleDTs' :: M.HashMap Symbol (Symbol, [SortedVar]) -> EliminatedSimple -> Cmd -> (EliminatedSimple, Cmd) +elimSimpleDTs' simple_srts es (Constraint t) = (es, Constraint $ elimSimpleDTsTerms simple_srts t) +elimSimpleDTs' _ _ (InvConstraint _ _ _ _) = error "elimSimpleDTs': InvConstraint unsupported" +elimSimpleDTs' simple_srts es (SynthFun fn sv rs (Just gd)) = + let + (es', sv') = mapAccumL (elimSimpleDTsSVs fn simple_srts) es sv + es'' = insertArgsES fn sv es' + sv'' = concat sv' + + gd' = adjustSimpleInGrammar simple_srts fn es' gd + in + (es'', SynthFun fn sv'' rs (Just gd')) +elimSimpleDTs' _ es cmd = (es, cmd) + +elimSimpleDTsSVs :: Symbol -> M.HashMap Symbol (Symbol, [SortedVar]) -> EliminatedSimple -> SortedVar -> (EliminatedSimple, [SortedVar]) +elimSimpleDTsSVs fn simple_srts es sv@(SortedVar symb srt) + | IdentSort (ISymb isrt) <- srt + , Just (_, params) <- M.lookup isrt simple_srts = + let + new_sv = map (\(SortedVar n i) -> SortedVar (symb ++ "__" ++ n) i) params + es' = foldr (\(SortedVar n _) -> insertTermES (fn, symb ++ "__" ++ n) (TermCall (ISymb n) [TermIdent (ISymb symb)])) es params + in + (es', new_sv) + | otherwise = (es, [sv]) + +elimSimpleDTsTerms :: M.HashMap Symbol (Symbol, [SortedVar]) -> Term -> Term +elimSimpleDTsTerms _ t@(TermIdent _) = t +elimSimpleDTsTerms _ t@(TermLit _) = t +elimSimpleDTsTerms simple_srts (TermCall i ts) = + swapToIdent . TermCall i $ concatMap (elimSimpleDTsList simple_srts) ts +elimSimpleDTsTerms simple_srts (TermExists sv t) = + let + (es, out_as) = mapAccumL + (\els (SortedVar n srt) -> + case M.lookup (sortSymb srt) simple_srts of + Just (_, as) -> + let + new_as = map (\(SortedVar s srt') -> SortedVar ("new__" ++ s) srt') as + els' = insertArgsES n new_as els + in + (els', new_as) + Nothing -> (els, [SortedVar n srt])) emptyES sv + in + case concat out_as of + [] -> elimExistentials es t' + out_as' -> TermExists out_as' $ elimExistentials es t' + where + t' = elimSimpleDTsTerms simple_srts t +elimSimpleDTsTerms _ t = error $ "elimSimpleDTsTerms: Unhandled term " ++ show t + +sortSymb :: Sort -> Symbol +sortSymb (IdentSort (ISymb symb)) = symb +sortSymb (IdentSortSort (ISymb symb) _) = symb + +elimSimpleDTsList :: M.HashMap Symbol (Symbol, [SortedVar]) -> Term -> [Term] +elimSimpleDTsList simple_srts t@(TermIdent (ISymb s)) + | s `S.member` getSimpleDTs simple_srts = [] + | otherwise = [t] +elimSimpleDTsList _ t@(TermLit _) = [t] +elimSimpleDTsList simple_srts (TermCall (ISymb s) ts) + | s `S.member` getSimpleDTs simple_srts = ts + | otherwise = [swapToIdent . TermCall (ISymb s) $ concatMap (elimSimpleDTsList simple_srts) ts] +elimSimpleDTsList simple_srts te@(TermExists _ _) = [elimSimpleDTsTerms simple_srts te] +elimSimpleDTsList _ t = error $ "elimSimpleDTsList: Unhandled term " ++ show t + +elimExistentials :: EliminatedSimple -> Term -> Term +elimExistentials _ t@(TermIdent _) = t +elimExistentials _ t@(TermLit _) = t +elimExistentials es (TermCall i ts) = + swapToIdent . TermCall i $ concatMap (elimExistentialsList es) ts +elimExistentials _ t = error $ "elimExistentials: Unhandled term " ++ show t + +elimExistentialsList :: EliminatedSimple -> Term -> [Term] +elimExistentialsList es t@(TermIdent (ISymb s)) = + case lookupArgsES s es of + Just as -> map (\(SortedVar i _) -> TermIdent $ ISymb i) as + Nothing -> [t] +elimExistentialsList _ t@(TermLit _) = [t] +elimExistentialsList es (TermCall i@(ISymb s) ts) + | Just _ <- lookupArgsES s es = ts + | otherwise = [swapToIdent . TermCall i $ map (elimExistentials es) ts] +elimExistentialsList _ t = error $ "elimExistentialsList: Unhandled term " ++ show t + +swapToIdent :: Term -> Term +swapToIdent (TermCall i []) = TermIdent i +swapToIdent t = t + +adjustSimpleInGrammar :: M.HashMap Symbol (Symbol, [SortedVar]) -> Symbol -> EliminatedSimple -> GrammarDef -> GrammarDef +adjustSimpleInGrammar simple_srts fn es (GrammarDef sv grl) = + GrammarDef (filter (not . simpleGrammarDecls simple_srts) sv) + . filter (not . simpleProdGRL simple_srts) $ map (adjustSimpleInGRL fn es) grl + +simpleGrammarDecls :: M.HashMap Symbol (Symbol, [SortedVar]) -> SortedVar -> Bool +simpleGrammarDecls simple_srts (SortedVar _ (IdentSort (ISymb s))) = s `M.member` simple_srts + +simpleProdGRL :: M.HashMap Symbol (Symbol, [SortedVar]) -> GroupedRuleList -> Bool +simpleProdGRL simple_srts (GroupedRuleList _ (IdentSort (ISymb s)) _) = s `M.member` simple_srts + +adjustSimpleInGRL :: Symbol -> EliminatedSimple -> GroupedRuleList -> GroupedRuleList +adjustSimpleInGRL fn es (GroupedRuleList symb srt gtrm) = + GroupedRuleList symb srt $ map (adjustSimpleInGTerms fn es) gtrm + +adjustSimpleInGTerms :: Symbol -> EliminatedSimple -> GTerm -> GTerm +adjustSimpleInGTerms fn es (GBfTerm (BfIdentifierBfs (ISymb s) _)) + | Just v <- selectorToVar fn s es = GBfTerm $ BfIdentifier (ISymb v) +adjustSimpleInGTerms _ _ gt = gt + + +----------------------------------------- +droppableDTDecl :: M.HashMap Symbol (Symbol, [SortedVar]) -> Cmd -> Bool +droppableDTDecl simple_srts (SmtCmd (DeclareDatatype symb _)) = symb `M.member` simple_srts +droppableDTDecl _ _ = False + +----------------------------------------- + +-- Maps Sorts with single data constructors to +-- (1) the data constructor name +-- (2) the data constructor arguments. +getSimpleSorts :: [Cmd] -> M.HashMap Symbol (Symbol, [SortedVar]) +getSimpleSorts = + M.fromList + . concatMap (\case + SmtCmd (DeclareDatatype s dtdec) + | Just dti <- isSimpleDT dtdec -> [(s, dti)] + SmtCmd (DeclareDatatypes _ _) -> error "getEliminatedSimple: declareDatatypes not supported" + _ -> []) + +getSimpleDTs :: M.HashMap Symbol (Symbol, [SortedVar]) -> S.Set Symbol +getSimpleDTs = S.fromList . map fst . M.elems + +isSimpleDT :: DTDec -> Maybe (Symbol, [SortedVar]) +isSimpleDT (DTDec [DTConsDec dtn sv]) + | all isPrimitiveSV sv = Just (dtn, sv) +isSimpleDT _ = Nothing + +isPrimitiveSV :: SortedVar -> Bool +isPrimitiveSV (SortedVar _ (IdentSort (ISymb i))) = i == "Int" || i == "Real" || i == "Bool" +isPrimitiveSV _ = False + +----------------------------------------- + +-- | Given information about eliminated simple ADTs, restore a solution +restoreSimpleDTs :: EliminatedSimple -> [Cmd] -> [Cmd] +restoreSimpleDTs es = map (restoreSimpleDTs' es) + +restoreSimpleDTs' :: EliminatedSimple -> Cmd -> Cmd +restoreSimpleDTs' es (SmtCmd cmd) = SmtCmd $ restoreSimpleDTsSMT es cmd +restoreSimpleDTs' _ _ = error "restoreSimpleDTs: Cmd not supported" + +restoreSimpleDTsSMT :: EliminatedSimple -> SmtCmd -> SmtCmd +restoreSimpleDTsSMT es (DefineFun fn sv srt t) = + let + sv' = maybe sv id (lookupArgsES fn es) + in + DefineFun fn sv' srt $ restoreSimpleDTsTerm es fn t +restoreSimpleDTsSMT _ _ = error "restoreSimpleDTsSMT: Cmd not supported" + +restoreSimpleDTsTerm :: EliminatedSimple -> Symbol -> Term -> Term +restoreSimpleDTsTerm es fn t@(TermIdent i) + | ISymb s <- i + , Just t' <- lookupTermES (fn, s) es = t' + | otherwise = t +restoreSimpleDTsTerm es fn (TermCall i ts) = TermCall i $ map (restoreSimpleDTsTerm es fn) ts +restoreSimpleDTsTerm es fn (TermExists sv t) = TermExists sv $ restoreSimpleDTsTerm es fn t +restoreSimpleDTsTerm es fn (TermForAll sv t) = TermForAll sv $ restoreSimpleDTsTerm es fn t +restoreSimpleDTsTerm _ _ (TermLet _ _ ) = error "restoreSimpleDTsTerm: Term not supported" +restoreSimpleDTsTerm _ _ t = t + +----------------------------------------- +-- Rewrites to remove redundant Ands + +elimRedundantAnds :: [Cmd] -> [Cmd] +elimRedundantAnds = map elimRedundantAnds' + +elimRedundantAnds' :: Cmd -> Cmd +elimRedundantAnds' (Constraint t) = Constraint $ elimRedAndsTerm t +elimRedundantAnds' cmd = cmd + +elimRedAndsTerm :: Term -> Term +elimRedAndsTerm (TermCall (ISymb "and") ts) = + TermCall (ISymb "and") $ concatMap inlineAnds ts +elimRedAndsTerm t = t + +inlineAnds :: Term -> [Term] +inlineAnds (TermCall (ISymb "and") ts) = concatMap inlineAnds ts +inlineAnds t = [t] + +----------------------------------------- +-- Split up anded terms into separate constraints + +splitAnds :: [Cmd] -> [Cmd] +splitAnds = concatMap splitAnds' + +splitAnds' :: Cmd -> [Cmd] +splitAnds' (Constraint t) = splitAndsTerm t +splitAnds' cmd = [cmd] + +splitAndsTerm :: Term -> [Cmd] +splitAndsTerm (TermCall (ISymb "and") ts) = map Constraint ts +splitAndsTerm t = [Constraint t] + +----------------------------------------- +-- Simplify by eliminatng any functions from the LHS of an implies that must be true + +simplifyImpliesLHS :: [Cmd] -> [Cmd] +simplifyImpliesLHS cmd = + let + true_trms = mapMaybe getTrueTerm cmd + in + map (simplifyImpliesLHS' true_trms) cmd + +simplifyImpliesLHS' :: [Term] -> Cmd -> Cmd +simplifyImpliesLHS' ts (Constraint t) = Constraint $ simplifyImpliesLHSTerm ts t +simplifyImpliesLHS' _ cmd = cmd + +simplifyImpliesLHSTerm :: [Term] -> Term -> Term +simplifyImpliesLHSTerm ts (TermCall (ISymb "=>") [lhs, rhs]) = + case simplifyImpliesLHSTerm' ts lhs of + Just lhs' -> TermCall (ISymb "=>") [lhs', rhs] + Nothing -> rhs +simplifyImpliesLHSTerm _ t = t + +simplifyImpliesLHSTerm' :: [Term] -> Term -> Maybe Term +simplifyImpliesLHSTerm' ts (TermCall (ISymb "and") and_ts) = + case mapMaybe (simplifyImpliesLHSTerm' ts) and_ts of + [] -> Just . TermLit $ LitBool True + and_ts' -> Just $ TermCall (ISymb "and") and_ts' +simplifyImpliesLHSTerm' ts t = if t `elem` ts then Nothing else Just t + +getTrueTerm :: Cmd -> Maybe Term +getTrueTerm (Constraint t) = Just t +getTrueTerm _ = Nothing + +----------------------------------------- +-- Simplify by eliminatng any functions from a not-ed and that must be true + +simplifyNegatedAnds :: [Cmd] -> [Cmd] +simplifyNegatedAnds cmd = + let + true_trms = mapMaybe getTrueTerm cmd + in + map (simplifyNegatedAnds' true_trms) cmd + +simplifyNegatedAnds' :: [Term] -> Cmd -> Cmd +simplifyNegatedAnds' ts (Constraint t) = Constraint $ simplifyNegatedAndsTerms ts t +simplifyNegatedAnds' _ cmd = cmd + +simplifyNegatedAndsTerms :: [Term] -> Term -> Term +simplifyNegatedAndsTerms ts (TermCall (ISymb "not") [t]) = + TermCall (ISymb "not") $ [simplifyNegatedAndsInNot ts t] +simplifyNegatedAndsTerms ts tc@(TermCall (ISymb "=>") [t, t']) + | t == TermLit (LitBool True) = simplifyNegatedAndsTerms ts t' + | otherwise = tc +simplifyNegatedAndsTerms _ t = t + +simplifyNegatedAndsInNot :: [Term] -> Term -> Term +simplifyNegatedAndsInNot ts (TermCall (ISymb "and") ts') = + case filter (`notElem` ts) ts' of + [] -> TermLit (LitBool True) + new_ts -> TermCall (ISymb "and") new_ts +simplifyNegatedAndsInNot _ t = t + +----------------------------------------- +-- Identify functions that can simply be rewritten to true, use `restoreSimplifiedToTrue` +-- to ensure all functions still appear in the returned solution + +newtype EliminatedTrivTrue = EliminatedTrivTrue [Cmd] + +simplifyToTrue :: [Cmd] -> (EliminatedTrivTrue, [Cmd]) +simplifyToTrue cmds = + let + synth_funs = mapMaybe getSynthFuns cmds + may_need_false = concatMap mayNeedToBeFalse cmds + + synth_set_true = filter (\(n, _, _) -> n `notElem` may_need_false) synth_funs + synth_set_true' = map (\(n, _, _) -> n) synth_set_true + + -- Set up EliminatedTrivTrue + tre = TermLit (LitBool True) + triv_def = map (\(n, ar, r) -> SmtCmd $ DefineFun n ar r tre) synth_set_true + in + (EliminatedTrivTrue triv_def, filter (not . mustBeTrue synth_set_true') cmds) + +getSynthFuns :: Cmd -> Maybe (Symbol, [SortedVar], Sort) +getSynthFuns (SynthFun n ars ret _) = Just (n, ars, ret) +getSynthFuns _ = Nothing + +mayNeedToBeFalse :: Cmd -> [Symbol] +mayNeedToBeFalse (Constraint t) = mayNeedToBeFalseTerm t +mayNeedToBeFalse _ = [] + +mustBeTrue :: [Symbol] -> Cmd -> Bool +mustBeTrue symbs (SynthFun n _ _ _) = n `elem` symbs +mustBeTrue symbs (Constraint (TermIdent (ISymb s))) = s `elem` symbs +mustBeTrue symbs (Constraint (TermCall (ISymb s) _)) = s `elem` symbs +mustBeTrue _ _ = False + +-- If a function is called directly in a constraint, it must be true, but if +-- it is nested in an implies or a not, it may need to be false +mayNeedToBeFalseTerm :: Term -> [Symbol] +mayNeedToBeFalseTerm (TermIdent _) = [] +mayNeedToBeFalseTerm (TermLit _) = [] +mayNeedToBeFalseTerm (TermCall _ ts) = concatMap mayNeedToBeFalseTerm' ts +mayNeedToBeFalseTerm (TermExists _ t) = mayNeedToBeFalseTerm' t -- Could this just be (mayNeedToBeFalseTerm t)? +mayNeedToBeFalseTerm _ = error "mayNeedToBeFalseTerm: unhandled term" + +mayNeedToBeFalseTerm' :: Term -> [Symbol] +mayNeedToBeFalseTerm' (TermIdent (ISymb s)) = [s] +mayNeedToBeFalseTerm' (TermLit _) = [] +mayNeedToBeFalseTerm' (TermCall (ISymb s) ts) = s:concatMap mayNeedToBeFalseTerm' ts +mayNeedToBeFalseTerm' (TermExists _ t) = mayNeedToBeFalseTerm' t +mayNeedToBeFalseTerm' _ = error "mayNeedToBeFalseTerm': unhandled term" + +restoreSimplifiedToTrue :: EliminatedTrivTrue -> [Cmd] -> [Cmd] +restoreSimplifiedToTrue (EliminatedTrivTrue el_cmds) = (++) el_cmds + + +----------------------------------------- +-- Elimiantes negated existentials. This simplification actually does NOT keep exactly the same problem. +-- However, in practice, we never benefit from negated existentials when synthesizing a refinement type. + +elimNegatedExistential :: [Cmd] -> [Cmd] +elimNegatedExistential = map elimNegatedExistential' + +elimNegatedExistential' :: Cmd -> Cmd +elimNegatedExistential' (Constraint t) = Constraint $ elimNegatedExistentialTerm t +elimNegatedExistential' cmd = cmd + +elimNegatedExistentialTerm :: Term -> Term +elimNegatedExistentialTerm (TermCall (ISymb "not") [t]) = + case elimNegatedExistentialTerm' t of + Nothing -> TermLit (LitBool True) + Just t' -> TermCall (ISymb "not") [t'] +elimNegatedExistentialTerm (TermCall i ts) = TermCall i $ map elimNegatedExistentialTerm ts +elimNegatedExistentialTerm t = t + +elimNegatedExistentialTerm' :: Term -> Maybe Term +elimNegatedExistentialTerm' (TermExists _ _) = Nothing +elimNegatedExistentialTerm' (TermCall (ISymb "and") ts) = + case mapMaybe elimNegatedExistentialTerm' ts of + [] -> Just $ TermLit (LitBool True) + ts' -> Just $ TermCall (ISymb "and") ts' +elimNegatedExistentialTerm' t = Just t + +----------------------------------------- +-- Simplify by eliminatng any existentials from an implies that must be true. +-- This simplification actually does NOT keep exactly the same problem. +-- However, in practice, we never benefit from negated existentials on the LHS of an implies. + +simplifyImpliesExistentials :: [Cmd] -> [Cmd] +simplifyImpliesExistentials cmd = + map simplifyImpliesExistentials' cmd + +simplifyImpliesExistentials' :: Cmd -> Cmd +simplifyImpliesExistentials' (Constraint t) = Constraint $ simplifyImpliesExistentialsTerm t +simplifyImpliesExistentials' cmd = cmd + +simplifyImpliesExistentialsTerm :: Term -> Term +simplifyImpliesExistentialsTerm (TermCall (ISymb "=>") [lhs, rhs]) = + TermCall (ISymb "=>") [simplifyImpliesExistentialsTerm' lhs, rhs] +simplifyImpliesExistentialsTerm t = t + +simplifyImpliesExistentialsTerm' :: Term -> Term +simplifyImpliesExistentialsTerm' (TermCall (ISymb "and") and_ts) = + case map simplifyImpliesExistentialsTerm' and_ts of + [] -> TermLit $ LitBool True + and_ts' -> TermCall (ISymb "and") and_ts' +simplifyImpliesExistentialsTerm' (TermExists _ _) = TermLit $ LitBool True +simplifyImpliesExistentialsTerm' t = t diff --git a/src/G2/Liquid/Inference/Sygus/SpecInfo.hs b/src/G2/Liquid/Inference/Sygus/SpecInfo.hs new file mode 100644 --- /dev/null +++ b/src/G2/Liquid/Inference/Sygus/SpecInfo.hs @@ -0,0 +1,620 @@ +{-# LANGUAGE OverloadedStrings #-} + +module G2.Liquid.Inference.Sygus.SpecInfo where + +import G2.Language as G2 +import qualified G2.Language.ExprEnv as E +import G2.Liquid.Conversion +import G2.Liquid.Helpers +import G2.Liquid.Types hiding (SP) +import G2.Liquid.Inference.Config +import G2.Liquid.Inference.FuncConstraint +import G2.Liquid.Inference.G2Calls +import G2.Liquid.Inference.GeneratedSpecs +import G2.Liquid.Inference.PolyRef +import G2.Liquid.Inference.UnionPoly +import G2.Solver as Solver + +import Language.Haskell.Liquid.Types as LH hiding (SP, ms, isBool) +import Language.Fixpoint.Types.Refinements as LH hiding (pAnd, pOr) +import qualified Language.Fixpoint.Types as LH + +import Control.Monad +import qualified Control.Monad.State.Lazy as SM +import Data.Coerce +import qualified Data.HashMap.Lazy as HM +import qualified Data.List as L +import qualified Data.Map as M +import Data.Maybe +import qualified Data.Text as T +import Data.Semigroup (Semigroup (..)) + +type NMExprEnv = HM.HashMap (T.Text, Maybe T.Text) G2.Expr + +-- A list of functions that still must have specifications synthesized at a lower level +type ToBeNames = [Name] + +-- A list of functions to synthesize a the current level +type ToSynthNames = [Name] + + +data Forms = LIA { -- LIA formulas + c_active :: SMTName + + , c_op_branch1 :: SMTName + , c_op_branch2 :: SMTName + + , b0 :: SMTName + , ars_coeffs :: [SMTName] + , rets_coeffs :: [SMTName] } + | Set { c_active :: SMTName + , c_op_branch1 :: SMTName + , c_op_branch2 :: SMTName + + , int_sing_set_bools_lhs :: [[SMTName]] + , int_sing_set_bools_rhs :: [[SMTName]] + + , ars_bools_lhs :: [[SMTName]] + , rets_bools_lhs :: [[SMTName]] + + , ars_bools_rhs :: [[SMTName]] + , rets_bools_rhs :: [[SMTName]] + } + | BoolForm { c_active :: SMTName + , c_op_branch1 :: SMTName + , c_op_branch2 :: SMTName + + , ars_bools :: [SMTName] + , rets_bools :: [SMTName] + + , forms :: [Forms] + } + deriving Show + +coeffs :: Forms -> [SMTName] +coeffs cf@(LIA {}) = b0 cf:ars_coeffs cf ++ rets_coeffs cf +coeffs (Set {}) = [] +coeffs cf@(BoolForm {}) = concatMap coeffs (forms cf) + +coeffsNoB :: Forms -> [SMTName] +coeffsNoB cf@(LIA {}) = ars_coeffs cf ++ rets_coeffs cf +coeffsNoB (Set {}) = [] +coeffsNoB cf@(BoolForm {}) = concatMap coeffsNoB (forms cf) + +setBools :: Forms -> [SMTName] +setBools (LIA {}) = [] +setBools s@(Set {}) = + concat $ int_sing_set_bools_lhs s ++ int_sing_set_bools_rhs s ++ ars_bools_lhs s ++ rets_bools_lhs s ++ ars_bools_rhs s ++ rets_bools_rhs s +setBools cf@(BoolForm {}) = concatMap setBools (forms cf) + +boolBools :: Forms -> [SMTName] +boolBools (LIA {}) = [] +boolBools (Set {}) = [] +boolBools cf@(BoolForm {}) = ars_bools cf ++ rets_bools cf ++ concatMap boolBools (forms cf) + + +type Clause = (SMTName, [Forms]) +type CNF = [Clause] + +data SpecInfo = SI { s_max_coeff :: Integer + + -- A function that is used to record the value of the function at known points, + -- i.e. points that occur in the FuncConstraints + , s_known_pre :: FixedSpec + , s_known_post :: FixedSpec + + -- A function specification that must be synthesized in the future, at a lower level + , s_to_be_pre :: ToBeSpec + , s_to_be_post :: ToBeSpec + + -- Functions that capture the pre and post condition. + -- We have one precondition function per argument + , s_syn_pre :: [PolyBound SynthSpec] + , s_syn_post :: PolyBound SynthSpec + + , s_type_pre :: [Type] + , s_type_post :: Type + + , s_status :: Status } + deriving (Show) + +s_known_pre_name :: SpecInfo -> SMTName +s_known_pre_name = fs_name . s_known_pre + +s_known_post_name :: SpecInfo -> SMTName +s_known_post_name = fs_name . s_known_post + +s_to_be_pre_name :: SpecInfo -> SMTName +s_to_be_pre_name = tb_name . s_to_be_pre + +s_to_be_post_name :: SpecInfo -> SMTName +s_to_be_post_name = tb_name . s_to_be_post + +data FixedSpec = FixedSpec { fs_name :: SMTName + , fs_args :: [SpecArg] } + deriving (Show) + +data ToBeSpec = ToBeSpec { tb_name :: SMTName + , tb_args :: [SpecArg] } + deriving (Show) + +data SynthSpec = SynthSpec { sy_name :: SMTName + , sy_args :: [SpecArg] + , sy_rets :: [SpecArg] + , sy_coeffs :: CNF } + deriving (Show) + +sy_args_and_ret :: SynthSpec -> [SpecArg] +sy_args_and_ret si = sy_args si ++ sy_rets si + +int_sy_args :: SynthSpec -> [SpecArg] +int_sy_args = filter (\a -> smt_sort a == SortInt) . sy_args + +int_sy_rets :: SynthSpec -> [SpecArg] +int_sy_rets = filter (\a -> smt_sort a == SortInt) . sy_rets + +set_sy_args :: SynthSpec -> [SpecArg] +set_sy_args = filter (isSet . smt_sort) . sy_args + +set_sy_rets :: SynthSpec -> [SpecArg] +set_sy_rets = filter (isSet . smt_sort) . sy_rets + +bool_sy_args :: SynthSpec -> [SpecArg] +bool_sy_args = filter (\a -> smt_sort a == SortBool) . sy_args + +bool_sy_rets :: SynthSpec -> [SpecArg] +bool_sy_rets = filter (\a -> smt_sort a == SortBool) . sy_rets + +isSet :: Sort -> Bool +isSet (SortArray _ _) = True +isSet _ = False + +int_sy_args_and_ret :: SynthSpec -> [SpecArg] +int_sy_args_and_ret si = int_sy_args si ++ int_sy_rets si + +set_sy_args_and_ret :: SynthSpec -> [SpecArg] +set_sy_args_and_ret si = set_sy_args si ++ set_sy_rets si + +bool_sy_args_and_ret :: SynthSpec -> [SpecArg] +bool_sy_args_and_ret si = bool_sy_args si ++ bool_sy_rets si + +all_sy_args_and_ret :: SynthSpec -> [SpecArg] +all_sy_args_and_ret si = int_sy_args_and_ret si ++ set_sy_args_and_ret si ++ bool_sy_args_and_ret si + +data SpecArg = SpecArg { lh_rep :: LH.Expr + , smt_var :: SMTName + , smt_sort :: Sort} + deriving (Show) + +data Status = Synth -- ^ A specification should be synthesized + | ToBeSynthed -- ^ The specification will be synthesized at some lower level + | Known -- ^ The specification is completely fixed + deriving (Eq, Show) + +buildNMExprEnv :: ExprEnv -> NMExprEnv +buildNMExprEnv = HM.fromList . map (\(n, e) -> ((nameOcc n, nameModule n), e)) . E.toExprList + +buildSpecInfo :: (InfConfigM m, ProgresserM m) => + NMExprEnv + -> TypeEnv + -> TypeClasses + -> Measures + -> [GhcInfo] + -> FuncConstraints + -> UnionedTypes + -> ToBeNames + -> ToSynthNames + -> m (M.Map Name SpecInfo) +buildSpecInfo eenv tenv tc meas ghci fc ut to_be_ns ns_synth = do + -- Compensate for zeroed out names in FuncConstraints + let ns_synth' = map zeroOutName ns_synth + + -- Figure out what the other functions relevant to the current spec are + let all_calls = concatMap allCallNames $ toListFC fc + non_ns = filter (`notElem` ns_synth') all_calls + + -- Form tuples of: + -- (1) Func Names + -- (2) Function Argument Types + -- (3) Function Known Types + -- to be used in forming SpecInfo's + let ns_aty_rty = map (relNameTypePairs eenv) ns_synth' + + other_aty_rty = map (relNameTypePairs eenv) non_ns + to_be_ns' = map zeroOutName to_be_ns + (to_be_ns_aty_rty, known_ns_aty_rty) = L.partition (\(n, _) -> n `elem` to_be_ns') other_aty_rty + + + si <- foldM (\m (n, (at, rt)) -> do + s <- buildSI tenv tc meas ut Synth ghci n at rt + return $ M.insert n s m) M.empty ns_aty_rty + si' <- foldM (\m (n, (at, rt)) -> do + s <- buildSI tenv tc meas ut ToBeSynthed ghci n at rt + return $ M.insert n s m) si to_be_ns_aty_rty + si'' <- foldM (\m (n, (at, rt)) -> do + s <- buildSI tenv tc meas ut Known ghci n at rt + return $ M.insert n s m) si' known_ns_aty_rty + + inf_con <- infConfigM + + let si''' = if use_invs inf_con + then allCondsKnown . conflateLoopNames . elimSyArgs $ si'' + else si'' + + return si''' + where + zeroOutName (Name n m _ l) = Name n m 0 l + +relNameTypePairs :: NMExprEnv -> Name -> (Name, ([Type], Type)) +relNameTypePairs eenv n = + case HM.lookup (nameOcc n, nameModule n) eenv of + Just e' -> (n, generateRelTypesFromExpr e') + Nothing -> error $ "synthesize: No expr found" + +generateRelTypesFromExpr :: G2.Expr -> ([Type], Type) +generateRelTypesFromExpr = generateRelTypes . inTyForAlls . typeOf + +generateRelTypes :: Type -> ([Type], Type) +generateRelTypes t = + let + ty_e = PresType t + arg_ty_c = filter (not . isTYPE) + . filter (notLH) + $ argumentTypes ty_e + ret_ty_c = returnType ty_e + in + (arg_ty_c, ret_ty_c) + +------------------------------------ +-- Building SpecInfos +------------------------------------ + +buildSI :: (InfConfigM m, ProgresserM m) => TypeEnv -> TypeClasses -> Measures -> UnionedTypes -> Status -> [GhcInfo] -> Name -> [Type] -> Type -> m SpecInfo +buildSI tenv tc meas uts stat ghci f aty rty = do + let smt_f = nameToStr f + fspec = case genSpec ghci f of + Just spec' -> spec' + _ -> error $ "synthesize: No spec found for " ++ show f + + (outer_ars_pb, ret_pb) <- argsAndRetFromSpec tenv tc ghci meas [] aty rty fspec + let outer_ars = map fst outer_ars_pb + ret_v = headValue ret_pb + + arg_ns = zipWith (\a i -> a { smt_var = "x_" ++ show i } ) (concat outer_ars) ([1..] :: [Integer]) + ret_ns = zipWith (\r i -> r { smt_var = "x_r_" ++ show i }) (aar_r ret_v) ([1..] :: [Integer]) + + let ut = case lookupUT f uts of + Just _ut -> _ut + Nothing -> error $ "buildSI: Missing UnionedType " ++ show f + (ut_a, ut_r) = generateRelTypes ut + ut_a' = reverse . take (length outer_ars_pb) $ reverse ut_a + -- smt_names = assignNamesAndArgCount ut + smt_names = assignNamesAndArgCount $ mkTyFun (ut_a' ++ [ut_r]) + + pre_specs = + zipWith3 (\ars_pb ut_ar i -> + let + ut_pb = extractTypeAppAndFuncPolyBound ut_ar + + ars = map fst (init ars_pb) + r_pb = snd (last ars_pb) + in + mapPB (\(AAndR { aar_a = ex_a, aar_r = rets }, t, j) -> + case unTyApp t of + TyVar (Id ut_n _):_ -> + let + (nme, count) = fromMaybe + ("_synth_pre_filler_" ++ show i ++ "_" ++ show j, 0) + (HM.lookup ut_n smt_names) + in + SynthSpec { sy_name = smt_f ++ "_spec" ++ nme + , sy_args = zipWith (\a k -> a { smt_var = "x_" ++ show k}) (concat (take count ars) ++ ex_a) ([1..] :: [Integer]) + , sy_rets = zipWith (\r k -> r { smt_var = "x_r_" ++ show k}) rets ([1..] :: [Integer]) + , sy_coeffs = []} + TyFun _ _:_ -> + SynthSpec { sy_name = smt_f ++ "_synth_pre_filler_" ++ show i ++ "_" ++ show j + , sy_args = [] + , sy_rets = [] + , sy_coeffs = []} + _ -> error "buildSI: unsupported Type" + ) $ zip3PB r_pb ut_pb (uniqueIds r_pb) + ) (filter (not . null) $ L.inits outer_ars_pb) ut_a' ([1..] :: [Integer]) + + return + SI { s_max_coeff = 0 + , s_known_pre = FixedSpec { fs_name = smt_f ++ "_known_pre" + , fs_args = arg_ns } + , s_known_post = FixedSpec { fs_name = smt_f ++ "_known_post" + , fs_args = arg_ns ++ ret_ns } + , s_to_be_pre = ToBeSpec { tb_name = smt_f ++ "_to_be_pre" + , tb_args = arg_ns } + , s_to_be_post = ToBeSpec { tb_name = smt_f ++ "_to_be_post" + , tb_args = arg_ns ++ ret_ns } + , s_syn_pre = pre_specs + , s_syn_post = mkSynSpecPB smt_f outer_ars (mapPB aar_r ret_pb) smt_names ut_r + + , s_type_pre = aty + , s_type_post = rty + + , s_status = stat } + +data ArgsAndRet = AAndR { aar_a :: [SpecArg], aar_r :: [SpecArg] } deriving Show + +instance Semigroup ArgsAndRet where + AAndR { aar_a = a1, aar_r = r1 } <> AAndR { aar_a = a2, aar_r = r2 } = AAndR { aar_a = a1 <> a2, aar_r = r1 <> r2 } + +instance Monoid ArgsAndRet where + mempty = AAndR { aar_a = [], aar_r = [] } + +argsAndRetFromSpec :: (InfConfigM m, ProgresserM m) => TypeEnv -> TypeClasses -> [GhcInfo] -> Measures -> [([SpecArg], PolyBound ArgsAndRet)] -> [Type] -> Type -> SpecType + -> m ([([SpecArg], PolyBound ArgsAndRet)], PolyBound ArgsAndRet) +argsAndRetFromSpec tenv tc ghci meas ars ts rty (RAllT { rt_ty = out }) = + argsAndRetFromSpec tenv tc ghci meas ars ts rty out +argsAndRetFromSpec tenv tc ghci meas ars (t:ts) rty (RFun { rt_in = rfun@(RFun {}), rt_out = out}) = do + let (ts', rty') = generateRelTypes t + (f_ars, f_ret) <- argsAndRetFromSpec tenv tc ghci meas ars ts' rty' rfun + let f_ret_list = case f_ret of + PolyBound (AAndR { aar_a = [], aar_r = [] }) [] -> [] + _ -> [f_ret] + f_ars_sa = map fst f_ars + f_ars' = zipWith (\sa pb -> mapPB (AAndR (concat sa)) pb) (L.inits f_ars_sa) (map (mapPB aar_r) $ map snd f_ars ++ f_ret_list) + argsAndRetFromSpec tenv tc ghci meas (([], PolyBound mempty f_ars'):ars) ts rty out +argsAndRetFromSpec tenv tc ghci meas ars (t:ts) rty rfun@(RFun { rt_in = i, rt_out = out}) = do + (m_out_symb, sa) <- mkSpecArgPB ghci tenv meas t rfun + let out_symb = case m_out_symb of + Just os -> os + Nothing -> error "argsAndRetFromSpec: out_symb is Nothing" + case i of + RVar {} -> argsAndRetFromSpec tenv tc ghci meas ars ts rty out + RFun {} -> argsAndRetFromSpec tenv tc ghci meas ars ts rty out + _ -> argsAndRetFromSpec tenv tc ghci meas ((out_symb, sa):ars) ts rty out +argsAndRetFromSpec tenv _ ghci meas ars _ rty rapp@(RApp {}) = do + (_, sa) <- mkSpecArgPB ghci tenv meas rty rapp + return (reverse ars, sa) +argsAndRetFromSpec tenv _ ghci meas ars _ rty rvar@(RVar {}) = do + (_, sa) <- mkSpecArgPB ghci tenv meas rty rvar + return (reverse ars, sa) +argsAndRetFromSpec _ _ _ _ _ [] _ st@(RFun {}) = error $ "argsAndRetFromSpec: RFun with empty type list " ++ show st +argsAndRetFromSpec _ _ _ _ _ _ _ st = error $ "argsAndRetFromSpec: unhandled SpecType " ++ show st + +mkSpecArgPB :: (InfConfigM m, ProgresserM m) => [GhcInfo] -> TypeEnv -> Measures -> Type -> SpecType -> m (Maybe [SpecArg], PolyBound ArgsAndRet) +mkSpecArgPB ghci tenv meas t st = do + MaxSize mx_meas <- maxSynthFormSizeM + let t_pb = extractTypePolyBound t + + sy_pb = specTypeSymbolPB st + in_sy_pb = mapPB inner sy_pb + + t_sy_pb = filterPBByType snd $ zipPB in_sy_pb t_pb + t_sy_pb' = case t_sy_pb of + Just pb -> pb + Nothing -> PolyBound (inner $ headValue sy_pb, t) [] + + out_symb = outer $ headValue sy_pb + out_spec_arg = fmap (\os -> mkSpecArg (fromInteger mx_meas) ghci tenv meas os t) out_symb + + return (out_spec_arg, mapPB (ret . uncurry (mkSpecArg (fromInteger mx_meas) ghci tenv meas)) t_sy_pb') + + +mkSpecArg :: Int -> [GhcInfo] -> TypeEnv -> Measures -> LH.Symbol -> Type -> [SpecArg] +mkSpecArg mx_meas ghci tenv meas symb t = + let + srt = typeToSort t + in + case srt of + Just srt' -> + [SpecArg { lh_rep = EVar symb + , smt_var = "tbd" + , smt_sort = srt' }] + Nothing -> + let + app_meas = applicableMeasuresType mx_meas tenv meas t + app_meas' = L.sortBy (\(n1, _) (n2, _) -> compare n1 n2) app_meas + in + mapMaybe + (\(mn, (at, rt)) -> + let vm = t `specializes` at in + case vm of + Just vm' -> + let + + rt' = applyTypeMap vm' rt + in + fmap (\srt' -> + let + lh_mn = map (getLHMeasureName ghci) mn + in + SpecArg { lh_rep = foldr EApp (EVar symb) $ map EVar lh_mn + , smt_var = "tbd" + , smt_sort = srt'}) $ typeToSort rt' + Nothing -> Nothing) app_meas' + +ret :: [SpecArg] -> ArgsAndRet +ret sa = AAndR { aar_a = [], aar_r = sa } + +mkSynSpecPB :: String -> [[SpecArg]] -> PolyBound [SpecArg] -> HM.HashMap Name (SMTName, Int) -> Type -> PolyBound SynthSpec +mkSynSpecPB smt_f ars pb_sa smt_names ut = + let + ut_pb = extractTypePolyBound ut + in + mapPB (\(sa, t, ui) -> + let + TyVar (Id ut_n _):_ = unTyApp t + (nme, count) = fromMaybe + ("_synth_post_filler", 0) + (HM.lookup ut_n smt_names) + arg_ns = zipWith (\a i -> a { smt_var = "x_" ++ show i } ) (concat . take count $ ars) ([1..] :: [Integer]) + ret_ns = map (\(r, i) -> r { smt_var = "x_r_" ++ show ui ++ "_" ++ show i }) $ zip sa ([1..] :: [Integer]) + in + SynthSpec { sy_name = smt_f ++ "_spec" ++ nme -- smt_f ++ show ui + , sy_args = arg_ns + , sy_rets = ret_ns + , sy_coeffs = [] } + ) + $ zip3PB pb_sa ut_pb (uniqueIds pb_sa) + +filterPBByType :: (v -> Type) -> PolyBound v -> Maybe (PolyBound v) +filterPBByType f = filterPB (\(PolyBound v _) -> + let + t = f v + in + not (isTyVar t)) + +assignNamesAndArgCount :: Type -> HM.HashMap Name (SMTName, Int) +assignNamesAndArgCount t = SM.evalState (assignNamesAndArgCount' 0 HM.empty t) 0 + +assignNamesAndArgCount' :: Int -> HM.HashMap Name (SMTName, Int) -> Type -> SM.State Int (HM.HashMap Name (SMTName, Int)) +assignNamesAndArgCount' ar_count hm (TyVar (Id n k)) + | Nothing <- HM.lookup n hm = do + pos <- SM.get + SM.modify' (+ 1) + return $ HM.insert n ("_synth_" ++ show ar_count ++ "_" ++ show pos, ar_count) hm + | otherwise = return hm +assignNamesAndArgCount' ar_count hm (TyFun t1 t2) = do + hm' <- assignNamesAndArgCount' ar_count hm t1 + assignNamesAndArgCount' (ar_count + 1) hm' t2 +assignNamesAndArgCount' ar_count hm (TyApp t1 t2) = do + hm' <- assignNamesAndArgCount' ar_count hm t1 + assignNamesAndArgCount' ar_count hm' t2 +assignNamesAndArgCount' ar_count hm (TyForAll _ t) = assignNamesAndArgCount' ar_count hm t +assignNamesAndArgCount' _ hm _ = return hm + +---------------------------------------------------------------------------- +-- Manipulate Evals +---------------------------------------------------------------------------- + +-- We assign a unique id to each function call, and use these as the arguments +-- to the known functions, rather than somehow using the arguments directly. +-- This means we can get away with needing only a single known function +-- for the pre, and a single known function for the post, as opposed +-- to needing individual known functions/function calls for polymorphic refinements. +assignIds :: Evals Bool -> Evals (Integer, Bool) +assignIds = snd . mapAccumLEvals (\i b -> (i + 1, (i, b))) 0 + +---------------------------------------------------------------------------- +-- Manipulate SpecTypes +---------------------------------------------------------------------------- + +data SymbolPair = SP { inner :: LH.Symbol, outer :: Maybe LH.Symbol } + +specTypeSymbolPB :: SpecType -> PolyBound SymbolPair +specTypeSymbolPB (RFun { rt_bind = b, rt_in = i }) = + case specTypeSymbolPB i of + PolyBound sp ps -> PolyBound (sp { outer = Just b}) ps +specTypeSymbolPB (RApp { rt_reft = ref, rt_args = ars }) = + PolyBound (SP { inner = reftSymbol $ ur_reft ref, outer = Nothing}) $ map specTypeSymbolPB ars +specTypeSymbolPB (RVar {rt_reft = ref}) = + PolyBound (SP { inner = reftSymbol $ ur_reft ref, outer = Nothing }) [] +specTypeSymbolPB r = error $ "specTypeSymbolPB: Unexpected SpecType" ++ "\n" ++ show r + +reftSymbol :: Reft -> LH.Symbol +reftSymbol = fst . unpackReft + +unpackReft :: Reft -> (LH.Symbol, LH.Expr) +unpackReft = coerce + +---------------------------------------------------------------------------- +-- Invariant configuration +---------------------------------------------------------------------------- + +elimPolyArgSpecs :: M.Map a SpecInfo -> M.Map a SpecInfo +elimPolyArgSpecs = M.map elimPolyArgSpecs' + +elimPolyArgSpecs' :: SpecInfo -> SpecInfo +elimPolyArgSpecs' si = si { s_syn_pre = map (\(PolyBound a _) -> PolyBound a []) (s_syn_pre si) + , s_syn_post = (\(PolyBound a _) -> PolyBound a []) (s_syn_post si)} + +elimSyArgs :: M.Map Name SpecInfo -> M.Map Name SpecInfo +elimSyArgs = M.mapWithKey (\n si -> if specialFunction n then elimSyArgs' si else si) + +elimSyArgs' :: SpecInfo -> SpecInfo +elimSyArgs' si = si { s_syn_pre = map (mapPB dropNonDirectInt) (s_syn_pre si) + , s_syn_post = mapPB dropNonDirectInt (s_syn_post si)} + +dropNonDirectInt :: SynthSpec -> SynthSpec +dropNonDirectInt sy = sy { sy_args = filter dropNonDirectInt' (sy_args sy) } + +dropNonDirectInt' :: SpecArg -> Bool +dropNonDirectInt' sy = + case lh_rep sy of + EVar {} -> True + _ -> False + +specialFunction :: Name -> Bool +specialFunction (Name n _ _ _) | T.take 4 n == "loop" = True + | T.take 5 n == "while" = True + | T.take 5 n == "breakWhile" = True + | otherwise = False + +conflateLoopNames :: M.Map a SpecInfo -> M.Map a SpecInfo +conflateLoopNames = M.map conflateLoopNames' + +conflateLoopNames' :: SpecInfo -> SpecInfo +conflateLoopNames' si@(SI { s_syn_pre = pb_sy_pre@(_:_) + , s_syn_post = pb_post@(PolyBound sy_post _) }) + | take 4 (sy_name sy_post) == "loop" = + let + pb_pre = last pb_sy_pre + in + si { s_syn_pre = init pb_sy_pre ++ [conflateLoopNames'' pb_pre pb_post] } +conflateLoopNames' si = si + +conflateLoopNames'' :: PolyBound SynthSpec -> PolyBound SynthSpec -> PolyBound SynthSpec +conflateLoopNames'' pb1 = mapPB (\(sy1, sy2) -> sy1 { sy_name = sy_name sy2} ) . zipPB pb1 + +allCondsKnown :: M.Map a SpecInfo -> M.Map a SpecInfo +allCondsKnown = M.map allCondsKnown' + +allCondsKnown' :: SpecInfo -> SpecInfo +allCondsKnown' si@(SI { s_syn_post = (PolyBound sy_post _) }) + | take 4 (sy_name sy_post) == "cond" = si { s_status = Known } +allCondsKnown' si = si + +---------------------------------------------------------------------------- + +typeToSort :: Type -> Maybe Sort +typeToSort (TyApp (TyCon (Name n _ _ _) _) t) + | n == "Set" + , Just s <- typeToSort t = Just (SortArray s SortBool) +typeToSort (TyCon (Name n _ _ _) _) + | n == "Int" = Just SortInt + | n == "Bool" = Just SortBool +typeToSort _ = Nothing + +getLHMeasureName :: [GhcInfo] -> Name -> LH.Symbol +getLHMeasureName ghci (Name n m _ l) = + let + MeasureSymbols meas_symb = measureSymbols ghci + zn = Name n m 0 l + in + case L.find (\meas -> symbolName meas == zn) meas_symb of + Just meas -> meas + Nothing -> error "getLHMeasureName: unhandled measure" + +applicableMeasuresType :: Int -> TypeEnv -> Measures -> Type -> [([Name], (Type, Type))] +applicableMeasuresType mx_meas tenv meas t = + HM.toList . HM.map (\es -> case filter notLH . anonArgumentTypes $ last es of + [at] + | Just (rt, _) <- chainReturnType t es -> (at, rt) + _ -> error $ "applicableMeasuresType: too many arguments" ++ "\n" ++ show es) + $ applicableMeasures mx_meas tenv meas t + +applicableMeasures :: Int -> TypeEnv -> Measures -> Type -> HM.HashMap [Name] [G2.Expr] +applicableMeasures mx_meas tenv meas t = + HM.fromList . map unzip + . filter repFstSnd + . filter (maybe False (isJust . typeToSort . fst) . chainReturnType t . map snd) + $ formMeasureComps mx_meas tenv t meas + +-- LiquidHaskell includes measures to extract from tuples of various sizes. +-- It includes redundant pairs (fst and x_Tuple21) and (snd and x_Tuple22). +-- Including both measures slows down the synthesis, so we eliminates +-- chains involving x_Tuple21 and x_Tuple22. +repFstSnd :: [(Name, a)] -> Bool +repFstSnd = all (\(Name n _ _ _) -> n /= "x_Tuple21" && n /= "x_Tuple22") . map fst + +notLH :: Type -> Bool +notLH ty + | TyCon (Name n _ _ _) _ <- tyAppCenter ty = n /= "lh" + | otherwise = True + diff --git a/src/G2/Liquid/Inference/Sygus/Sygus.hs b/src/G2/Liquid/Inference/Sygus/Sygus.hs new file mode 100644 --- /dev/null +++ b/src/G2/Liquid/Inference/Sygus/Sygus.hs @@ -0,0 +1,417 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +module G2.Liquid.Inference.Sygus.Sygus where + +import G2.Language as G2 +import G2.Liquid.Interface +import G2.Liquid.Types +import G2.Liquid.Inference.Config +import G2.Liquid.Inference.FuncConstraint +import G2.Liquid.Inference.G2Calls +import G2.Liquid.Inference.PolyRef +import G2.Liquid.Inference.UnionPoly +import G2.Liquid.Inference.Sygus.FCConverter +import G2.Liquid.Inference.Sygus.SpecInfo +import G2.Solver as Solver + +import Sygus.LexSygus +import Sygus.ParseSygus +import Sygus.Print +import Sygus.Syntax as Sy + +import Control.Monad.IO.Class +import Data.Hashable +import qualified Data.HashMap.Lazy as HM +import qualified Data.HashSet as HS +import Data.List +import qualified Data.Map as M +import Data.Maybe +import Data.Ratio +import qualified Data.Text as T + +import Language.Haskell.Liquid.Types as LH hiding (SP, ms, isBool) + +generateSygusProblem :: (InfConfigM m, ProgresserM m, MonadIO m) => + [GhcInfo] + -> LiquidReadyState + -> Evals Bool + -> MeasureExs + -> FuncConstraints + -> UnionedTypes + -> ToBeNames + -> ToSynthNames + -> m [Cmd] +generateSygusProblem ghci lrs evals meas_ex fc ut to_be_ns ns_synth = do + -- Figure out the type of each of the functions we need to synthesize + let eenv = buildNMExprEnv $ expr_env . state $ lr_state lrs + tenv = type_env . state $ lr_state lrs + tc = type_classes . state $ lr_state lrs + meas = lrsMeasures ghci lrs + + si <- buildSpecInfo eenv tenv tc meas ghci fc ut to_be_ns ns_synth + + let grammar = buildGrammars si + + let eval_ids = assignIds evals + to_be_consts = createToBeConsts si eval_ids + constraints <- constraintsToSygus eenv tenv meas meas_ex eval_ids si fc + + let cmds = [ SmtCmd (Sy.SetLogic "ALL")] ++ to_be_consts ++ grammar ++ constraints ++ [CheckSynth] + + liftIO $ putStrLn "-------------\nSyGuS\n" + liftIO . putStrLn . T.unpack . printSygus $ cmds + liftIO $ putStrLn "-------------" + + return cmds + +------------------------------- +-- Grammar +------------------------------- + +buildGrammars :: M.Map Name SpecInfo -> [Cmd] +buildGrammars = + concatMap buildGrammars' . M.elems . M.filter (\si -> s_status si == Synth) + +buildGrammars' :: SpecInfo -> [Cmd] +buildGrammars' si = + map buildGrammars'' $ extractValues (s_syn_post si) ++ concatMap extractValues (s_syn_pre si) + +buildGrammars'' :: SynthSpec -> Cmd +buildGrammars'' sy_spec = + SynthFun (sy_name sy_spec) + (map buildGramArgs $ sy_args_and_ret sy_spec) + (IdentSort (ISymb "Bool")) + . Just $ buildGrammar sy_spec + +buildGramArgs :: SpecArg -> SortedVar +buildGramArgs sa = SortedVar (smt_var sa) (smtSortToSygusSort $ smt_sort sa) + +buildGrammar :: SynthSpec -> GrammarDef +buildGrammar sy_spec = + -- forceVarInGrammar (buildGramArgs $ sy_rets sy_spec) + -- (map buildGramArgs $ sy_args sy_spec) + (buildGrammar' sy_spec) + +buildGrammar' :: SynthSpec -> GrammarDef +buildGrammar' sy_spec = + GrammarDef + [ SortedVar "B" (IdentSort (ISymb "Bool")) + , SortedVar "IConst" (IdentSort (ISymb "Int")) + , SortedVar "I" (IdentSort (ISymb "Int"))] + [ GroupedRuleList "B" (IdentSort (ISymb "Bool")) + [ GVariable (IdentSort (ISymb "Bool")) + , GConstant (IdentSort (ISymb "Bool")) + , GBfTerm (BfIdentifierBfs (ISymb "=") [BfIdentifier (ISymb "I"), BfIdentifier (ISymb "I")]) + , GBfTerm (BfIdentifierBfs (ISymb ">") [BfIdentifier (ISymb "I"), BfIdentifier (ISymb "I")]) + , GBfTerm (BfIdentifierBfs (ISymb ">=") [BfIdentifier (ISymb "I"), BfIdentifier (ISymb "I")]) + ] + , GroupedRuleList "IConst" (IdentSort (ISymb "Int")) + [ GConstant (IdentSort (ISymb "Int")) ] + , GroupedRuleList "I" (IdentSort (ISymb "Int")) + [ GVariable (IdentSort (ISymb "Int")) + , GConstant (IdentSort (ISymb "Int")) + , GBfTerm (BfIdentifierBfs (ISymb "+") [BfIdentifier (ISymb "I"), BfIdentifier (ISymb "I")]) + , GBfTerm (BfIdentifierBfs (ISymb "*") [BfIdentifier (ISymb "IConst"), BfIdentifier (ISymb "I")]) + ] + ] + +------------------------------- +-- Constraints +------------------------------- + +constraintsToSygus :: (InfConfigM m, ProgresserM m) => + NMExprEnv + -> TypeEnv + -> Measures + -> MeasureExs + -> Evals (Integer, Bool) + -> M.Map Name SpecInfo + -> FuncConstraints + -> m [Cmd] +constraintsToSygus eenv tenv meas meas_ex evals si fc = + return . map Constraint =<< + convertConstraints + convertExprToTerm + (ifNotNull mkSygusAnd (TermLit (LitBool True))) + (ifNotNull mkSygusOr (TermLit (LitBool False))) + mkSygusNot + mkSygusImplies + (\s -> TermCall (ISymb s)) + (\_ _ -> TermLit . LitBool) + (\n i b -> + if b then + TermIdent (ISymb $ n ++ "__SYGUS_INT__" ++ show i) + else TermLit (LitBool False)) + eenv tenv meas meas_ex evals si fc + where + ifNotNull _ def [] = def + ifNotNull f _ xs = f xs + + mkSygusAnd = TermCall (ISymb "and") + mkSygusOr = TermCall (ISymb "or") + mkSygusNot t = TermCall (ISymb "not") [t] + mkSygusImplies t1 t2 = TermCall (ISymb "=>") [t1, t2] + +convertExprToTerm :: G2.Expr -> Term +convertExprToTerm (Data (DataCon (Name n _ _ _) _)) + | "True" <- n = TermLit $ LitBool True + | "False" <- n =TermLit $ LitBool False +convertExprToTerm (Lit l) = litToTerm l +convertExprToTerm e = error $ "convertExprToTerm: Unhandled Expr " ++ show e + +litToTerm :: G2.Lit -> Term +litToTerm (LitInt i) = TermLit (LitNum i) +litToTerm (LitDouble d) = TermCall (ISymb "/") [ TermLit . LitNum $ numerator d + , TermLit . LitNum $ denominator d] +litToTerm (LitChar c) = TermLit (LitStr [c]) +litToTerm _ = error "litToTerm: Unhandled Lit" + +createToBeConsts :: M.Map Name SpecInfo -> Evals (Integer, Bool) -> [Cmd] +createToBeConsts si ev = + let si' = M.mapKeys zeroOutName si in + createToBeConsts' s_to_be_pre_name si' (pre_evals ev) + ++ createToBeConsts' s_to_be_post_name si' (post_evals ev) + where + zeroOutName (Name n m _ l) = Name n m 0 l + + +createToBeConsts' :: (SpecInfo -> SMTName) -> M.Map Name SpecInfo -> FCEvals ((Integer, Bool)) -> [Cmd] +createToBeConsts' f si = mapMaybe (createToBeConsts'' f si) + . concatMap (\(n, es) -> map (n,) es) + . HM.toList + . HM.map HM.elems + +createToBeConsts'' :: (SpecInfo -> SMTName) -> M.Map Name SpecInfo -> (Name, (Integer, Bool)) -> Maybe Cmd +createToBeConsts'' f si (n, (i, _)) + | Just si' <- M.lookup n si + , s_status si' == ToBeSynthed = + Just $ DeclareVar (f si' ++ "__SYGUS_INT__" ++ show i) (IdentSort (ISymb "Bool")) + | otherwise = Nothing + +------------------------------- +-- Sorts +------------------------------- + +smtSortToSygusSort :: Solver.Sort -> Sy.Sort +smtSortToSygusSort SortBool = IdentSort (ISymb "Bool") +smtSortToSygusSort SortInt = IdentSort (ISymb "Int") +smtSortToSygusSort s = error $ "smtSortToSygusSort: unsupported sort" ++ "\n" ++ show s + +------------------------------- +-- Enforcing return value use +------------------------------- + +-- Adjusts a grammar to force using a given GTerm + +forceVarInGrammar :: SortedVar -- ^ The variable to force + -> [SortedVar] -- ^ All other variables + -> GrammarDef + -> GrammarDef +forceVarInGrammar vr params (GrammarDef sv grls) = + let + prod_srt = mapMaybe (\grl@(GroupedRuleList grl_symb _ _) -> + if any (flip canProduceVar grl) (vr:params) + then Just grl_symb + else Nothing ) grls + + reach = gramSymbReachableFrom prod_srt grls + + sv_reach = concatMap (grammarDefSortedVars reach) sv + + (sv_final, grl_final) = elimNonTermGRL vr (forceVarInGRLList vr reach grls) sv_reach + in + GrammarDef sv_final grl_final + +forceVarInGRLList :: SortedVar -> [Symbol] -> [GroupedRuleList] -> [GroupedRuleList] +forceVarInGRLList vr reach grls = + let + fv_map = HM.fromList $ map (\n -> (toBf n, toBf $ forcedVarSymb n)) reach + + in + concatMap (forceVarInGRL vr reach fv_map) grls + where + toBf = BfIdentifier . ISymb + +forceVarInGRL :: SortedVar -> [Symbol] -> HM.HashMap BfTerm BfTerm -> GroupedRuleList -> [GroupedRuleList] +forceVarInGRL (SortedVar sv_symb sv_srt) reach fv_map grl@(GroupedRuleList grl_symb grl_srt gtrms) + | grl_symb `elem` reach = + let + bf_var = BfIdentifier (ISymb sv_symb) + fv_gtrms' = if sv_srt == grl_srt + then GBfTerm bf_var:(filter (not . isClamp) $ elimVariable fv_gtrms) + else filter (not . isClamp) $ elimVariable fv_gtrms + in + [GroupedRuleList fv_symb grl_srt fv_gtrms', grl] + | otherwise = [grl] + where + fv_symb = forcedVarSymb grl_symb + fv_gtrms = substOnceGTerms fv_map gtrms + + +forcedVarSymb :: Symbol -> Symbol +forcedVarSymb = ("fv_" ++) + +elimVariable :: [GTerm] -> [GTerm] +elimVariable = filter (\t -> case t of + GVariable _ -> False + _ -> True) + +elimNonTermGRL :: SortedVar -> [GroupedRuleList] -> [SortedVar] -> ([SortedVar], [GroupedRuleList]) +elimNonTermGRL (SortedVar sv_n _) grls sv = + let + has_term = hasTermFix (HS.singleton sv_n) grls + + sv' = filter (\(SortedVar n _) -> n `elem` has_term) sv + grls' = map (elimRules has_term) + $ filter (\(GroupedRuleList n _ _) -> n `elem` has_term) grls + in + (sv', grls') + +hasTermFix :: HS.HashSet Symbol -> [GroupedRuleList] -> [Symbol] +hasTermFix ht grl = + let + ht' = HS.fromList + . map (\(GroupedRuleList n _ _) -> n) + $ filter (hasTermGRL ht) grl + + + ht_all = HS.union ht ht' + in + if ht == ht_all then HS.toList ht_all else hasTermFix ht_all grl + +hasTermGRL :: HS.HashSet Symbol -> GroupedRuleList -> Bool +hasTermGRL ht (GroupedRuleList n _ r) = n `HS.member` ht || any (hasTermGTerm ht) r + +hasTermGTerm :: HS.HashSet Symbol -> GTerm -> Bool +hasTermGTerm _ (GConstant _) = True +hasTermGTerm _ (GVariable _) = True +hasTermGTerm ht (GBfTerm bft) = hasTermBfTerm ht bft + +hasTermBfTerm :: HS.HashSet Symbol -> BfTerm -> Bool +hasTermBfTerm ht (BfIdentifier (ISymb i)) = i `HS.member` ht +hasTermBfTerm _ (BfLiteral _) = True +hasTermBfTerm ht (BfIdentifierBfs _ bfs) = all (hasTermBfTerm ht) bfs + +isClamp :: GTerm -> Bool +isClamp (GBfTerm (BfIdentifier (ISymb "IClamp"))) = True +isClamp (GBfTerm (BfIdentifier (ISymb "DClamp"))) = True +isClamp _ = False + +elimRules :: [Symbol] -> GroupedRuleList -> GroupedRuleList +elimRules grls (GroupedRuleList symb srt r) = + GroupedRuleList symb srt $ filter (elimRules' grls) r + +elimRules' :: [Symbol] -> GTerm -> Bool +elimRules' _ (GConstant _) = True +elimRules' _ (GVariable _) = True +elimRules' grls (GBfTerm bft) = elimRulesBfT grls bft + +elimRulesBfT :: [Symbol] -> BfTerm -> Bool +elimRulesBfT grls (BfIdentifier (ISymb i)) = i `elem` grls +elimRulesBfT _ (BfLiteral _) = True +elimRulesBfT grls (BfIdentifierBfs _ bfs) = all (elimRulesBfT grls) bfs + +----------------------------------------------------- + +-- Substitution functions + +substOnceGTerms :: HM.HashMap BfTerm BfTerm -> [GTerm] -> [GTerm] +substOnceGTerms m = concatMap (substOnceGTerm m) + +substOnceGTerm :: HM.HashMap BfTerm BfTerm -> GTerm -> [GTerm] +substOnceGTerm m (GBfTerm bf) = map GBfTerm $ substOnceBfTerm m bf +substOnceGTerm _ gt = [gt] + +substOnceBfTerm :: HM.HashMap BfTerm BfTerm -> BfTerm -> [BfTerm] +substOnceBfTerm m (BfIdentifierBfs c bfs) = elimRedundant . map (BfIdentifierBfs c) $ substsOnces m bfs +substOnceBfTerm _ bf = [bf] + +elimRedundant :: [BfTerm] -> [BfTerm] +elimRedundant (b@(BfIdentifierBfs (ISymb s) [b1, b2]):xs) = + let + xs' = if isCommutative s + then delete (BfIdentifierBfs (ISymb s) [b2, b1]) xs + else xs + in + b:elimRedundant xs' +elimRedundant (x:xs) = x:elimRedundant xs +elimRedundant [] = [] + +isCommutative :: Symbol -> Bool +isCommutative "and" = True +isCommutative "=" = True +isCommutative "+" = True +isCommutative _ = False + +-- | Given: +-- * A mapping of list element to be replaced, to new elements +-- * A list, xs +-- returns a list of new lists. Each new list is xs, but with exactly one +-- occurence of an old element replaced by the corresponding new element. +substsOnces :: (Eq a, Hashable a) => HM.HashMap a a -> [a] -> [[a]] +substsOnces m = substsOnces' m [] + +substsOnces' :: (Eq a, Hashable a) => HM.HashMap a a -> [a] -> [a] -> [[a]] +substsOnces' _ _ [] = [] +substsOnces' m rv (x:xs) + | Just new <- HM.lookup x m = (reverse rv ++ new:xs):rst + | otherwise = rst + where + rst = substsOnces' m (x:rv) xs + +----------------------------------------------------- + +grammarDefSortedVars :: [Symbol] -> SortedVar -> [SortedVar] +grammarDefSortedVars symbs sv@(SortedVar n srt) + | n `elem` symbs = [SortedVar (forcedVarSymb n) srt, sv] + | otherwise = [sv] + +canProduceVar :: SortedVar -> GroupedRuleList -> Bool +canProduceVar vr@(SortedVar _ sv_srt) (GroupedRuleList _ grl_srt gtrms) + | sv_srt == grl_srt = any (canProduceVarGTerm vr) gtrms + | otherwise = False + +canProduceVarGTerm :: SortedVar -> GTerm -> Bool +canProduceVarGTerm (SortedVar _ sv_srt) (GVariable gv_srt) = sv_srt == gv_srt +canProduceVarGTerm (SortedVar s _) (GBfTerm (BfIdentifier (ISymb is))) = s == is +canProduceVarGTerm s (GBfTerm (BfIdentifierBfs _ bfs)) = any (canProduceVarGTerm s) $ map GBfTerm bfs +canProduceVarGTerm _ (GBfTerm (BfLiteral _)) = False +canProduceVarGTerm _ (GConstant _) = False +canProduceVarGTerm _ t = error $ "Unhandled term" ++ show t + +----------------------------------------------------- + +-- Reachability checks + +gramSymbReachableFrom :: [Symbol] -> [GroupedRuleList] -> [Symbol] +gramSymbReachableFrom = gramSymbReachableFrom' HS.empty + +gramSymbReachableFrom' :: HS.HashSet Symbol -> [Symbol] -> [GroupedRuleList] -> [Symbol] +gramSymbReachableFrom' searched [] _ = HS.toList searched +gramSymbReachableFrom' searched (x:xs) grls + | x `HS.member` searched = gramSymbReachableFrom' searched xs grls + | otherwise = + let + contains_x = map (\(GroupedRuleList s _ _) -> s) + $ filter (containsSymbol x) grls + in + gramSymbReachableFrom' (HS.insert x searched) (contains_x ++ xs) grls + +containsSymbol :: Symbol -> GroupedRuleList -> Bool +containsSymbol symb (GroupedRuleList _ _ gtrms) = any (containsSymbolGTerm symb) gtrms + +containsSymbolGTerm :: Symbol -> GTerm -> Bool +containsSymbolGTerm symb (GBfTerm bf) = containsSymbolBfTerm symb bf +containsSymbolGTerm _ _ = False + +containsSymbolBfTerm :: Symbol -> BfTerm -> Bool +containsSymbolBfTerm symb (BfIdentifier ident) = containsSymbolIdent symb ident +containsSymbolBfTerm symb (BfIdentifierBfs ident bfs) = + containsSymbolIdent symb ident || any (containsSymbolBfTerm symb) bfs +containsSymbolBfTerm _ (BfLiteral _) = False + +containsSymbolIdent :: Symbol -> Identifier -> Bool +containsSymbolIdent symb (ISymb symb') = symb == symb' +containsSymbolIdent _ _ = False + diff --git a/src/G2/Liquid/Inference/Sygus/UnsatCoreElim.hs b/src/G2/Liquid/Inference/Sygus/UnsatCoreElim.hs new file mode 100644 --- /dev/null +++ b/src/G2/Liquid/Inference/Sygus/UnsatCoreElim.hs @@ -0,0 +1,36 @@ +module G2.Liquid.Inference.Sygus.UnsatCoreElim (unsatCoreElim) where + +import Sygus.Syntax + +import Data.Maybe + +-- | Eliminates negative constraints that would lead to an unsat core +unsatCoreElim :: [Cmd] -> [Cmd] +unsatCoreElim cmds = + let + true_terms = mapMaybe getTrueTerm cmds + in + mapMaybe (unsatCoreElim' true_terms) cmds + +unsatCoreElim' :: [Term] -> Cmd -> Maybe Cmd +unsatCoreElim' ts cmd@(Constraint t) = + if mustBeFalse ts t then Nothing else Just cmd +unsatCoreElim' _ cmd = Just cmd + +mustBeFalse :: [Term] -> Term -> Bool +mustBeFalse ts (TermCall (ISymb "=>") [t1, t2]) = + mustBeTrue ts t1 && mustBeFalse ts t2 +mustBeFalse ts (TermCall (ISymb "not") [t1]) = mustBeTrue ts t1 +mustBeFalse ts (TermCall (ISymb "and") and_ts) = any (mustBeFalse ts) and_ts +mustBeFalse _ (TermLit (LitBool False)) = True +mustBeFalse _ _ = False + +mustBeTrue :: [Term] -> Term -> Bool +mustBeTrue ts (TermCall (ISymb "=>") [t1, t2]) = mustBeFalse ts t1 || mustBeTrue ts t2 +mustBeTrue ts (TermCall (ISymb "and") and_ts) = all (mustBeTrue ts) and_ts +mustBeTrue _ (TermLit (LitBool True)) = True +mustBeTrue ts t = t `elem` ts + +getTrueTerm :: Cmd -> Maybe Term +getTrueTerm (Constraint t) = Just t +getTrueTerm _ = Nothing diff --git a/src/G2/Liquid/Inference/UnionPoly.hs b/src/G2/Liquid/Inference/UnionPoly.hs new file mode 100644 --- /dev/null +++ b/src/G2/Liquid/Inference/UnionPoly.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE FlexibleContexts, OverloadedStrings #-} + +module G2.Liquid.Inference.UnionPoly (UnionedTypes, sharedTyConsEE, lookupUT) where + +import qualified G2.Data.UFMap as UF +import qualified G2.Data.UnionFind as UFind +import G2.Language +import qualified G2.Language.ExprEnv as E +import G2.Language.Monad.AST +import G2.Language.Monad.Naming +import G2.Language.Monad.Support + +import Control.Monad +import qualified Data.HashMap.Lazy as HM +import Data.Maybe +import qualified Data.Text as T + +newtype UnionedTypes = UT (HM.HashMap Name Type) deriving Show + +lookupUT :: Name -> UnionedTypes -> Maybe Type +lookupUT (Name n m _ l) (UT ut) = HM.lookup (Name n m 0 l) ut + +sharedTyConsEE :: [Name] -> ExprEnv -> UnionedTypes +sharedTyConsEE ns eenv = fst $ runNamingM (sharedTyConsEE' ns eenv) (mkNameGen eenv) + +sharedTyConsEE' :: [Name] -> ExprEnv -> NameGenM UnionedTypes +sharedTyConsEE' ns eenv = do + let f_eenv = E.filterWithKey (\n _ -> n `elem` ns) eenv + typeOf_eenv = E.map' typeOf f_eenv + tys <- mapM assignTyConNames typeOf_eenv + + let rep_eenv = E.map (repVars tys) f_eenv + rep_eenv' = elimTypes rep_eenv + -- We want to try and be clever with passed in functions/lamdas to unify types when required, + -- but we can do too much if we unify non-function types or inner lambdas. + -- This is very much a heuristic. + rep_eenv'' <- E.mapM (scrambleNonFuncLams >=> scrambleNonFuncLets) + . substLams + . adjustLetTypes + =<< E.mapM (assignTyConNames >=> elimTyForAll) rep_eenv' + + let union_poly = mconcat . map UF.joinedKeys . HM.elems + . E.map' (fromMaybe UF.empty . checkType) + $ rep_eenv'' + + union_tys = fmap (renameFromUnion union_poly) tys + + return . UT $ HM.mapKeys (\(Name n m _ l) -> Name n m 0 l) union_tys + +g2UnionNameText :: T.Text +g2UnionNameText = "__G2__UNION__NAME__" + +freshG2UnionName :: NameGenM Name +freshG2UnionName = freshSeededStringN g2UnionNameText + +isG2UnionName :: Name -> Bool +isG2UnionName (Name n Nothing _ Nothing) = n == g2UnionNameText +isG2UnionName _ = False + +assignTyConNames :: ASTContainerM m Type => m -> NameGenM m +assignTyConNames = modifyASTsM assignTyConNames' + +assignTyConNames' :: Type -> NameGenM Type +assignTyConNames' (TyCon _ k) = do + n <- freshG2UnionName + return (TyVar (Id n k)) +assignTyConNames' t = return t + +repVars :: HM.HashMap Name Type -> Expr -> Expr +repVars tys = modifyASTs (repVars' tys) + +repVars' :: HM.HashMap Name Type -> Expr -> Expr +repVars' tys (Var (Id n _)) | Just t <- HM.lookup n tys = Var (Id n t) +repVars' _ e = e + +elimTyForAll :: ASTContainerM m Type => m -> NameGenM m +elimTyForAll = modifyASTsM elimTyForAll' + +elimTyForAll' :: Type -> NameGenM Type +elimTyForAll' (TyForAll (Id n _) t) = do + n' <- freshSeededNameN n + elimTyForAll' (rename n n' t) +elimTyForAll' t = return t + +elimTypes :: ASTContainer m Expr => m -> m +elimTypes = modifyASTs elimTypes' + +elimTypes' :: Expr -> Expr +elimTypes' (Lam TypeL _ e) = elimTypes' e +elimTypes' (App e (Type _)) = elimTypes' e +elimTypes' e = e + +adjustLetTypes :: ASTContainer m Expr => m -> m +adjustLetTypes = modifyASTs adjustLetTypes' + +adjustLetTypes' :: Expr -> Expr +adjustLetTypes' (Let ie e) = + let + ie' = map (\(Id n _, le) -> (Id n (typeOf le), le)) ie + f ((i_old, _), (i_new, _)) fe = modifyASTs (repVar (idName i_old) (Var i_new)) fe + in + foldr f (Let ie' e) (zip ie ie') +adjustLetTypes' e = e + +substLams :: ASTContainer m Expr => m -> m +substLams = modifyASTs substLams' + +substLams' :: Expr -> Expr +substLams' (Lam use i e) = Lam use i $ modifyASTs (repVar (idName i) (Var i)) e +substLams' e = e + +scrambleNonFuncLams :: Expr -> NameGenM Expr +scrambleNonFuncLams (Lam u i@(Id n t) e) | not $ isTyFun t = do + Lam u i <$> (scrambleNonFuncLamLetIds n =<< scrambleNonFuncLams e) +scrambleNonFuncLams (Lam u i e) = Lam u i <$> scrambleNonFuncLams e +scrambleNonFuncLams e = return e + +scrambleNonFuncLets :: ASTContainerM m Expr => m -> NameGenM m +scrambleNonFuncLets = modifyASTsM scrambleNonFuncLets' + +scrambleNonFuncLets' :: Expr -> NameGenM Expr +scrambleNonFuncLets' (Let b e) = do + let b' = map idName . filter (not . isTyFun . typeOf) . map fst $ b + foldM (flip scrambleNonFuncLamLetIds) (Let b e) b' +scrambleNonFuncLets' e = return e + +scrambleNonFuncLamLetIds :: Name -> Expr -> NameGenM Expr +scrambleNonFuncLamLetIds n = modifyASTsM (scrambleNonFuncLamLetIds' n) + +scrambleNonFuncLamLetIds' :: Name -> Expr -> NameGenM Expr +scrambleNonFuncLamLetIds' n (Var (Id vn t)) | n == vn = Var . Id n <$> scrambleNonFuncLamLetsType t +scrambleNonFuncLamLetIds' _ e = return e + +scrambleNonFuncLamLetsType :: Type -> NameGenM Type +scrambleNonFuncLamLetsType = modifyASTsM scrambleNonFuncLamLetsType' + +scrambleNonFuncLamLetsType' :: Type -> NameGenM Type +scrambleNonFuncLamLetsType' (TyVar (Id n t)) | isG2UnionName n = do + new_n <- freshG2UnionName + return . TyVar $ Id new_n t +scrambleNonFuncLamLetsType' t = return t + + +repVar :: Name -> Expr -> Expr -> Expr +repVar old new (Var (Id n _)) | n == old = new +repVar _ _ re = re + +renameFromUnion :: UFind.UnionFind Name -> Type -> Type +renameFromUnion uf = modifyASTs (renameFromUnion' uf ) + +renameFromUnion' :: UFind.UnionFind Name -> Type -> Type +renameFromUnion' uf (TyVar (Id n k)) = TyVar (Id (UFind.find n uf) k) +renameFromUnion' _ t = t diff --git a/src/G2/Liquid/Inference/Verify.hs b/src/G2/Liquid/Inference/Verify.hs new file mode 100644 --- /dev/null +++ b/src/G2/Liquid/Inference/Verify.hs @@ -0,0 +1,402 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} + +module G2.Liquid.Inference.Verify ( VerifyResult (..) + , verifyVarToName + , tryToVerifyOnly + , checkGSCorrect + , verify + , ghcInfos + , defLHConfig + , tryToVerify) where + +import qualified G2.Language.Syntax as G2 +import G2.Liquid.Helpers +import G2.Liquid.Types +import G2.Liquid.Inference.Config +import G2.Liquid.Inference.GeneratedSpecs + +import Data.Maybe +import GHC +#if MIN_VERSION_liquidhaskell(0,8,10) +import Language.Haskell.Liquid.Types + hiding (TargetInfo (..), TargetSrc (..), TargetSpec (..), GhcSrc (..), GhcSpec (..)) +#else +import Language.Haskell.Liquid.Types +#endif +import Language.Haskell.Liquid.UX.CmdLine +import Text.PrettyPrint.HughesPJ + +#if MIN_VERSION_GLASGOW_HASKELL(9,0,2,0) +import GHC.Core +import GHC.Types.Var as V +import GHC.Driver.Types + +import Liquid.GHC.Interface +import Liquid.GHC.Misc +#else +import CoreSyn +import HscTypes (SourceError) +import Var as V + +import Language.Haskell.Liquid.GHC.Interface +import Language.Haskell.Liquid.GHC.Misc (showCBs, ignoreCoreBinds) +#endif + +--------------------------------------------------------------------------- +--------------------------------------------------------------------------- +-- Copied from LiquidHaskell (because checkMany not exported) +import Control.Monad (when) +import Control.Monad.IO.Class +import qualified Control.Exception as Ex +import Language.Haskell.Liquid.UX.Tidy +import Language.Haskell.Liquid.Constraint.Generate +import Language.Haskell.Liquid.Constraint.ToFixpoint +import Language.Haskell.Liquid.Constraint.Types +import Language.Haskell.Liquid.Misc +import Language.Fixpoint.Solver +import qualified Language.Fixpoint.Types as F +import qualified Language.Fixpoint.Types.Errors as F (FixResult (..)) + +#if MIN_VERSION_liquidhaskell(0,8,6) +import qualified Language.Haskell.Liquid.Termination.Structural as ST +import qualified Data.HashSet as S +#else +import Language.Haskell.Liquid.GHC.Misc (showCBs) +#endif + +-- For Show instance of Cinfo +import Language.Haskell.Liquid.Liquid () + +--------------------------------------------------------------------------- +--------------------------------------------------------------------------- + +import qualified Language.Haskell.Liquid.UX.DiffCheck as DC + +data VerifyResult v = Safe + | Crash [(Integer, Cinfo)] String + | Unsafe [v] + deriving Show + +verifyVarToName :: VerifyResult V.Var -> VerifyResult G2.Name +verifyVarToName Safe = Safe +verifyVarToName (Crash ic s) = Crash ic s +verifyVarToName (Unsafe v) = Unsafe (map varToName v) + +-- Tries to verify the assertions, specifically for the set of functions, +-- that we care about. If that fails, removes any synthesized +-- assertions/assumptions on the failing functions. +tryHardToVerifyIgnoring :: (InfConfigM m, MonadIO m) + => [GhcInfo] + -> GeneratedSpecs + -> [G2.Name] + -> m (Either [G2.Name] GeneratedSpecs) +tryHardToVerifyIgnoring ghci gs ignore = do + lhconfig <- lhConfigM + infconfig <- infConfigM + liftIO $ do + let merged_ghci = addSpecsToGhcInfos ghci gs + + putStrLn "---\nVerify" + putStrLn "gsAsmSigs" + mapM_ (print . getAssumedSigs) merged_ghci + putStrLn "gsTySigs" + mapM_ (print . getTySigs) merged_ghci + putStrLn "---\nEnd Verify" + + res <- return . verifyVarToName =<< verify infconfig lhconfig merged_ghci + putStrLn "res" + case res of + Unsafe ns + | f_ns <- filterIgnoring ns + , f_ns /= [] -> do + putStrLn $ "filtered = " ++ show ns + let f_gs = filterOutAssertSpecs f_ns gs + f_merged_ghci = addSpecsToGhcInfos ghci f_gs + + filtered_res <- return . verifyVarToName =<< + verify infconfig lhconfig f_merged_ghci + case filtered_res of + Unsafe _ -> return $ Left f_ns + Safe -> do + liftIO . putStrLn $ "Safe 2 after " ++ show ns + return $ Right f_gs + Crash ci err -> error $ "Crash\n" ++ show ci ++ "\n" ++ err + | otherwise -> do + putStrLn $ "safe ignoring ns = " ++ show ns + return $ Right gs + Safe -> do + liftIO $ putStrLn "Safe 1" + return $ Right gs + Crash ci err -> error $ "Crash\n" ++ show ci ++ "\n" ++ err + where + ignore' = map (\(G2.Name n m _ _) -> (n, m)) ignore + filterIgnoring = filter (\(G2.Name n m _ _) -> (n, m) `notElem` ignore') + +tryToVerifyOnly :: (InfConfigM m, MonadIO m) => [GhcInfo] -> [G2.Name] -> m (VerifyResult G2.Name) +tryToVerifyOnly ghci ns = do + res <- tryToVerify ghci + case res of + Safe -> return Safe + Unsafe unsafe -> + case filter (\n -> toOccMod n `elem` ns_nm) unsafe of + [] -> return Safe + unsafe' -> do + return $ Unsafe unsafe' + x -> error (show x) + where + ns_nm = map toOccMod ns + toOccMod (G2.Name n m _ _) = (n, m) + +tryToVerify :: (InfConfigM m, MonadIO m) => [GhcInfo] -> m (VerifyResult G2.Name) +tryToVerify ghci = do + lhconfig <- lhConfigM + infconfig <- infConfigM + + liftIO $ do + putStrLn "-------------------------------" + putStrLn "-------------------------------" + putStrLn "tryToVerify" + mapM (print . getTySigs) ghci + putStrLn "-------------------------------" + putStrLn "-------------------------------" + + return . verifyVarToName =<< liftIO (verify infconfig lhconfig ghci) + +-- | Confirm that we have actually found exactly the needed specs +checkGSCorrect :: InferenceConfig -> Config -> [GhcInfo] -> GeneratedSpecs -> IO (VerifyResult V.Var) +checkGSCorrect infconfig lhconfig ghci gs + | nullAssumeGS gs = do + let merged_ghci = addSpecsToGhcInfos ghci $ switchAssumesToAsserts gs + verify infconfig lhconfig merged_ghci + | otherwise = error "Non-null assumes." + +verify :: InferenceConfig -> Config -> [GhcInfo] -> IO (VerifyResult V.Var) +verify infconfig cfg ghci = do + r <- verify' infconfig cfg ghci + case F.resStatus r of +#if MIN_VERSION_liquidhaskell(0,9,0) + F.Safe _ -> return Safe + F.Crash ci err -> return $ Crash (map fst ci) err + F.Unsafe _ bad -> do + putStrLn $ "bad var = " ++ show (map (ci_var . snd) bad) + putStrLn $ "bad loc = " ++ show (map (ci_loc . snd) bad) + return . Unsafe . catMaybes $ map (ci_var . snd) bad +#elif MIN_VERSION_liquidhaskell(0,8,10) + F.Safe _ -> return Safe + F.Crash ci err -> return $ Crash ci err + F.Unsafe _ bad -> do + putStrLn $ "bad var = " ++ show (map (ci_var . snd) bad) + putStrLn $ "bad loc = " ++ show (map (ci_loc . snd) bad) + return . Unsafe . catMaybes $ map (ci_var . snd) bad +#else + F.Safe -> return Safe + F.Crash ci err -> return $ Crash ci err + F.Unsafe bad -> do + putStrLn $ "bad var = " ++ show (map (ci_var . snd) bad) + putStrLn $ "bad loc = " ++ show (map (ci_loc . snd) bad) + return . Unsafe . catMaybes $ map (ci_var . snd) bad +#endif + + +verify' :: InferenceConfig -> Config -> [GhcInfo] -> IO (F.Result (Integer, Cinfo)) +verify' infconfig cfg ghci = checkMany infconfig cfg mempty ghci + +ghcInfos :: Maybe HscEnv -> Config -> [FilePath] -> IO [GhcInfo] +ghcInfos me cfg fp = do +#if MIN_VERSION_liquidhaskell(0,8,10) + (ghci, _) <- getTargetInfos me cfg fp +#else + (ghci, _) <- getGhcInfos me cfg fp +#endif + return ghci + +defLHConfig :: [FilePath] -> IO Config +defLHConfig proj = do + config <- getOpts [] + return config { idirs = idirs config ++ proj + , files = files config + , ghcOptions = ["-v"]} + +--------------------------------------------------------------------------- +--------------------------------------------------------------------------- +-- Copied from LiquidHaskell (because checkMany not exported) +checkMany :: InferenceConfig -> Config -> F.Result (Integer, Cinfo) -> [GhcInfo] -> IO (F.Result (Integer, Cinfo)) +-------------------------------------------------------------------------------- +checkMany infconfig cfg d (g:gs) = do + d' <- checkOne infconfig cfg g + checkMany infconfig cfg (d `mappend` d') gs + +checkMany _ _ d [] = + return d + +-------------------------------------------------------------------------------- +checkOne :: InferenceConfig -> Config -> GhcInfo -> IO (F.Result (Integer, Cinfo)) +-------------------------------------------------------------------------------- +checkOne infconfig cfg g = do + z <- actOrDie $ liquidOne infconfig g + case z of + Left e -> undefined + Right r -> return r + + +actOrDie :: IO a -> IO (Either ErrorResult a) +actOrDie act = + (Right <$> act) + `Ex.catch` (\(e :: SourceError) -> handle e) + `Ex.catch` (\(e :: Error) -> handle e) + `Ex.catch` (\(e :: UserError) -> handle e) + `Ex.catch` (\(e :: [Error]) -> handle e) + +handle :: (Result a) => a -> IO (Either ErrorResult b) +handle = return . Left . result + +-------------------------------------------------------------------------------- +liquidOne :: InferenceConfig -> GhcInfo -> IO (F.Result (Integer, Cinfo)) +-------------------------------------------------------------------------------- +liquidOne infconfig info = do + -- whenNormal $ donePhase Loud "Extracted Core using GHC" + let cfg = getConfig info +#if MIN_VERSION_liquidhaskell(0,8,6) + let tgt = giTarget (giSrc info) + let cbs' = giCbs (giSrc info) +#else + let tgt = target info + -- whenLoud $ do putStrLn $ showpp info + -- putStrLn "*************** Original CoreBinds ***************************" + -- putStrLn $ render $ pprintCBs (cbs info) + let cbs' = cbs info -- scopeTr (cbs info) +#endif + -- whenNormal $ donePhase Loud "Transformed Core" + -- whenLoud $ do donePhase Loud "transformRecExpr" + -- putStrLn "*************** Transform Rec Expr CoreBinds *****************" + -- putStrLn $ showCBs (untidyCore cfg) cbs' + -- putStrLn $ render $ pprintCBs cbs' + -- putStrLn $ showPpr cbs' + edcs <- newPrune cfg cbs' tgt info + liquidQueries infconfig cfg tgt info edcs + +#if MIN_VERSION_liquidhaskell(0,8,6) +newPrune :: Config -> [CoreBind] -> FilePath -> GhcInfo -> IO (Either [CoreBind] [DC.DiffCheck]) +newPrune cfg cbs tgt info + | not (null vs) = return . Right $ [DC.thin cbs sp vs] + | timeBinds cfg = return . Right $ [DC.thin cbs sp [v] | v <- exportedVars (giSrc info) ] + | diffcheck cfg = maybeEither cbs <$> DC.slice tgt cbs sp + | otherwise = return $ Left (ignoreCoreBinds ignores cbs) + where + ignores = gsIgnoreVars (gsVars sp) + vs = gsTgtVars (gsVars sp) + sp = giSpec info + +exportedVars :: GhcSrc -> [V.Var] +exportedVars src = filter (isExportedVar src) (giDefVars src) +#else +newPrune :: Config -> [CoreBind] -> FilePath -> GhcInfo -> IO (Either [CoreBind] [DC.DiffCheck]) +newPrune cfg cbs tgt info + | not (null vs) = return . Right $ [DC.thin cbs sp vs] + | timeBinds cfg = return . Right $ [DC.thin cbs sp [v] | v <- exportedVars info ] + | diffcheck cfg = maybeEither cbs <$> DC.slice tgt cbs sp + | otherwise = return (Left cbs) + where + vs = gsTgtVars sp + sp = spec info + +ignoreCoreBinds :: [V.Var] -> [CoreBind] -> [CoreBind] +ignoreCoreBinds vs cbs + | null vs = cbs + | otherwise = concatMap go cbs + where + go :: CoreBind -> [CoreBind] + go b@(NonRec x _) + | x `elem` vs = [] + | otherwise = [b] + go (Rec xes) = [Rec (filter ((`notElem` vs) . fst) xes)] +#endif + +-- topLevelBinders :: GhcSpec -> [Var] +-- topLevelBinders = map fst . tySigs + +maybeEither :: a -> Maybe b -> Either a [b] +maybeEither d Nothing = Left d +maybeEither _ (Just x) = Right [x] + +liquidQueries :: InferenceConfig -> Config -> FilePath -> GhcInfo -> Either [CoreBind] [DC.DiffCheck] -> IO (F.Result (Integer, Cinfo)) +liquidQueries infconfig cfg tgt info (Left cbs') + = liquidQuery infconfig cfg tgt info (Left cbs') +liquidQueries infconfig cfg tgt info (Right dcs) + = mconcat <$> mapM (liquidQuery infconfig cfg tgt info . Right) dcs + +liquidQuery :: InferenceConfig -> Config -> FilePath -> GhcInfo -> Either [CoreBind] DC.DiffCheck -> IO (F.Result (Integer, Cinfo)) +#if MIN_VERSION_liquidhaskell(0,8,6) +liquidQuery infconfig cfg tgt info edc = do + let names = either (const Nothing) (Just . map show . DC.checkedVars) edc + let oldOut = either (const mempty) DC.oldOutput edc + let info1 = either (const info) (\z -> info {giSpec = DC.newSpec z}) edc + let cbs'' = either id DC.newBinds edc + let info2 = info1 { giSrc = (giSrc info1) {giCbs = cbs''}} + let info3 = updGhcInfoTermVars info2 + let cgi = {-# SCC "generateConstraints" #-} generateConstraints $! info3 + when False (dumpCs cgi) + -- whenLoud $ mapM_ putStrLn [ "****************** CGInfo ********************" + -- , render (pprint cgi) ] + timedAction names $ solveCs infconfig cfg tgt cgi info3 names + +updGhcInfoTermVars :: GhcInfo -> GhcInfo +updGhcInfoTermVars i = updInfo i (ST.terminationVars i) + where + updInfo info vs = info { giSpec = updSpec (giSpec info) vs } + updSpec sp vs = sp { gsTerm = updSpTerm (gsTerm sp) vs } + updSpTerm gsT vs = gsT { gsNonStTerm = S.fromList vs } +#else +liquidQuery infconfig cfg tgt info edc = do + when False (dumpCs cgi) + timedAction names $ solveCs infconfig cfg tgt cgi info' names + where + cgi = {-# SCC "generateConstraints" #-} generateConstraints $! info' {cbs = cbs''} + cbs'' = either id DC.newBinds edc + info' = either (const info) (\z -> info {spec = DC.newSpec z}) edc + names = either (const Nothing) (Just . map show . DC.checkedVars) edc + oldOut = either (const mempty) DC.oldOutput edc +#endif + + +dumpCs :: CGInfo -> IO () +dumpCs cgi = do + putStrLn "***************************** SubCs *******************************" + putStrLn $ render $ pprintMany (hsCs cgi) + putStrLn "***************************** FixCs *******************************" + putStrLn $ render $ pprintMany (fixCs cgi) + putStrLn "***************************** WfCs ********************************" + putStrLn $ render $ pprintMany (hsWfs cgi) + +pprintMany :: (PPrint a) => [a] -> Doc +pprintMany xs = vcat [ F.pprint x $+$ text " " | x <- xs ] + +-- instance Show Cinfo where +-- show = show . F.toFix + +solveCs :: InferenceConfig -> Config -> FilePath -> CGInfo -> GhcInfo -> Maybe [String] -> IO (F.Result (Integer, Cinfo)) +solveCs infconfig cfg tgt cgi info names = do + finfo <- cgInfoFInfo info cgi + -- We only want qualifiers we have found with G2 Inference, so we have to force the correct set here + let finfo' = finfo { F.quals = (getQualifiers $ info) ++ if keep_quals infconfig then F.quals finfo else [] } +#if MIN_VERSION_liquid_fixpoint(0,9,0) + fres@(F.Result r sol _ _) <- solve (fixConfig tgt cfg) finfo' +#else + fres@(F.Result r sol _) <- solve (fixConfig tgt cfg) finfo' +#endif + -- let resErr = applySolution sol . cinfoError . snd <$> r + -- resModel_ <- fmap (e2u cfg sol) <$> getModels info cfg resErr + -- let resModel = resModel_ `addErrors` (e2u cfg sol <$> logErrors cgi) + -- let out0 = mkOutput cfg resModel sol (annotMap cgi) + -- out1 = out0 { o_vars = names } + -- { o_result = resModel } + -- DC.saveResult tgt out1 + -- exitWithResult cfg [tgt] out1 + + return fres + + +-- e2u :: Config -> F.FixSolution -> Error -> UserError +-- e2u cfg s = fmap F.pprint . tidyError cfg s + diff --git a/src/G2/Liquid/Interface.hs b/src/G2/Liquid/Interface.hs --- a/src/G2/Liquid/Interface.hs +++ b/src/G2/Liquid/Interface.hs @@ -1,13 +1,47 @@ -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} -module G2.Liquid.Interface where +module G2.Liquid.Interface ( LiquidData (..) + , LiquidReadyState + , lr_state + , lr_binding + , lrsMeasures + , Abstracted (..) + , AbstractedInfo (..) + , findCounterExamples + + , runLHG2 + , onlyMinimalStates + , cleanupResults + , runLHCore + , liquidStateWithCall + , liquidStateWithCall' + , liquidStateFromSimpleStateWithCall + , liquidStateFromSimpleStateWithCall' + + , cleanReadyState + , fromLiquidNoCleaning + , createLiquidReadyState + , processLiquidReadyState + , processLiquidReadyStateWithCall + , extractWithoutSpecs + + , processLiquidReadyStateCleaning + + , reqNames + + , lhStateToCE + , printLHOut + , printCE) where + import G2.Config.Config import G2.Translation import G2.Interface import G2.Language as Lang +import G2.Language.KnownValues as KV import qualified G2.Language.ExprEnv as E import G2.Execution @@ -17,36 +51,40 @@ import G2.Liquid.AddCFBranch import G2.Liquid.AddLHTC import G2.Liquid.AddOrdToNum +import G2.Liquid.AddTyVars +import G2.Liquid.Config import G2.Liquid.Conversion import G2.Liquid.ConvertCurrExpr +import G2.Liquid.Helpers import G2.Liquid.LHReducers import G2.Liquid.Measures +import G2.Liquid.MkLHVals +import G2.Liquid.G2Calls import G2.Liquid.Simplify import G2.Liquid.SpecialAsserts import G2.Liquid.TCGen +import G2.Liquid.TCValues import G2.Liquid.Types +import G2.Liquid.TyVarBags import G2.Solver hiding (solve) import G2.Lib.Printers -import qualified Language.Haskell.Liquid.GHC.Interface as LHI -import Language.Haskell.Liquid.Types hiding (Config, cls, names) -import qualified Language.Haskell.Liquid.Types.PrettyPrint as PPR -import Language.Haskell.Liquid.UX.CmdLine -import qualified Language.Haskell.Liquid.UX.Config as LHC - -import qualified Language.Fixpoint.Types.PrettyPrint as FPP +import Language.Haskell.Liquid.Types hiding (Config, cls, names, measures) +import Language.Haskell.Liquid.UX.CmdLine hiding (config) import Control.Exception +import Control.Monad.Extra +import Control.Monad.IO.Class +import qualified Control.Monad.State as SM import Data.List +import qualified Data.HashSet as S +import qualified Data.HashMap.Lazy as HM import qualified Data.Map as M import qualified Data.Text as T import qualified Data.Text.IO as TI -import qualified GHC as GHC -import Var - -import G2.Language.KnownValues +import G2.Language.Monad data LHReturn = LHReturn { calledFunc :: FuncInfo , violating :: Maybe FuncInfo @@ -59,59 +97,216 @@ -- | findCounterExamples -- Given (several) LH sources, and a string specifying a function name, -- attempt to find counterexamples to the functions liquid type -findCounterExamples :: [FilePath] -> [FilePath] -> T.Text -> [FilePath] -> [FilePath] -> Config -> IO (([ExecRes [FuncCall]], Bindings), Lang.Id) -findCounterExamples proj fp entry libs lhlibs config = do +findCounterExamples :: [FilePath] -> [FilePath] -> T.Text -> Config -> LHConfig -> IO (([ExecRes AbstractedInfo], Bindings), Lang.Id) +findCounterExamples proj fp entry config lhconfig = do let config' = config { mode = Liquid } lh_config <- getOpts [] - ghc_cg <- try $ getGHCInfos lh_config proj fp lhlibs :: IO (Either SomeException [LHOutput]) + ghci <- try $ getGHCInfos lh_config proj fp :: IO (Either SomeException [GhcInfo]) - let ghc_cg' = case ghc_cg of + let ghci' = case ghci of Right g_c -> g_c Left e -> error $ "ERROR OCCURRED IN LIQUIDHASKELL\n" ++ show e - tgt_trans <- translateLoaded proj fp libs (simplTranslationConfig { simpl = False }) config' + tgt_trans <- translateLoaded proj fp (simplTranslationConfig { simpl = False }) config' - runLHCore entry tgt_trans ghc_cg' config' + runLHCore entry tgt_trans ghci' config' lhconfig -runLHCore :: T.Text -> (Maybe T.Text, ExtractedG2) - -> [LHOutput] - -> Config - -> IO (([ExecRes [FuncCall]], Bindings), Lang.Id) -runLHCore entry (mb_modname, exg2) ghci_cg config = do - let (init_state, ifi, bindings) = initState exg2 True entry mb_modname (mkCurrExpr Nothing Nothing) config - let (init_state', bindings') = (markAndSweepPreserving (reqNames init_state) init_state bindings) - let cleaned_state = init_state' { type_env = type_env init_state } +runLHCore :: T.Text + -> (Maybe T.Text, ExtractedG2) + -> [GhcInfo] + -> Config + -> LHConfig + -> IO (([ExecRes AbstractedInfo], Bindings), Lang.Id) +runLHCore entry (mb_modname, exg2) ghci config lhconfig = do + LiquidData { ls_state = final_st + , ls_bindings = bindings + , ls_id = ifi + , ls_counterfactual_name = cfn + , ls_memconfig = pres_names } <- liquidStateWithCall entry (mb_modname, exg2) ghci config lhconfig mempty - let (no_part_state@(State {expr_env = np_eenv})) = cleaned_state - let np_ng = name_gen bindings' + SomeSolver solver <- initSolver config + let simplifier = IdSimplifier - let renme = E.keys np_eenv -- \\ nub (Lang.names (type_classes no_part_state)) - let ((meenv, mkv, mtc, minst), ng') = doRenames renme np_ng - (np_eenv, known_values no_part_state, type_classes no_part_state, higher_order_inst bindings') + let (red, hal, ord) = lhReducerHalterOrderer config lhconfig solver simplifier entry mb_modname cfn final_st + (exec_res, final_bindings) <- SM.evalStateT (runLHG2 config red hal ord solver simplifier pres_names ifi final_st bindings) (mkPrettyGuide ()) + + close solver + + return ((exec_res, final_bindings), ifi) + +{-# INLINE liquidStateWithCall #-} +liquidStateWithCall :: T.Text -> (Maybe T.Text, ExtractedG2) + -> [GhcInfo] + -> Config + -> LHConfig + -> MemConfig + -> IO LiquidData +liquidStateWithCall entry (mb_modname, exg2) ghci config lhconfig memconfig = + liquidStateWithCall' entry (mb_modname, exg2) ghci config lhconfig memconfig (mkCurrExpr Nothing Nothing) mkArgTys + +{-# INLINE liquidStateWithCall' #-} +liquidStateWithCall' :: T.Text -> (Maybe T.Text, ExtractedG2) + -> [GhcInfo] + -> Config + -> LHConfig + -> MemConfig + -> (Lang.Id -> MkCurrExpr) + -> (Lang.Expr -> MkArgTypes) + -> IO LiquidData +liquidStateWithCall' entry (mb_m, exg2) ghci config lhconfig memconfig mkCurr argTys = do + let simp_s = initSimpleState exg2 + liquidStateFromSimpleStateWithCall' simp_s ghci entry mb_m config lhconfig memconfig mkCurr argTys + +{-# INLINE liquidStateFromSimpleStateWithCall #-} +liquidStateFromSimpleStateWithCall :: SimpleState + -> [GhcInfo] + -> T.Text + -> Maybe T.Text + -> Config + -> LHConfig + -> MemConfig + -> IO LiquidData +liquidStateFromSimpleStateWithCall simp_s ghci entry mb_m config lhconfig memconfig = + liquidStateFromSimpleStateWithCall' simp_s ghci entry mb_m config lhconfig memconfig (mkCurrExpr Nothing Nothing) mkArgTys + +{-# INLINE liquidStateFromSimpleStateWithCall' #-} +liquidStateFromSimpleStateWithCall' :: SimpleState + -> [GhcInfo] + -> T.Text + -> Maybe T.Text + -> Config + -> LHConfig + -> MemConfig + -> (Lang.Id -> MkCurrExpr) + -> (Lang.Expr -> MkArgTypes) + -> IO LiquidData +liquidStateFromSimpleStateWithCall' simp_s ghci entry mb_m config lhconfig memconfig mkCurr argTys = do + let (simp_s', ph_tyvars) = if add_tyvars lhconfig + then fmap Just $ addTyVarsEEnvTEnv simp_s + else (simp_s, Nothing) + (s, i, bindings') = initStateFromSimpleStateWithCall simp_s' True entry mb_m mkCurr argTys config - let ng_bindings = bindings' {name_gen = ng'} + fromLiquidReadyState s i bindings' ghci ph_tyvars lhconfig memconfig - let ng_state = no_part_state {track = []} +{-# INLINE fromLiquidReadyState #-} +fromLiquidReadyState :: State () + -> Lang.Id + -> Bindings + -> [GhcInfo] + -> Maybe PhantomTyVars + -> LHConfig + -> MemConfig + -> IO LiquidData +fromLiquidReadyState init_state ifi bindings ghci ph_tyvars lhconfig memconfig = do + let (init_state', bindings') = (markAndSweepPreserving (reqNames init_state `mappend` memconfig) init_state bindings) + cleaned_state = init_state' { type_env = type_env init_state } + fromLiquidNoCleaning cleaned_state ifi bindings' ghci ph_tyvars lhconfig memconfig - let (lh_state, lh_bindings) = createLHState meenv mkv ng_state ng_bindings +data LiquidReadyState = LiquidReadyState { lr_state :: LHState + , lr_binding :: Bindings + , lr_known_values :: KnownValues + , lr_type_classes :: TypeClasses + , lr_higher_ord_insts :: S.HashSet Name } - let (cfn, (merged_state, bindings'')) = runLHStateM (initializeLH ghci_cg ifi lh_bindings) lh_state lh_bindings +data LiquidData = LiquidData { ls_state :: State LHTracker + , ls_bindings :: Bindings + , ls_id :: Lang.Id + , ls_counterfactual_name :: CounterfactualName + , ls_counterfactual_funcs :: S.HashSet Name + , ls_measures :: Measures + , ls_assumptions :: Assumptions + , ls_posts :: Posts + , ls_tcv :: TCValues + , ls_memconfig :: MemConfig } - let tcv = tcvalues merged_state - let merged_state' = deconsLHState merged_state +cleanReadyState :: LiquidReadyState -> MemConfig -> LiquidReadyState +cleanReadyState lrs@(LiquidReadyState { lr_state = lhs@(LHState { state = s }), lr_binding = b }) memconfig = + let + (s', b') = (markAndSweepPreserving (reqNames s `mappend` memconfig) s b) + s'' = s' { type_env = type_env s } + in + lrs { lr_state = lhs { state = s'' }, lr_binding = b' } - let pres_names = reqNames merged_state' ++ names tcv ++ names mkv +fromLiquidNoCleaning :: State () + -> Lang.Id + -> Bindings + -> [GhcInfo] + -> Maybe PhantomTyVars + -> LHConfig + -> MemConfig + -> IO LiquidData +fromLiquidNoCleaning init_state ifi bindings ghci ph_tyvars lhconfig memconfig = do + let lrs = createLiquidReadyState init_state bindings ghci ph_tyvars lhconfig + processLiquidReadyState lrs ifi ghci lhconfig memconfig - let annm = annots merged_state +createLiquidReadyState :: State () -> Bindings -> [GhcInfo] -> Maybe PhantomTyVars -> LHConfig -> LiquidReadyState +createLiquidReadyState s bindings ghci ph_tyvars lhconfig = + let + np_ng = name_gen bindings - let track_state = merged_state' {track = LHTracker { abstract_calls = [] - , last_var = Nothing - , annotations = annm} } + (meenv, mkv, mtc, minst, mexported, ng') = mkLHVals s (higher_order_inst bindings) (exported_funcs bindings) np_ng - SomeSolver con <- initSolver config + s' = s { track = [] } + bindings' = bindings { exported_funcs = mexported ++ exported_funcs bindings, name_gen = ng' } + (lh_state, lh_bindings) = createLHState meenv mkv mtc s' bindings' + + (data_state, data_bindings) = execLHStateM (initializeLHData ghci ph_tyvars lhconfig) lh_state lh_bindings + in + LiquidReadyState { lr_state = data_state + , lr_binding = data_bindings + , lr_known_values = mkv + , lr_type_classes = mtc + , lr_higher_ord_insts = minst } -- (mkv, mtc, minst, data_state, data_bindings) + +processLiquidReadyStateCleaning :: LiquidReadyState -> Lang.Id -> [GhcInfo] -> LHConfig -> MemConfig -> IO LiquidData +processLiquidReadyStateCleaning lrs ifi ghci lhconfig memconfig = + let + lrs' = cleanReadyState lrs memconfig + in + processLiquidReadyState lrs' ifi ghci lhconfig memconfig + +processLiquidReadyState :: LiquidReadyState -> Lang.Id -> [GhcInfo] -> LHConfig -> MemConfig -> IO LiquidData +processLiquidReadyState lrs@(LiquidReadyState { lr_state = lh_state + , lr_binding = lh_bindings }) ifi ghci lhconfig memconfig = do + let ((cfn, mc, cff), (merged_state, bindings')) = runLHStateM (initializeLHSpecs (counterfactual lhconfig) ghci ifi lh_bindings) lh_state lh_bindings + lrs' = lrs { lr_state = merged_state, lr_binding = bindings'} + + lhs <- extractWithoutSpecs lrs' ifi ghci memconfig + + let lh_s = if only_top lhconfig + then elimNonTop (S.insert (idName mc) cff) (ls_state lhs) + else ls_state lhs + + return $ lhs { ls_state = lh_s + , ls_id = mc + , ls_counterfactual_name = cfn + , ls_counterfactual_funcs = cff } + +extractWithoutSpecs :: LiquidReadyState -> Lang.Id -> [GhcInfo] -> MemConfig -> IO LiquidData +extractWithoutSpecs lrs@(LiquidReadyState { lr_state = s + , lr_binding = bindings + , lr_known_values = mkv + , lr_type_classes = mtc + , lr_higher_ord_insts = minst}) ifi ghci memconfig = do + let (lh_s, bindings') = execLHStateM (return ()) s bindings + let bindings'' = bindings' { higher_order_inst = minst } + + let tcv = tcvalues lh_s + let lh_s' = deconsLHState lh_s + + let annm = annots lh_s + pres_names = addSearchNames (namesList tcv ++ namesList mkv) $ reqNames lh_s' + pres_names' = addSearchNames (namesList annm) pres_names + + let track_state = lh_s' {track = LHTracker { abstract_calls = [] + , last_var = Nothing + , annotations = annm + , all_calls = [] + , higher_order_calls = [] } } + -- We replace certain function name lists in the final State with names -- mapping into the measures from the LHState. These functions do not -- need to be passed the LH typeclass, so this ensures use of Names from @@ -119,188 +314,291 @@ -- for the LH typeclass. let final_st = track_state { known_values = mkv , type_classes = unionTypeClasses mtc (type_classes track_state)} - let bindings''' = bindings'' { higher_order_inst = minst } - -- let bindings''' = bindings'' + let real_meas = lrsMeasures ghci lrs - let tr_ng = mkNameGen () - let state_name = Name "state" Nothing 0 Nothing - let (limHalt, limOrd) = limitByAccepted (cut_off config) + return $ LiquidData { ls_state = final_st + , ls_bindings = bindings'' + , ls_id = ifi + , ls_counterfactual_name = error "No counterfactual name" + , ls_counterfactual_funcs = error "No counterfactual funcs" + , ls_measures = real_meas + , ls_assumptions = assumptions lh_s + , ls_posts = posts lh_s + , ls_tcv = tcv + , ls_memconfig = pres_names' `mappend` memconfig } - (ret, final_bindings) <- if higherOrderSolver config == AllFuncs - then runG2WithSomes - (SomeReducer NonRedPCRed - <~| (case logStates config of - Just fp -> SomeReducer (StdRed con :<~| LHRed cfn :<~ Logger fp) - Nothing -> SomeReducer (StdRed con :<~| LHRed cfn))) - (SomeHalter - (MaxOutputsHalter (maxOutputs config) - :<~> ZeroHalter (steps config) - :<~> LHAbsHalter entry mb_modname (expr_env init_state) - :<~> limHalt - :<~> SwitchEveryNHalter (switch_after config) - :<~> AcceptHalter)) - (SomeOrderer limOrd) - con (pres_names ++ names annm) final_st bindings''' - else runG2WithSomes - (SomeReducer (NonRedPCRed :<~| TaggerRed state_name tr_ng) - <~| (case logStates config of - Just fp -> SomeReducer (StdRed con :<~| LHRed cfn :<~ Logger fp) - Nothing -> SomeReducer (StdRed con :<~| LHRed cfn))) - (SomeHalter - (DiscardIfAcceptedTag state_name - :<~> MaxOutputsHalter (maxOutputs config) - :<~> ZeroHalter (steps config) - :<~> LHAbsHalter entry mb_modname (expr_env init_state) - :<~> limHalt - :<~> SwitchEveryNHalter (switch_after config) - :<~> AcceptHalter)) - (SomeOrderer limOrd) - con (pres_names ++ names annm) final_st bindings''' - - -- We filter the returned states to only those with the minimal number of abstracted functions - let mi = case length ret of +lrsMeasures :: [GhcInfo] -> LiquidReadyState -> Measures +lrsMeasures ghci lrs = + let + meas_names = measureNames ghci + meas_nameOcc = map (\(Name n md _ _) -> (n, md)) $ map symbolName meas_names + + real_meas = E.filterWithKey (\(Name n md i _) _ -> + (n, md) `elem` meas_nameOcc && i == 0) . measures $ lr_state lrs + in + real_meas + +processLiquidReadyStateWithCall :: LiquidReadyState -> [GhcInfo] -> T.Text -> Maybe T.Text -> Config -> LHConfig -> MemConfig -> IO LiquidData +processLiquidReadyStateWithCall lrs@(LiquidReadyState { lr_state = lhs@(LHState { state = s }) + , lr_binding = bindings}) + ghci f m_mod config lhconfig memconfig = do + + let (ie, _) = case findFunc f m_mod (expr_env s) of + Left ie' -> ie' + Right errs -> error errs + + (ce, is, f_i, ng') = mkCurrExpr Nothing Nothing ie (type_classes s) (name_gen bindings) + (expr_env s) (type_env s) (deepseq_walkers bindings) (known_values s) config + + lhs' = lhs { state = s { expr_env = foldr E.insertSymbolic (expr_env s) is + , curr_expr = CurrExpr Evaluate ce } + } + (lhs'', bindings') = execLHStateM (addLHTCCurrExpr) lhs' (bindings { name_gen = ng' }) + + lrs' = lrs { lr_state = lhs'' + , lr_binding = bindings' { fixed_inputs = f_i + , input_names = map idName is + } + } + + processLiquidReadyStateCleaning lrs' ie ghci lhconfig memconfig + +runLHG2 :: (MonadIO m, Solver solver, Simplifier simplifier) + => Config + -> SomeReducer m LHTracker + -> SomeHalter m LHTracker + -> SomeOrderer m LHTracker + -> solver + -> simplifier + -> MemConfig + -> Lang.Id + -> State LHTracker + -> Bindings + -> m ([ExecRes AbstractedInfo], Bindings) +runLHG2 config red hal ord solver simplifier pres_names init_id final_st bindings = do + let only_abs_st = addTicksToDeepSeqCases (deepseq_walkers bindings) final_st + (ret, final_bindings) <- runG2WithSomes red hal ord solver simplifier pres_names only_abs_st bindings + + let ret' = onlyMinimalStates ret + + cleanupResults solver simplifier config init_id final_st final_bindings ret' + +onlyMinimalStates :: [ExecRes LHTracker] -> [ExecRes LHTracker] +onlyMinimalStates ers = + let + mi = case length ers of 0 -> 0 - _ -> minimum $ map (\(ExecRes {final_state = s}) -> length $ abstract_calls $ track s) ret - let ret' = filter (\(ExecRes {final_state = s}) -> mi == (length $ abstract_calls $ track s)) ret + _ -> minimum $ map (\(ExecRes {final_state = s}) -> abstractCallsNum s) ers + in + filter (\(ExecRes {final_state = s}) -> mi == (abstractCallsNum s)) ers - let exec_res = map (\(ExecRes { final_state = s - , conc_args = es - , conc_out = e - , violated = ais}) -> - (ExecRes { final_state = s {track = map (subVarFuncCall (model s) (expr_env s) (type_classes s)) $ abstract_calls $ track s} - , conc_args = es - , conc_out = e - , violated = ais})) ret' +cleanupResults :: (MonadIO m, Solver solver, Simplifier simplifier) => + solver + -> simplifier + -> Config + -> Lang.Id + -> State LHTracker + -> Bindings + -> [ExecRes LHTracker] + -> m ([ExecRes AbstractedInfo], Bindings) +cleanupResults solver simplifier config init_id init_state bindings ers = do + let ers2 = map (\er -> er { final_state = putSymbolicExistentialInstInExprEnv (final_state er) }) ers + ers3 = map (\er -> if fmap funcName (violated er) == Just initiallyCalledFuncName + then er { violated = Nothing } + else er) ers2 - -- mapM (\(s, _, _, _) -> putStrLn . pprExecStateStr $ s) states - -- mapM (\(_, es, e, ais) -> do print es; print e; print ais) states + (bindings', ers4) <- liftIO $ mapAccumM (reduceCalls runG2WithSomes solver simplifier config) bindings ers3 + ers5 <- liftIO $ mapM (checkAbstracted runG2WithSomes solver simplifier config init_id bindings') ers4 + let ers6 = + map (\er@(ExecRes { final_state = s }) -> + (er { final_state = + s {track = + mapAbstractedInfoFCs (subVarFuncCall True (model s) (expr_env init_state) (type_classes s)) + $ track s + } + })) ers5 + return (ers6, bindings') - close con +lhReducerHalterOrderer :: (MonadIO m, Solver solver, Simplifier simplifier) + => Config + -> LHConfig + -> solver + -> simplifier + -> T.Text + -> Maybe T.Text + -> CounterfactualName + -> State t + -> ( SomeReducer (SM.StateT PrettyGuide m) LHTracker + , SomeHalter (SM.StateT PrettyGuide m) LHTracker + , SomeOrderer (SM.StateT PrettyGuide m) LHTracker) +lhReducerHalterOrderer config lhconfig solver simplifier entry mb_modname cfn st = + let - return ((exec_res, final_bindings), ifi) + share = sharing config -initializeLH :: [LHOutput] -> Lang.Id -> Bindings -> LHStateM Lang.Name -initializeLH ghci_cg ifi bindings = do - let ghcInfos = map ghcI ghci_cg + state_name = Name "state" Nothing 0 Nothing - addLHTC - addOrdToNum + abs_ret_name = Name "abs_ret" Nothing 0 Nothing - let lh_measures = measureSpecs ghcInfos - createMeasures lh_measures + non_red = nonRedPCRed .|. nonRedPCRedConst - let specs = funcSpecs ghcInfos - mergeLHSpecState specs + m_logger = fmap SomeReducer $ getLogger config - addSpecialAsserts - addTrueAsserts ifi + lh_std_red = existentialInstRed :== NoProgress .--> lhRed cfn :== Finished --> stdRed share retReplaceSymbFuncVar solver simplifier + opt_logger_red = case m_logger of + Just logger -> logger .~> lh_std_red + Nothing -> lh_std_red + in + if higherOrderSolver config == AllFuncs then + (opt_logger_red .== Finished .--> + (taggerRed abs_ret_name :== Finished --> nonRedAbstractReturnsRed) .== Finished .--> + SomeReducer non_red + , SomeHalter + (maxOutputsHalter (maxOutputs config) + <~> zeroHalter (steps config) + <~> lhAbsHalter entry mb_modname (expr_env st) + <~> lhLimitByAcceptedHalter (cut_off lhconfig) + <~> switchEveryNHalter (switch_after lhconfig) + <~> lhAcceptIfViolatedHalter) + , SomeOrderer lhLimitByAcceptedOrderer) + else + (opt_logger_red .== Finished .--> + ((taggerRed state_name :== Finished --> non_red)) .== Finished .--> + (taggerRed abs_ret_name :== Finished --> nonRedAbstractReturnsRed) + , SomeHalter + (discardIfAcceptedTagHalter state_name + <~> discardIfAcceptedTagHalter abs_ret_name + <~> maxOutputsHalter (maxOutputs config) + <~> zeroHalter (steps config) + <~> lhAbsHalter entry mb_modname (expr_env st) + <~> lhLimitByAcceptedHalter (cut_off lhconfig) + <~> switchEveryNHalter (switch_after lhconfig) + <~> lhAcceptIfViolatedHalter) + , SomeOrderer lhLimitByAcceptedOrderer) - -- getAnnotations ghci_cg +initializeLHData :: [GhcInfo] -> Maybe PhantomTyVars -> LHConfig -> LHStateM () +initializeLHData ghcInfos m_ph_tyvars config = do + addLHTC + addOrdToNum - -- The simplification works less well on some of the Core generated by convertCurrExpr, - -- so we apply the simplification first - simplify + addErrorAssumes config - ns <- convertCurrExpr ifi bindings + let lh_measures = measureSpecs ghcInfos - cfn <- addCounterfactualBranch ns + meenv <- measuresM + nt <- return . M.fromList =<< mapMaybeM measureTypeMappings lh_measures + fil_meenv <- filterMeasures' meenv (M.keys nt) - return cfn + createMeasures lh_measures -getGHCInfos :: LHC.Config -> [FilePath] -> [FilePath] -> [FilePath] -> IO [LHOutput] -getGHCInfos config proj fp lhlibs = do - let config' = config {idirs = idirs config ++ proj ++ lhlibs - , files = files config ++ lhlibs - , ghcOptions = ["-v"]} + case m_ph_tyvars of + Just ph_tyvars -> addTyVarsMeasures ph_tyvars + Nothing -> return () - -- GhcInfo - (ghci, _) <- LHI.getGhcInfos Nothing config' fp + meenv' <- measuresM + putMeasuresM (fil_meenv `E.union` meenv') - mapM (getGHCInfos' config') ghci +-- | Returns the name of the Tick on the counterfactual branches, and the names +-- of all functions with counterfactual branches +initializeLHSpecs :: Counterfactual -> [GhcInfo] -> Lang.Id -> Bindings -> LHStateM (Lang.Name, Lang.Id, S.HashSet Lang.Name) +initializeLHSpecs counter ghcInfos ifi bindings = do + let specs = funcSpecs ghcInfos + mergeLHSpecState specs + addSpecialAsserts + addTrueAsserts (idName ifi) -getGHCInfos' :: LHC.Config -> GhcInfo -> IO LHOutput -getGHCInfos' config ghci = do - -- CGInfo - -- let cgi = generateConstraints ghci + -- Most of the simplification works less well on some of the Core generated by convertCurrExpr, + -- so we apply the simplification first. However, we do want to stamp out as much redundancy + -- from convertCurrExpr as we can, so we do further simplificiation after + simplify + (main_call, ns) <- convertCurrExpr ifi bindings + furtherSimplifyCurrExpr - -- finfo <- cgInfoFInfo ghci cgi - -- F.Result _ sol _ <- solve (fixConfig "LH_FILEPATH" config) finfo + (cfn, ns') <- case counter of + Counterfactual cf_mods -> + return . (,ns) =<< addCounterfactualBranch cf_mods ns + NotCounterfactual -> return (Name "" Nothing 0 Nothing, []) - return (LHOutput {ghcI = ghci, cgI = undefined {- cgi -}, solution = undefined {- sol -} }) - -funcSpecs :: [GhcInfo] -> [(Var, LocSpecType)] -funcSpecs fs = concatMap (gsTySigs . spec) fs -- Functions asserted in LH - ++ concatMap (gsAsmSigs . spec) fs -- Functions assumed in LH + mapME (return . flattenLets) -measureSpecs :: [GhcInfo] -> [Measure SpecType GHC.DataCon] -measureSpecs = concatMap (gsMeasures . spec) + return (cfn, main_call, S.fromList ns') -reqNames :: State t -> [Name] +reqNames :: State t -> MemConfig reqNames (State { expr_env = eenv + , type_env = tenv , type_classes = tc - , known_values = kv}) = - Lang.names [ mkGe eenv - , mkGt eenv - , mkEq eenv - , mkNeq eenv - , mkLt eenv - , mkLe eenv - , mkAnd eenv - , mkOr eenv - , mkNot eenv - , mkPlus eenv - , mkMinus eenv - , mkMult eenv - -- , mkDiv eenv - , mkMod eenv - , mkNegate eenv - , mkImplies eenv - , mkIff eenv - , mkFromInteger eenv - -- , mkToInteger eenv - ] - ++ - Lang.names - (M.filterWithKey - (\k _ -> k == eqTC kv || k == numTC kv || k == ordTC kv || k == integralTC kv || k == structEqTC kv) - (toMap tc) - ) + , known_values = kv}) = + let ns = Lang.namesList + [ mkGe kv eenv + , mkGt kv eenv + , mkEq kv eenv + , mkNeq kv eenv + , mkLt kv eenv + , mkLe kv eenv + , mkAnd kv eenv + , mkOr kv eenv + , mkNot kv eenv + , mkPlus kv eenv + , mkMinus kv eenv + , mkMult kv eenv + -- , mkDiv kv eenv + , mkMod kv eenv + , mkNegate kv eenv + , mkImplies kv eenv + , mkIff kv eenv + , mkFromInteger kv eenv + -- , mkToInteger kv eenv -pprint :: (Var, LocSpecType) -> IO () -pprint (v, r) = do - let i = mkIdUnsafe v + , mkJust kv tenv + , mkNothing kv tenv - let doc = PPR.rtypeDoc FPP.Full $ val r - putStrLn $ show i - putStrLn $ show doc + , mkUnit kv tenv -printLHOut :: Lang.Id -> [ExecRes [FuncCall]] -> IO () -printLHOut entry = printParsedLHOut . parseLHOut entry + , mkIntegralExtactReal kv + , mkRealExtractNum kv + ] + ++ + Lang.namesList + (HM.filterWithKey + (\k _ -> k == eqTC kv || k == numTC kv || k == ordTC kv || k == integralTC kv || k == fractionalTC kv) + (toMap tc) + ) + ++ + Lang.namesList (filter (\(Name _ m _ _) -> m == Just "Data.Set.Internal") (E.keys eenv)) + in + MemConfig { search_names = ns + , pres_func = pf } + where + pf _ (Bindings { deepseq_walkers = dsw }) a = + S.fromList . map idName . M.elems $ M.filterWithKey (\n _ -> n `S.member` a) dsw -printParsedLHOut :: [LHReturn] -> IO () -printParsedLHOut [] = return () +printLHOut :: Lang.Id -> [ExecRes AbstractedInfo] -> IO () +printLHOut entry = + mapM_ (\lhr -> do printParsedLHOut lhr; putStrLn "") . map (parseLHOut entry) + +printCE :: State t -> [CounterExample] -> IO () +printCE s = + mapM_ (\lhr -> do printParsedLHOut lhr; putStrLn "") . map (counterExampleToLHReturn s) + +printParsedLHOut :: LHReturn -> IO () printParsedLHOut (LHReturn { calledFunc = FuncInfo {func = f, funcArgs = call, funcReturn = output} , violating = Nothing - , abstracted = abstr} : xs) = do + , abstracted = abstr}) = do putStrLn "The call" TI.putStrLn $ call `T.append` " = " `T.append` output TI.putStrLn $ "violates " `T.append` f `T.append` "'s refinement type" printAbs abstr - putStrLn "" - printParsedLHOut xs printParsedLHOut (LHReturn { calledFunc = FuncInfo {funcArgs = call, funcReturn = output} , violating = Just (FuncInfo {func = f, funcArgs = call', funcReturn = output'}) - , abstracted = abstr } : xs) = do + , abstracted = abstr }) = do TI.putStrLn $ call `T.append` " = " `T.append` output putStrLn "makes a call to" TI.putStrLn $ call' `T.append` " = " `T.append` output' TI.putStrLn $ "violating " `T.append` f `T.append` "'s refinement type" printAbs abstr - putStrLn "" - printParsedLHOut xs printAbs :: [FuncInfo] -> IO () printAbs fi = do @@ -324,31 +622,54 @@ printFuncInfo (FuncInfo {funcArgs = call, funcReturn = output}) = TI.putStrLn $ call `T.append` " = " `T.append` output -parseLHOut :: Lang.Id -> [ExecRes [FuncCall]] -> [LHReturn] -parseLHOut _ [] = [] -parseLHOut entry ((ExecRes { final_state = s - , conc_args = inArg - , conc_out = ex - , violated = ais}):xs) = - let - tl = parseLHOut entry xs - funcCall = T.pack $ mkCleanExprHaskell s - . foldl (\a a' -> App a a') (Var entry) $ inArg - funcOut = T.pack $ mkCleanExprHaskell s $ ex - - called = FuncInfo {func = nameOcc $ idName entry, funcArgs = funcCall, funcReturn = funcOut} +parseLHOut :: Lang.Id -> ExecRes AbstractedInfo -> LHReturn +parseLHOut entry (ExecRes { final_state = s + , conc_args = inArg + , conc_out = ex + , violated = ais}) = + let + called = funcCallToFuncInfo (printHaskell s) + $ FuncCall { funcName = idName entry, arguments = inArg, returns = ex} viFunc = fmap (parseLHFuncTuple s) ais - abstr = map (parseLHFuncTuple s) $ track s + abstr = map (parseLHFuncTuple s) . map abstract . abs_calls $ track s in LHReturn { calledFunc = called - , violating = if called `sameFuncNameArgs` viFunc then Nothing else viFunc - , abstracted = abstr} : tl + , violating = viFunc + , abstracted = abstr} -sameFuncNameArgs :: FuncInfo -> Maybe FuncInfo -> Bool -sameFuncNameArgs _ Nothing = False -sameFuncNameArgs (FuncInfo {func = f1, funcArgs = fa1}) (Just (FuncInfo {func = f2, funcArgs = fa2})) = f1 == f2 && fa1 == fa2 +counterExampleToLHReturn :: State t -> CounterExample -> LHReturn +counterExampleToLHReturn s (DirectCounter fc abstr _) = + let + called = funcCallToFuncInfo (printHaskell s) . abstract $ fc + abstr' = map (funcCallToFuncInfo (printHaskell s) . abstract) abstr + in + LHReturn { calledFunc = called + , violating = Nothing + , abstracted = abstr'} +counterExampleToLHReturn s (CallsCounter fc viol_fc abstr _) = + let + called = funcCallToFuncInfo (printHaskell s) . abstract $ fc + viol_called = funcCallToFuncInfo (printHaskell s) . abstract $ viol_fc + abstr' = map (funcCallToFuncInfo (printHaskell s) . abstract) abstr + in + LHReturn { calledFunc = called + , violating = Just viol_called + , abstracted = abstr'} +funcCallToFuncInfo :: (Expr -> T.Text) -> FuncCall -> FuncInfo +funcCallToFuncInfo t (FuncCall { funcName = f, arguments = inArg, returns = ret }) = + let + funcCall = t . foldl (\a a' -> App a a') (Var (Id f TyUnknown)) $ inArg + funcOut = t ret + in + FuncInfo {func = nameOcc f, funcArgs = funcCall, funcReturn = funcOut} + +lhStateToCE :: ExecRes AbstractedInfo -> CounterExample +lhStateToCE (ExecRes { final_state = State { track = t } }) + | Just c <- abs_violated t = CallsCounter (init_call t) c (abs_calls t) (ai_higher_order_calls t) + | otherwise = DirectCounter (init_call t) (abs_calls t) (ai_higher_order_calls t) + parseLHFuncTuple :: State t -> FuncCall -> FuncInfo parseLHFuncTuple s (FuncCall {funcName = n, arguments = ars, returns = out}) = let @@ -357,5 +678,5 @@ Nothing -> error $ "Unknown type for abstracted function " ++ show n in FuncInfo { func = nameOcc n - , funcArgs = T.pack $ mkCleanExprHaskell s (foldl' App (Var (Id n t)) ars) - , funcReturn = T.pack $ mkCleanExprHaskell s out } + , funcArgs = printHaskell s (foldl' App (Var (Id n t)) ars) + , funcReturn = printHaskell s out } diff --git a/src/G2/Liquid/LHReducers.hs b/src/G2/Liquid/LHReducers.hs --- a/src/G2/Liquid/LHReducers.hs +++ b/src/G2/Liquid/LHReducers.hs @@ -1,27 +1,54 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE UndecidableInstances #-} -module G2.Liquid.LHReducers ( LHRed (..) - , LHLimitByAcceptedHalter - , LHLimitByAcceptedOrderer - , LHAbsHalter (..) +module G2.Liquid.LHReducers ( lhRed + , allCallsRed + , higherOrderCallsRed + , redArbErrors + , nonRedAbstractReturnsRed + + , lhAcceptIfViolatedHalter + , lhSWHNFHalter + , lhLimitByAcceptedOrderer + , lhLimitByAcceptedHalter + , lhAbsHalter + , lhMaxOutputsHalter , LHTracker (..) - , lhReduce - , initialTrack - , limitByAccepted) where + , lhStdTimerHalter + , lhTimerHalter + , abstractCallsNum + , minAbstractCalls + + , lhReduce + , initialTrack) where + +import G2.Execution.NormalForms import G2.Execution.Reducer import G2.Execution.Rules import G2.Language +import qualified G2.Language.Stack as Stck import qualified G2.Language.ExprEnv as E import G2.Liquid.Annotations +import G2.Liquid.Conversion +import G2.Liquid.Helpers +import G2.Liquid.SpecialAsserts -import Data.Monoid +import Control.Monad.IO.Class +import qualified Data.HashSet as S +import Data.List +import Data.List.Extra +import qualified Data.Map as M +import Data.Maybe +import Data.Monoid hiding ((<>)) +import Data.Ord import Data.Semigroup import qualified Data.Text as T +import Data.Time.Clock -- lhReduce -- When reducing for LH, we change the rule for evaluating Var f. @@ -42,12 +69,17 @@ -- only the information that LH also knows (that is, the information in the -- refinment type.) lhReduce :: Name -> State LHTracker -> Maybe (Rule, [State LHTracker]) -lhReduce cfn s@(State { curr_expr = CurrExpr Evaluate (Tick (NamedLoc tn) e@(Assume fc _ _)) - , track = tr@(LHTracker { abstract_calls = abs_c } )}) +lhReduce cfn s@(State { curr_expr = CurrExpr Evaluate (Tick (NamedLoc tn) e@(Assume (Just fc) _ _)) + , track = tr@(LHTracker { abstract_calls = abs_c }) + , exec_stack = stck}) | cfn == tn = + let + stck' = if arguments fc == [] then Stck.filter (\f -> f /= UpdateFrame (funcName fc)) stck else stck + in Just ( RuleOther , [s { curr_expr = CurrExpr Evaluate e - , track = tr { abstract_calls = maybe abs_c (:abs_c) fc }}]) + , track = tr { abstract_calls = fc:abs_c } + , exec_stack = stck' }]) | otherwise = Nothing lhReduce _ _ = Nothing @@ -62,7 +94,7 @@ initialTrack eenv (App e e') = initialTrack eenv e + initialTrack eenv e' initialTrack eenv (Lam _ _ e) = initialTrack eenv e initialTrack eenv (Let b e) = initialTrack eenv e + (getSum $ evalContainedASTs (Sum . initialTrack eenv) b) -initialTrack eenv (Case e _ a) = initialTrack eenv e + (getMax $ evalContainedASTs (Max . initialTrack eenv) a) +initialTrack eenv (Case e _ _ a) = initialTrack eenv e + (getMax $ evalContainedASTs (Max . initialTrack eenv) a) initialTrack eenv (Cast e _) = initialTrack eenv e initialTrack eenv (Assume _ _ e) = initialTrack eenv e initialTrack eenv (Assert _ _ e) = initialTrack eenv e @@ -70,50 +102,109 @@ data LHTracker = LHTracker { abstract_calls :: [FuncCall] , last_var :: Maybe Name - , annotations :: AnnotMap } deriving (Eq, Show) + , annotations :: AnnotMap + , all_calls :: [FuncCall] + , higher_order_calls :: [FuncCall] } deriving (Eq, Show) + +minAbstractCalls :: [State LHTracker] -> Int +minAbstractCalls xs = + minimum $ 10000000000:mapMaybe (\s -> case true_assert s of + True -> Just $ abstractCallsNum s + False -> Nothing ) xs + +abstractCallsNum :: State LHTracker -> Int +abstractCallsNum = length . abstract_calls . track + instance Named LHTracker where - names (LHTracker {abstract_calls = abs_c, last_var = n, annotations = anns}) = - names abs_c ++ names n ++ names anns + names (LHTracker {abstract_calls = abs_c, last_var = n, annotations = anns, all_calls = ac, higher_order_calls = hc}) = + names abs_c <> names n <> names anns <> names ac <> names hc - rename old new (LHTracker {abstract_calls = abs_c, last_var = n, annotations = anns}) = + rename old new (LHTracker {abstract_calls = abs_c, last_var = n, annotations = anns, all_calls = ac, higher_order_calls = hc}) = LHTracker { abstract_calls = rename old new abs_c , last_var = rename old new n - , annotations = rename old new anns } + , annotations = rename old new anns + , all_calls = rename old new ac + , higher_order_calls = rename old new hc } - renames hm (LHTracker {abstract_calls = abs_c, last_var = n, annotations = anns}) = + renames hm (LHTracker {abstract_calls = abs_c, last_var = n, annotations = anns, all_calls = ac, higher_order_calls = hc}) = LHTracker { abstract_calls = renames hm abs_c , last_var = renames hm n - , annotations = renames hm anns } + , annotations = renames hm anns + , all_calls = renames hm ac + , higher_order_calls = renames hm hc } instance ASTContainer LHTracker Expr where - containedASTs (LHTracker {abstract_calls = abs_c, annotations = anns}) = - containedASTs abs_c ++ containedASTs anns - modifyContainedASTs f lht@(LHTracker {abstract_calls = abs_c, annotations = anns}) = - lht {abstract_calls = modifyContainedASTs f abs_c, annotations = modifyContainedASTs f anns} + containedASTs (LHTracker {abstract_calls = abs_c, annotations = anns, all_calls = ac, higher_order_calls = hc}) = + containedASTs abs_c ++ containedASTs anns ++ containedASTs ac ++ containedASTs hc + modifyContainedASTs f lht@(LHTracker {abstract_calls = abs_c, annotations = anns, all_calls = ac, higher_order_calls = hc}) = + lht { abstract_calls = modifyContainedASTs f abs_c + , annotations = modifyContainedASTs f anns + , all_calls = modifyContainedASTs f ac + , higher_order_calls = modifyContainedASTs f hc} instance ASTContainer LHTracker Type where - containedASTs (LHTracker {abstract_calls = abs_c, annotations = anns}) = containedASTs abs_c ++ containedASTs anns - modifyContainedASTs f lht@(LHTracker {abstract_calls = abs_c, annotations = anns}) = - lht {abstract_calls = modifyContainedASTs f abs_c, annotations = modifyContainedASTs f anns} + containedASTs (LHTracker {abstract_calls = abs_c, annotations = anns, all_calls = ac, higher_order_calls = hc}) = + containedASTs abs_c ++ containedASTs anns ++ containedASTs ac ++ containedASTs hc + modifyContainedASTs f lht@(LHTracker {abstract_calls = abs_c, annotations = anns, all_calls = ac, higher_order_calls = hc}) = + lht {abstract_calls = modifyContainedASTs f abs_c + , annotations = modifyContainedASTs f anns + , all_calls = modifyContainedASTs f ac + , higher_order_calls = modifyContainedASTs f hc } -data LHRed = LHRed Name +{-# INLINE lhRed #-} +lhRed :: Monad m => Name -> Reducer m () LHTracker +lhRed cfn = mkSimpleReducer (const ()) rr + where + rr _ s b = do + case lhReduce cfn s of + Just (_, s') -> + return $ ( InProgress + , zip s' (repeat ()), b) + Nothing -> return (Finished, [(s, ())], b) -instance Reducer LHRed () LHTracker where - initReducer _ _ = () +{-# INLINE allCallsRed #-} +allCallsRed :: Monad m => Reducer m () LHTracker +allCallsRed = mkSimpleReducer (const ()) rr + where + rr _ s@(State { curr_expr = CurrExpr Evaluate (Assert (Just fc) _ _) }) b = + let + lht = (track s) { all_calls = fc:all_calls (track s) } + in + return $ (Finished, [(s { track = lht } , ())], b) + rr _ s b = return $ (Finished, [(s, ())], b) - redRules lhr@(LHRed cfn) _ s b = do - case lhReduce cfn s of - Just (_, s') -> - return $ ( InProgress - , zip s' (repeat ()), b, lhr) - Nothing -> return (Finished, [(s, ())], b, lhr) +{-# INLINE higherOrderCallsRed #-} +higherOrderCallsRed :: Monad m => Reducer m () LHTracker +higherOrderCallsRed = mkSimpleReducer (const ()) rr + where + rr _ s@(State { curr_expr = CurrExpr Evaluate (Tick (NamedLoc nl) (Assume (Just fc) _ _)) }) b | nl == higherOrderTickName= + let + lht = (track s) { higher_order_calls = fc:higher_order_calls (track s) } + in + return $ (Finished, [(s { track = lht } , ())], b) + rr _ s@(State { curr_expr = CurrExpr Evaluate (Tick (NamedLoc nl) (Assume (Just fc) _ real_assert@(Assert _ _ _))) }) b | nl == higherOrderTickName= + let + lht = (track s) { higher_order_calls = fc:higher_order_calls (track s) } + in + return $ (Finished, [(s { curr_expr = CurrExpr Evaluate real_assert + , track = lht } , ())], b) + rr _ s b = return $ (Finished, [(s, ())], b) -limitByAccepted :: Int -> (LHLimitByAcceptedHalter, LHLimitByAcceptedOrderer) -limitByAccepted i = (LHLimitByAcceptedHalter i, LHLimitByAcceptedOrderer i) +{-# INLINE redArbErrors #-} +redArbErrors :: Monad m => Reducer m () t +redArbErrors = mkSimpleReducer (const ()) rr + where + rr _ s@(State { curr_expr = CurrExpr er (Tick tick (Let [(_, Type t)] _)) }) b + | tick == arbErrorTickish = + let + (arb, _) = arbValue t (type_env s) (arb_value_gen b) + in + return (InProgress, [(s { curr_expr = CurrExpr er arb }, ())], b) + rr _ s b = return (Finished, [(s, ())], b) --- LHLimitByAcceptedHalter and LHLimitByAcceptedOrderer should always be used --- together. +-- LHLimitByAcceptedHalter should always be used +-- with LHLimitByAcceptedOrderer. -- LHLimitByAcceptedHalter is parameterized by a cutoff, `c`. -- It allows execution of a state only if -- (1) No counterexamples have been found @@ -129,40 +220,30 @@ -- least steps, we only restart a State with too many steps once EVERY state has too -- many steps. --- | Halt if we go `n` steps past another, already accepted state -data LHLimitByAcceptedHalter = LHLimitByAcceptedHalter Int - -instance Halter LHLimitByAcceptedHalter (Maybe Int) LHTracker where - initHalt _ _ = Nothing - - -- If we start trying to execute a state with more than the maximal number - -- of rules applied, we throw it away. - discardOnStart (LHLimitByAcceptedHalter co) (Just v) _ s = num_steps s > v + co - discardOnStart _ Nothing _ _ = False +-- | Halt if we go `n` steps past another, already accepted state +lhLimitByAcceptedHalter :: Monad m => Int -> Halter m (Maybe Int) LHTracker +lhLimitByAcceptedHalter co = + (mkSimpleHalter (const Nothing) update stop (\hv _ _ _ -> hv)) { discardOnStart = discard } + where + -- If we start trying to execute a state with more than the maximal number + -- of rules applied, we throw it away. + discard (Just v) _ s = num_steps s > v + co + discard Nothing _ _ = False - -- Find all accepted states with the (current) minimal number of abstracted functions - -- Then, get the minimal number of steps taken by one of those states - updatePerStateHalt _ _ (Processed { accepted = []}) _ = Nothing - updatePerStateHalt _ _ (Processed { accepted = acc@(_:_)}) _ = - Just . minimum . map num_steps - $ allMin (length . abstract_calls . track) acc - - stopRed _ Nothing _ _ = Continue - stopRed (LHLimitByAcceptedHalter co) (Just nAcc) _ s = - if num_steps s > nAcc + co then Switch else Continue - - stepHalter _ hv _ _ _ = hv + -- Find all accepted states with the (current) minimal number of abstracted functions + -- Then, get the minimal number of steps taken by one of those states + update _ (Processed { accepted = []}) _ = Nothing + update _ (Processed { accepted = acc@(_:_)}) _ = + Just . minimum . map num_steps + $ allMin (length . abstract_calls . track) acc + + stop Nothing _ _ = return Continue + stop (Just nAcc) _ s = + return $ if num_steps s > nAcc + co then Switch else Continue -- | Runs the state that had the fewest number of rules applied. -data LHLimitByAcceptedOrderer = LHLimitByAcceptedOrderer Int - -instance Orderer LHLimitByAcceptedOrderer () Int LHTracker where - initPerStateOrder _ _ = () - - orderStates _ _ = num_steps - - updateSelected _ _ _ _ = () - +lhLimitByAcceptedOrderer :: Monad m => Orderer m () Int t +lhLimitByAcceptedOrderer = mkSimpleOrderer (const ()) (\_ _ -> return . num_steps ) (\_ _ -> return ()) allMin :: Ord b => (a -> b) -> [a] -> [a] allMin f xs = @@ -172,21 +253,136 @@ filter (\s -> minT == (f s)) xs -- | Halt if we abstract more calls than some other already accepted state -data LHAbsHalter = LHAbsHalter T.Text (Maybe T.Text) ExprEnv +{-# INLINE lhAbsHalter #-} +lhAbsHalter :: Monad m => T.Text -> Maybe T.Text -> ExprEnv -> Halter m Int LHTracker +lhAbsHalter entry modn eenv = mkSimpleHalter initial update stop step + where + -- We initialize the maximal number of abstracted variables, + -- to the number of variables in the entry function + initial _ = + let + fe = case E.occLookup entry modn eenv of + Just e -> e + Nothing -> error $ "initOrder: Bad function passed\n" ++ show entry ++ " " ++ show modn + in + initialTrack eenv fe -instance Halter LHAbsHalter Int LHTracker where - -- We initialize the maximal number of abstracted variables, - -- to the number of variables in the entry function - initHalt (LHAbsHalter entry modn eenv) _ = - let - fe = case E.occLookup entry modn eenv of - Just e -> e - Nothing -> error $ "initOrder: Bad function passed\n" ++ show entry ++ show modn - in - initialTrack eenv fe + update ii (Processed {accepted = acc}) _ = + minimum $ ii:mapMaybe (\s -> case true_assert s of + True -> Just . length . abstract_calls . track $ s + False -> Nothing) acc - updatePerStateHalt _ ii (Processed {accepted = acc}) _ = minimum $ ii:map (length . abstract_calls . track) acc + stop hv _ s = + return $ if length (abstract_calls $ track s) > hv + then Discard + else Continue - stopRed _ hv _ s = if length (abstract_calls $ track s) > hv then Discard else Continue + step hv _ _ _ = hv - stepHalter _ hv _ _ _ = hv +{-# INLINE lhMaxOutputsHalter #-} +lhMaxOutputsHalter :: Monad m => Int -> Halter m Int LHTracker +lhMaxOutputsHalter mx = (mkSimpleHalter + (const mx) + (\hv _ _ -> hv) + (\_ _ _ -> return Continue) + (\hv _ _ _ -> hv)) { discardOnStart = discard} + where + discard m (Processed { accepted = acc }) _ = length acc' >= m + where + min_abs = minAbstractCalls acc + acc' = filter (\s -> abstractCallsNum s == min_abs) acc + +{-# INLINE lhStdTimerHalter #-} +lhStdTimerHalter :: (MonadIO m, MonadIO m_run) => NominalDiffTime -> m (Halter m_run Int t) +lhStdTimerHalter ms = lhTimerHalter ms 10 + +{-# INLINE lhTimerHalter #-} +lhTimerHalter :: (MonadIO m, MonadIO m_run) => NominalDiffTime -> Int -> m (Halter m_run Int t) +lhTimerHalter ms ce = do + curr <- liftIO $ getCurrentTime + return $ mkSimpleHalter (const 0) + (\_ _ _ -> 0) + (stop curr) + step + where + stop it v (Processed { accepted = acc }) _ + | v == 0 + , any true_assert acc = do + curr <- liftIO $ getCurrentTime + let t_diff = diffUTCTime curr it + + if t_diff > ms + then return Discard + else return Continue + | otherwise = return Continue + + step v _ _ _ + | v >= ce = 0 + | otherwise = v + 1 + +-- | Reduces any non-SWHNF values being returned by an abstracted function +{-# INLINE nonRedAbstractReturnsRed #-} +nonRedAbstractReturnsRed :: Monad m => Reducer m () LHTracker +nonRedAbstractReturnsRed = + mkSimpleReducer (const ()) + nonRedAbstractReturnsRedStep + +nonRedAbstractReturnsRedStep :: Monad m => RedRules m () LHTracker +nonRedAbstractReturnsRedStep _ + s@(State { expr_env = eenv + , curr_expr = cexpr + , exec_stack = stck + , track = LHTracker { abstract_calls = afs } + , true_assert = True }) + b@(Bindings { deepseq_walkers = ds}) + | Just af <- firstJust (absRetToRed eenv ds) afs = do + let stck' = Stck.push (CurrExprFrame NoAction cexpr) stck + cexpr' = CurrExpr Evaluate af + + let s' = s { curr_expr = cexpr' + , exec_stack = stck' + } + + return (InProgress, [(s', ())], b) + | otherwise = do + return (Finished, [(s, ())], b) +nonRedAbstractReturnsRedStep _ s b = return (Finished, [(s, ())], b) + +absRetToRed :: ExprEnv -> Walkers -> FuncCall -> Maybe Expr +absRetToRed eenv ds (FuncCall { returns = r }) + | not . normalForm eenv $ r + , Just strict_e <- mkStrict_maybe ds r = + Just $ fillLHDictArgs ds strict_e + | otherwise = Nothing + +-- | Accepts a state when it is in SWHNF, true_assert is true, +-- and all abstracted functions have reduced returns. +-- Discards it if in SWHNF and true_assert is false +lhAcceptIfViolatedHalter :: Monad m => Halter m () LHTracker +lhAcceptIfViolatedHalter = mkSimpleHalter (const ()) (\_ _ _ -> ()) stop (\_ _ _ _ -> ()) + where + stop _ _ s = + let + eenv = expr_env s + abs_calls = abstract_calls (track s) + in + case isExecValueForm s of + True + | true_assert s + , all (normalForm eenv . returns) abs_calls -> return Accept + | true_assert s -> return Continue + | otherwise -> return Discard + False -> return Continue + +lhSWHNFHalter :: Monad m => Halter m () LHTracker +lhSWHNFHalter = mkSimpleHalter (const ()) (\_ _ _ -> ()) stop (\_ _ _ _ -> ()) + where + stop _ _ s = + let + eenv = expr_env s + abs_calls = abstract_calls (track s) + in + case isExecValueForm s && all (normalForm eenv . returns) abs_calls of + True -> return Accept + False -> return Continue + diff --git a/src/G2/Liquid/Measures.hs b/src/G2/Liquid/Measures.hs --- a/src/G2/Liquid/Measures.hs +++ b/src/G2/Liquid/Measures.hs @@ -1,7 +1,8 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} -module G2.Liquid.Measures (Measures, createMeasures) where +module G2.Liquid.Measures (Measures, createMeasures, filterMeasures', measureTypeMappings) where import G2.Language import qualified G2.Language.ExprEnv as E @@ -13,7 +14,7 @@ import Control.Monad.Extra -import qualified Data.Map as M +import Data.List import Data.Maybe import qualified GHC as GHC @@ -23,9 +24,11 @@ -- This is required to find all measures that are written in comments. createMeasures :: [Measure SpecType GHC.DataCon] -> LHStateM () createMeasures meas = do - nt <- return . M.fromList =<< mapMaybeM measureTypeMappings meas + nt <- return . HM.fromList =<< mapMaybeM measureTypeMappings meas meas' <- mapMaybeM (convertMeasure nt) =<< filterM allTypesKnown meas + filterMeasures (HM.keys nt) + meenv <- measuresM let eenvk = E.keys meenv mvNames = filter (flip notElem eenvk) $ varNames meas' @@ -35,13 +38,35 @@ return () +-- | We remove any names covered by the Measures found by LH from the Measures we already have +-- to prevent using the wrong measures later +filterMeasures :: [Name] -> LHStateM () +filterMeasures nt = do + pre_meenv <- measuresM + fil_meenv <- filterMeasures' pre_meenv nt + putMeasuresM fil_meenv + +filterMeasures' :: Measures -> [Name] -> LHStateM Measures +filterMeasures' pre_meenv nt = do + let ns = map (\(Name n m _ _) -> (n, m)) nt + fil_meenv = E.filterWithKey (\(Name n m _ _) _ -> (n, m) `notElem` ns) pre_meenv + return fil_meenv + allTypesKnown :: Measure SpecType GHC.DataCon -> LHStateM Bool +#if MIN_VERSION_liquidhaskell(0,8,6) +allTypesKnown (M {msSort = srt}) = do +#else allTypesKnown (M {sort = srt}) = do +#endif st <- specTypeToType srt return $ isJust st measureTypeMappings :: Measure SpecType GHC.DataCon -> LHStateM (Maybe (Name, Type)) +#if MIN_VERSION_liquidhaskell(0,8,6) +measureTypeMappings (M {msName = n, msSort = srt}) = do +#else measureTypeMappings (M {name = n, sort = srt}) = do +#endif st <- specTypeToType srt lh <- lhTCM @@ -61,7 +86,11 @@ mapInTyForAlls (\t' -> foldr TyFun t' lhD) t convertMeasure :: BoundTypes -> Measure SpecType GHC.DataCon -> LHStateM (Maybe (Name, Expr)) +#if MIN_VERSION_liquidhaskell(0,8,6) +convertMeasure bt (M {msName = n, msSort = srt, msEqns = eq}) = do +#else convertMeasure bt (M {name = n, sort = srt, eqns = eq}) = do +#endif let n' = symbolName $ val n st <- specTypeToType srt @@ -78,12 +107,15 @@ stArgs = anonArgumentTypes . PresType $ fromJust st stRet = fmap (returnType . PresType) st - lam_i <- freshIdN (head stArgs) + lam_i <- mapM freshIdN stArgs cb <- freshIdN (head stArgs) - alts <- mapMaybeM (convertDefs stArgs stRet (M.fromList as_t) bt) eq + alts <- mapMaybeM (convertDefs stArgs stRet (HM.fromList as_t) bt) eq + fls <- mkFalseE + let defTy = maybe TyUnknown (returnType . PresType) st + defAlt = Alt Default $ Assume Nothing fls (Prim Undefined defTy) - let e = mkLams as' (Lam TermL lam_i $ Case (Var lam_i) cb alts) + let e = mkLams (as' ++ map (TermL,) lam_i) $ Case (Var (head lam_i)) cb defTy (defAlt:alts) case st of -- [1] Just _ -> return $ Just (n', e) @@ -96,14 +128,12 @@ convertDefs :: [Type] -> Maybe Type -> LHDictMap -> BoundTypes -> Def SpecType GHC.DataCon -> LHStateM (Maybe Alt) convertDefs [l_t] ret m bt (Def { ctor = dc, body = b, binds = bds}) | TyCon _ _ <- tyAppCenter l_t - , st_t <- tyAppArgs l_t = do + , st_t <- tyAppArgs l_t + , dc' <- mkDataUnsafe dc = do tenv <- typeEnv - let (DataCon n t) = mkData HM.empty HM.empty dc - (TyCon tn _) = tyAppCenter $ returnType $ PresType t - dc' = getDataConNameMod tenv tn n - + let -- See [1] below, we only evaluate this if Just - dc''@(DataCon _ dct) = fromJust dc' + dc''@(DataCon _ dct) = fixNamesDC tenv dc' bnds = tyForAllBindings $ PresType dct dctarg = anonArgumentTypes $ PresType dct @@ -116,20 +146,49 @@ let is = map (uncurry Id) nt - e <- mkExprFromBody ret m (M.union bt $ M.fromList nt) b + e <- mkExprFromBody ret m (HM.union bt $ HM.fromList nt) b - case dc' of - Just _ -> return $ Just $ Alt (DataAlt dc'' is) e -- [1] - Nothing -> return Nothing + return $ Just $ Alt (DataAlt dc'' is) e -- [1] + | otherwise = return Nothing convertDefs _ _ _ _ _ = error "convertDefs: Unhandled Type List" +fixNamesDC :: TypeEnv -> DataCon -> DataCon +fixNamesDC tenv (DataCon n t) = + let + (TyCon tn _) = tyAppCenter $ returnType $ PresType t + in + case getDataConNameMod tenv tn n of + Just (DataCon dcn _) -> DataCon dcn (fixNamesType tenv t) + Nothing -> error "fixNamesDC: Bad DC" + +fixNamesType :: TypeEnv -> Type -> Type +fixNamesType tenv = modify (fixNamesType' tenv) + +fixNamesType' :: TypeEnv -> Type -> Type +fixNamesType' tenv (TyCon n k) = + case getTypeNameMod tenv n of + Just n' -> TyCon n' k + Nothing -> error "fixNamesType: Bad Type" +fixNamesType' _ t = t + +getTypeNameMod :: TypeEnv -> Name -> Maybe Name +getTypeNameMod tenv (Name n m _ _) = find (\(Name n' m' _ _) -> n == n' && m == m') $ HM.keys tenv + mkExprFromBody :: Maybe Type -> LHDictMap -> BoundTypes -> Body -> LHStateM Expr mkExprFromBody ret m bt (E e) = convertLHExpr (mkDictMaps m) bt ret e mkExprFromBody ret m bt (P e) = convertLHExpr (mkDictMaps m) bt ret e -mkExprFromBody _ _ _ _ = error "mkExprFromBody: Unhandled Body" +mkExprFromBody ret m bt (R s e) = do + let s_nm = symbolName s + t = maybe (error "mkExprFromBody: ret type unknown") id ret + i = Id s_nm t + bt' = HM.insert s_nm t bt + g2_e <- convertLHExpr (mkDictMaps m) bt' ret e + return . Let [(i, SymGen SNoLog t)] . Assume Nothing g2_e $ Var i + mkDictMaps :: LHDictMap -> DictMaps mkDictMaps ldm = DictMaps { lh_dicts = ldm - , num_dicts = M.empty - , integral_dicts = M.empty - , ord_dicts = M.empty} + , num_dicts = HM.empty + , integral_dicts = HM.empty + , fractional_dicts = HM.empty + , ord_dicts = HM.empty} diff --git a/src/G2/Liquid/MkLHVals.hs b/src/G2/Liquid/MkLHVals.hs new file mode 100644 --- /dev/null +++ b/src/G2/Liquid/MkLHVals.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE OverloadedStrings #-} + +module G2.Liquid.MkLHVals (mkLHVals) where + +import G2.Language as Lang +import G2.Language.KnownValues +import qualified G2.Language.ExprEnv as E + +import qualified Data.HashSet as S +import qualified Data.Text as T + +mkLHVals :: State t + -> S.HashSet Name + -> [Name] + -> NameGen + -> (ExprEnv, KnownValues, TypeClasses, S.HashSet Name, [Name], NameGen) +mkLHVals (State { expr_env = eenv + , type_env = tenv + , known_values = kv + , type_classes = tc }) inst exported ng = + let + renme = E.keys eenv + ((meenv, mkv, mtc, minst, mexported), ng') = doRenames renme ng (eenv, kv, tc, inst, exported) + + (newMod, meenv', ng'') = symGenIfZero (modFunc mkv) meenv tenv mkv mtc ng' + in + (meenv', mkv { modFunc = newMod } , mtc, minst, mexported, ng'') + +symGenIfZero :: Name -> ExprEnv -> TypeEnv -> KnownValues -> TypeClasses -> NameGen -> (Name, ExprEnv, NameGen) +symGenIfZero n eenv tenv kv tc ng = + case E.lookup n eenv of + Just e -> + let + (newN, ng') = freshSeededString ("symGen" `T.append` nameOcc n) ng + (e', ng'') = symGenIfZero' e eenv tenv kv tc ng' + in + (newN, E.insert newN e' eenv, ng'') + Nothing -> error "symGenIfZero: Name not found" + +symGenIfZero' :: Expr -> ExprEnv -> TypeEnv -> KnownValues -> TypeClasses -> NameGen -> (Expr, NameGen) +symGenIfZero' e eenv tenv kv tc ng = + let + (ars, ng') = argTyToLamUseIds (spArgumentTypes e) ng + + class_ty = case ars of + (TypeL, c_ty):_ -> c_ty + _ -> error "symGenIfZero: Type not found" + snd_int = haveType (TyVar class_ty) (map snd ars) !! 1 + + int_tcs_m = tcWithNameMap (integralTC kv) (map snd ars) + int_tc = case typeClassInst tc int_tcs_m (integralTC kv) (TyVar class_ty) of + Just int_tc' -> int_tc' + Nothing -> error "symGenIfZero: Typeclass dictionary not found" + + type_expr = Type (TyVar class_ty) + num_dict = App + (App + (mkRealExtractNum kv) + type_expr + ) + (App + (App + (mkIntegralExtactReal kv) + type_expr + ) + int_tc + ) + eq_dict = + App + (App + (mkOrdExtractEq kv) + type_expr + ) + (App + (App + (mkRealExtractOrd kv) + type_expr + ) + (App + (App + (mkIntegralExtactReal kv) + type_expr + ) + int_tc + ) + ) + zero = App (mkDCInteger kv tenv) (Lit (LitInt 0)) + zero_con = mkApp [mkFromInteger kv eenv, type_expr, num_dict, zero] + eq = mkApp [ Var (Id (eqFunc kv) TyUnknown) + , type_expr + , eq_dict + , Var snd_int + , zero_con] + + (i, ng'') = freshId (Lang.tyBool kv) ng' + + trueDC = mkDCTrue kv tenv + + ret_t = returnType e + + e' = mkLams ars + $ Case eq i ret_t + [ Alt Default (mkApp (e:map (Var . snd) ars)) + , Alt (DataAlt trueDC []) (SymGen SNoLog ret_t)] + in + (e', ng'') + +haveType :: Type -> [Id] -> [Id] +haveType t = filter (\e -> typeOf e == t) + +argTyToLamUseIds :: [ArgType] -> NameGen -> ([(LamUse, Id)], NameGen) +argTyToLamUseIds = + mapNG (\ar_ty ng -> + case ar_ty of + NamedType i -> ((TypeL, i), ng) + AnonType t -> + let + (n, ng') = freshName ng + in + ((TermL, Id n t), ng')) diff --git a/src/G2/Liquid/Simplify.hs b/src/G2/Liquid/Simplify.hs --- a/src/G2/Liquid/Simplify.hs +++ b/src/G2/Liquid/Simplify.hs @@ -1,20 +1,42 @@ {-# Language FlexibleContexts #-} +{-# Language OverloadedStrings #-} -module G2.Liquid.Simplify ( simplify ) where +module G2.Liquid.Simplify ( simplify + , furtherSimplifyCurrExpr ) where import G2.Language +import qualified G2.Language.ExprEnv as E +import qualified G2.Language.Simplification as GSimp import G2.Language.Monad import G2.Liquid.Types +import qualified Data.HashSet as HS +import Data.Monoid ((<>)) +import qualified Data.Text as T + -- | The LH translation generates certain redundant Expr's over and over again. -- Here we stamp them out. simplify :: LHStateM () simplify = do + removeRedundantAsserts simplifyExprEnv mapCurrExpr simplifyExpr mapAssumptionsM simplifyExpr mapAnnotsExpr simplifyExpr + in_eenv <- inlineEnv + in_case_env <- inlineInCaseEnv + mapAssumptionsM (return . GSimp.simplifyExprs in_eenv in_case_env) + mapPostM (return . GSimp.simplifyExprs in_eenv in_case_env) + mapE (GSimp.simplifyExprs in_eenv in_case_env) + mapMeasuresM (return . GSimp.simplifyExprs in_eenv in_case_env) + +furtherSimplifyCurrExpr :: LHStateM () +furtherSimplifyCurrExpr = do + in_eenv <- inlineEnv + in_case_env <- inlineInCaseEnv + mapCurrExpr (return . GSimp.simplifyExprs in_eenv in_case_env) + simplifyExprEnv :: LHStateM () simplifyExprEnv = mapME simplifyExpr @@ -85,3 +107,94 @@ fixM f e = do e' <- f e if e == e' then return e else fixM f e' + + +-- | Asserts in the default numerical classes just reflect the actual function definition directly, +-- so we can remove them to save some time. +removeRedundantAsserts :: LHStateM () +removeRedundantAsserts = mapWithKeyME removeRedundantAsserts' + +removeRedundantAsserts' :: Name -> Expr -> LHStateM Expr +removeRedundantAsserts' (Name n m _ _) e + | (n, m) `HS.member` specFuncs = return $ elimAsserts e + | otherwise = return e + +-- | Environments for inlining +inlineEnv :: LHStateM ExprEnv +inlineEnv = do + tcv <- tcValuesM + lh_tc_n <- lhTCM + lhnum_tc_n <- lhNumTCM + + g2_int <- tyIntT + lh_int_tc <- measureClassDictExpr lh_tc_n g2_int + num_int_tc <- regTCClassDictExpr lhnum_tc_n g2_int + + eenv <- exprEnv + meas <- measuresM + let lh_ns = names tcv <> names lh_int_tc <> names num_int_tc + eenv' = E.filterWithKey (\n _ -> n `elem` lh_ns) $ E.union eenv meas + return eenv' + +inlineInCaseEnv :: LHStateM ExprEnv +inlineInCaseEnv = do + tc <- typeClasses + lh_tc_n <- lhTCM + lh_num <- lhNumTCM + let all_lh_tc = lookupTCDicts lh_tc_n tc + all_num_tc = lookupTCDicts lh_num tc + + eenv <- exprEnv + meas <- measuresM + let lh_ns = names all_lh_tc <> names all_num_tc + eenv' = E.filterWithKey (\n _ -> n `elem` lh_ns) $ E.union eenv meas + return eenv' + +measureClassDictExpr :: Name -> Type -> LHStateM (Maybe Expr) +measureClassDictExpr = classDictExpr lookupMeasureM lookupTCDictTC + +regTCClassDictExpr :: Name -> Type -> LHStateM (Maybe Expr) +regTCClassDictExpr = classDictExpr lookupE lookupTCDictTC + +classDictExpr :: (Name -> LHStateM (Maybe Expr)) + -> (Name -> Type -> LHStateM (Maybe Id)) + -> Name + -> Type + -> LHStateM (Maybe Expr) +classDictExpr look_ex look_tc n t = do + i <- look_tc n t + case i of + Just i' -> look_ex (idName i') + Nothing -> return Nothing + +specFuncs :: HS.HashSet (T.Text, Maybe T.Text) +specFuncs = HS.fromList [ ("+", Just "GHC.Num") + , ("-", Just "GHC.Num") + , ("*", Just "GHC.Num") + , ("negate", Just "GHC.Num") + , ("abs", Just "GHC.Num") + , ("signum", Just "GHC.Num") + , ("fromInteger", Just "GHC.Num") + + , ("quot", Just "GHC.Real") + , ("rem", Just "GHC.Real") + , ("div", Just "GHC.Real") + , ("mod", Just "GHC.Real") + , ("quotRem", Just "GHC.Real") + , ("divMod", Just "GHC.Real") + , ("toInteger", Just "GHC.Real") + + , ("==", Just "GHC.Classes") + , ("/=", Just "GHC.Classes") + + , ("<", Just "GHC.Classes") + , ("<=", Just "GHC.Classes") + , (">", Just "GHC.Classes") + , (">=", Just "GHC.Classes") + + , ("I#", Just "GHC.Types") + , ("True", Just "GHC.Types") + , ("False", Just "GHC.Types") + + , ("$", Just "GHC.Base")] + diff --git a/src/G2/Liquid/SpecialAsserts.hs b/src/G2/Liquid/SpecialAsserts.hs --- a/src/G2/Liquid/SpecialAsserts.hs +++ b/src/G2/Liquid/SpecialAsserts.hs @@ -1,11 +1,23 @@ +{-# LANGUAGE OverloadedStrings #-} + module G2.Liquid.SpecialAsserts ( addSpecialAsserts - , addTrueAsserts) where + , addTrueAsserts + , addTrueAssertsAll + , addErrorAssumes + , arbErrorTickish + , assumeErrorTickish) where +import G2.Liquid.Config import G2.Language import qualified G2.Language.KnownValues as KV import G2.Language.Monad import G2.Liquid.Types +import qualified Data.HashSet as S +import qualified Data.Text as T + +import Debug.Trace + -- | Adds an assert of false to the function called when a pattern match fails addSpecialAsserts :: LHStateM () addSpecialAsserts = do @@ -27,9 +39,9 @@ -- excluding certain functions (namely dicts) that we never want to abstract -- Furthermore, expands all Lambdas as much as possible, so that we get all the arguments -- for the assertion. -addTrueAsserts :: Id -> LHStateM () -addTrueAsserts i = do - ns <- return . maybe [] varNames =<< lookupE (idName i) +addTrueAsserts :: ExState s m => Name -> m () +addTrueAsserts n = do + ns <- return . maybe [] varNames =<< lookupE n tc <- return . tcDicts =<< typeClasses let tc' = map idName tc @@ -37,21 +49,88 @@ mapWithKeyME (addTrueAsserts' ns') -addTrueAsserts' :: [Name] -> Name -> Expr -> LHStateM Expr +addTrueAsserts' :: ExState s m => [Name] -> Name -> Expr -> m Expr addTrueAsserts' ns n e - | n `elem` ns = - insertInLamsE (\is e' -> - case e' of - Let [(_, _)] (Assert _ _ _) -> return e' - _ -> do - true <- mkTrueE - r <- freshIdN (typeOf e') + | n `elem` ns = addTrueAssert'' n e + | otherwise = return e - let fc = FuncCall { funcName = n - , arguments = map Var is - , returns = (Var r)} - e'' = Let [(r, e')] $ Assert (Just fc) true (Var r) +addTrueAssert'' :: ExState s m => Name -> Expr -> m Expr +addTrueAssert'' n e = do + insertInLamsE (\is e' -> + case e' of + Let [(_, _)] (Assert _ _ _) -> return e' + _ -> do + true <- mkTrueE + r <- freshIdN (returnType e') - return e'' - ) =<< etaExpandToE (numArgs e) e - | otherwise = return e + more_is <- tyBindings e' + + let fc = FuncCall { funcName = n + , arguments = map Var $ is ++ map snd more_is + , returns = (Var r)} + e'' = mkLams more_is $ Let [(r, mkApp $ e':map (Var . snd) more_is)] $ Assert (Just fc) true (Var r) + + return e'' + ) =<< etaExpandToE (numArgs e) e + +tyBindings :: (ExState s m, Typed t) => t -> m [(LamUse, Id)] +tyBindings t = do + let at = spArgumentTypes t + fn <- freshNamesN (length at) + return $ tyBindings' fn at + +tyBindings' :: [Name] -> [ArgType] -> [(LamUse, Id)] +tyBindings' _ [] = [] +tyBindings' ns (NamedType i:ts) = (TypeL, i):tyBindings' ns ts +tyBindings' (n:ns) (AnonType t:ts) = (TermL, Id n t):tyBindings' ns ts +tyBindings' [] _ = error "Name list exhausted in tyBindings'" + +addTrueAssertsAll :: ExState s m => m () +addTrueAssertsAll = mapWithKeyME (addTrueAssert'') + +--- [BlockErrors] +-- | Blocks calling error in the functions specified in the block_errors_in in +-- the Config, by wrapping the errors in Assume False. +addErrorAssumes :: LHConfig -> LHStateM () +addErrorAssumes config = do + kv <- knownValues + mapWithKeyME (addErrorAssumes' (block_errors_method config) (block_errors_in config) kv) + lh_kv <- lhKnownValuesM + mapMeasuresWithKeyM (addErrorAssumes' (block_errors_method config) (block_errors_in config) lh_kv) + +addErrorAssumes' :: BlockErrorsMethod -> S.HashSet (T.Text, Maybe T.Text) -> KnownValues -> Name -> Expr -> LHStateM Expr +addErrorAssumes' be ns kv (Name n m _ _) e = do + if (n, m) `S.member` ns then addErrorAssumes'' be kv (typeOf e) e else return e + +addErrorAssumes'' :: BlockErrorsMethod -> KnownValues -> Type -> Expr -> LHStateM Expr +addErrorAssumes'' be kv _ v@(Var (Id n t)) + | KV.isErrorFunc kv n + , be == AssumeBlock = do + flse <- mkFalseE + return $ Assume Nothing (Tick assumeErrorTickish flse) v + | KV.isErrorFunc kv n + , be == ArbBlock = do + d <- freshSeededStringN "d" + let ast = spArgumentTypes $ PresType t + rt = returnType $ PresType t + + lam_it = map (\as -> case as of + AnonType at -> (TermL, Id d at) + NamedType i -> (TypeL, i)) ast + fr_n <- trace ("ast = " ++ show ast ++ "\nrt = " ++ show rt) freshSeededStringN "t" + + flse <- mkFalseE + + return . mkLams lam_it + . Assume Nothing (Tick assumeErrorTickish flse) + . Tick arbErrorTickish + $ Let [(Id fr_n TYPE, Type rt)] v +addErrorAssumes'' be kv (TyForAll _ t) (Lam u i e) = return . Lam u i =<< modifyChildrenM (addErrorAssumes'' be kv t) e +addErrorAssumes'' be kv (TyFun _ t) (Lam u i e) = return . Lam u i =<< modifyChildrenM (addErrorAssumes'' be kv t) e +addErrorAssumes'' be kv t e = modifyChildrenM (addErrorAssumes'' be kv t) e + +arbErrorTickish :: Tickish +arbErrorTickish = NamedLoc (Name "arb_error" Nothing 0 Nothing) + +assumeErrorTickish :: Tickish +assumeErrorTickish = NamedLoc (Name "library_error" Nothing 0 Nothing) diff --git a/src/G2/Liquid/TCGen.hs b/src/G2/Liquid/TCGen.hs --- a/src/G2/Liquid/TCGen.hs +++ b/src/G2/Liquid/TCGen.hs @@ -10,26 +10,26 @@ import G2.Liquid.Types import Data.Foldable -import qualified Data.Map as M +import qualified Data.HashMap.Lazy as HM import qualified Data.Text as T -- | Creates an LHState. This involves building a TCValue, and -- creating the new LH TC which checks equality, and has a function to -- check refinements of polymorphic types -createLHState :: Measures -> KnownValues -> State [FuncCall] -> Bindings -> (LHState, Bindings) -createLHState meenv mkv s b = +createLHState :: Measures -> KnownValues -> TypeClasses -> State [FuncCall] -> Bindings -> (LHState, Bindings) +createLHState meenv mkv mtc s b = let - (tcv, (s', b')) = runStateM (createTCValues mkv) s b + (tcv, (s', b')) = runStateM (createTCValues mkv (type_env s)) s b - lh_s = consLHState s' meenv tcv + lh_s = consLHState s' meenv mkv mtc tcv in execLHStateM (do createLHTCFuncs createExtractors) lh_s b' -createTCValues :: KnownValues -> StateM [FuncCall] TCValues -createTCValues kv = do +createTCValues :: KnownValues -> TypeEnv -> StateM [FuncCall] TCValues +createTCValues kv tenv = do lhTCN <- freshSeededStringN "lh" lhEqN <- freshSeededStringN "lhEq" lhNeN <- freshSeededStringN "lhNe" @@ -41,6 +41,7 @@ lhPPN <- freshSeededStringN "lhPP" lhNuOr <- freshSeededStringN "lhNuOr" + lhOrdN <- freshSeededStringN "lhOrd" let tcv = (TCValues { lhTC = lhTCN , lhNumTC = KV.numTC kv @@ -61,21 +62,34 @@ , lhMod = KV.modFunc kv , lhFromInteger = KV.fromIntegerFunc kv , lhToInteger = KV.toIntegerFunc kv + + , lhFromRational = KV.fromRationalFunc kv + + , lhToRatioFunc = KV.toRatioFunc kv + , lhNumOrd = lhNuOr , lhAnd = KV.andFunc kv , lhOr = KV.orFunc kv + , lhNot = KV.notFunc kv - , lhPP = lhPPN }) + , lhImplies = KV.impliesFunc kv + , lhIff = KV.iffFunc kv + , lhPP = lhPPN + + , lhOrd = lhOrdN + + , lhSet = nameModMatch (Name "Set" (Just "Data.Set.Internal") 0 Nothing) tenv}) + return tcv type PredFunc = LHDictMap -> Name -> AlgDataTy -> DataCon -> [Id] -> LHStateM [Alt] createLHTCFuncs :: LHStateM () createLHTCFuncs = do - lhm <- mapM (uncurry initalizeLHTC) . M.toList =<< typeEnv - let lhm' = M.fromList lhm + lhm <- mapM (uncurry initalizeLHTC) . HM.toList =<< typeEnv + let lhm' = HM.fromList lhm -- createLHTCFuncs' relies on the standard TypeClass lookup functions to get access to -- LH Dicts. So it is important that, before calling it, we set up the TypeClass correctly @@ -90,11 +104,11 @@ tc <- typeClasses tcn <- lhTCM tci <- freshIdN TYPE - let tc' = insertClass tcn (Class { insts = lhtc, typ_ids = [tci] }) tc + let tc' = insertClass tcn (Class { insts = lhtc, typ_ids = [tci], superclasses = [] }) tc putTypeClasses tc' -- Now, we do the work of actually generating all the code/functions for the typeclass - mapM_ (uncurry (createLHTCFuncs' lhm')) . M.toList =<< typeEnv + mapM_ (uncurry (createLHTCFuncs' lhm')) . HM.toList =<< typeEnv initalizeLHTC :: Name -> AlgDataTy -> LHStateM (Name, Id) initalizeLHTC n adt = do @@ -109,12 +123,12 @@ let ct = foldl' TyApp (TyCon n TYPE) $ map TyVar bi let t = (TyApp - (TyCon lh TYPE) + (TyCon lh (TyFun TYPE TYPE)) ct ) let t' = foldr TyFun t $ map (TyApp (TyCon lh (TyFun TYPE TYPE)) . TyVar) bi - let t'' = foldr TyForAll t' $ map NamedTyBndr bi + let t'' = foldr TyForAll t' bi return t'' lhName :: T.Text -> Name -> LHStateM Name @@ -150,6 +164,15 @@ pp <- lhPPFunc n adt insertMeasureM ppN pp + -- We also put the Ord typeclass into the LH TC, if it exists. + ord <- ordTCM + ordDict <- lookupTCDictTC ord (TyCon n TyUnknown) + ordE <- case ordDict of + Just i -> return (Var i) + _ -> do + flse <- mkFalseE + return (Assume Nothing flse (Prim Undefined TyUnknown)) + -- We define a function to get the LH Dict for this type -- It takes and passes on the type arguments, and the LH Dicts for those -- type arguments @@ -167,15 +190,15 @@ , (leN, (typeOf le)) , (gtN, (typeOf gt)) , (geN, (typeOf ge)) - , (ppN, (typeOf pp)) ] - let fs' = map (\f -> mkApp $ f:bt ++ lhdv) fs + , (ppN, (typeOf pp))] + let fs' = map (\f -> mkApp $ f:bt ++ lhdv) fs ++ [ordE] lhdct <- lhDCType let e = mkApp $ Data (DataCon lh lhdct):fs' let e' = foldr (Lam TermL) e lhd let e'' = foldr (Lam TypeL) e' bi - let fn = M.lookup n lhm + let fn = HM.lookup n lhm case fn of Just fn' -> do @@ -210,9 +233,12 @@ taab --ge (TyFun TyUnknown - (TyApp - (TyCon lh TYPE) - (TyVar n) + (TyFun + TyUnknown + (TyApp + (TyCon lh (TyFun TYPE TYPE)) + (TyVar n) + ) ) ) ) @@ -232,12 +258,12 @@ let bi = bound_ids adt lh <- lhTCM - lhbi <- mapM (freshIdN . TyApp (TyCon lh TYPE) . TyVar) bi + lhbi <- mapM (freshIdN . TyApp (TyCon lh (TyFun TYPE TYPE)) . TyVar) bi d1 <- freshIdN (TyCon n TYPE) d2 <- freshIdN (TyCon n TYPE) - let m = M.fromList $ zip (map idName bi) lhbi + let m = HM.fromList $ zip (map idName bi) lhbi e <- mkFirstCase cf m d1 d2 n adt let e' = mkLams (map (TypeL,) bi ++ map (TermL,) lhbi ++ [(TermL, d1), (TermL, d2)]) e @@ -247,10 +273,12 @@ mkFirstCase :: PredFunc -> LHDictMap -> Id -> Id -> Name -> AlgDataTy -> LHStateM Expr mkFirstCase f ldm d1 d2 n adt@(DataTyCon { data_cons = dcs }) = do caseB <- freshIdN (typeOf d1) - return . Case (Var d1) caseB =<< mapM (mkFirstCase' f ldm d2 n adt) dcs + boolT <- tyBoolT + return . Case (Var d1) caseB boolT =<< mapM (mkFirstCase' f ldm d2 n adt) dcs mkFirstCase f ldm d1 d2 n adt@(NewTyCon { data_con = dc }) = do caseB <- freshIdN (typeOf d1) - return . Case (Var d1) caseB . (:[]) =<< mkFirstCase' f ldm d2 n adt dc + boolT <- tyBoolT + return . Case (Var d1) caseB boolT . (:[]) =<< mkFirstCase' f ldm d2 n adt dc mkFirstCase _ _ _ _ _ _ = error "mkFirstCase: Unsupported AlgDataTy" mkFirstCase' :: PredFunc -> LHDictMap -> Id -> Name -> AlgDataTy -> DataCon -> LHStateM Alt @@ -265,8 +293,10 @@ alts <- f ldm n adt dc ba1 - return $ Case (Var d2) caseB alts + boolT <- tyBoolT + return $ Case (Var d2) caseB boolT alts + lhEqFunc :: PredFunc lhEqFunc ldm _ _ dc ba1 = do ba2 <- freshIdsN $ anonArgumentTypes dc @@ -289,8 +319,8 @@ i <- freshIdN TYPE b <- tyBoolT - let lhv = App (Var $ Id lhe (TyForAll (NamedTyBndr i) (TyFun (TyVar i) (TyFun (TyVar i) b)))) (Type t) lhd <- lhTCDict' ldm t + let lhv = App (Var $ Id lhe (TyForAll i (TyFun (typeOf lhd) (TyFun (TyVar i) (TyFun (TyVar i) b))))) (Type t) return $ foldl' App (App lhv lhd) [Var i1, Var i2] @@ -302,7 +332,7 @@ lhd <- lhTCDict' ldm t - let lhv = App (Var (Id lhe (TyForAll (NamedTyBndr i) (TyFun (TyVar i) (TyFun (TyVar i) b))))) (Type t) + let lhv = App (Var (Id lhe (TyForAll i (TyFun (typeOf lhd) (TyFun (TyVar i) (TyFun (TyVar i) b)))))) (Type t) return $ App (App (App lhv lhd) (Var i1)) (Var i2) | TyFun _ _ <- t = mkTrueE @@ -333,12 +363,14 @@ trueDC <- mkDCTrueM falseDC <- mkDCFalseM + tBool <- tyBoolT + pr <- mapM (uncurry (eqLHFuncCall ldm)) $ zip ba1 ba2 let pr' = foldr (\e -> App (App an e)) true pr b <- freshIdN =<< tyBoolT - let pr'' = Case pr' b [ Alt (DataAlt trueDC []) false - , Alt (DataAlt falseDC []) true ] + let pr'' = Case pr' b tBool [ Alt (DataAlt trueDC []) false + , Alt (DataAlt falseDC []) true ] return [ Alt Default false , Alt (DataAlt dc ba2) pr''] @@ -367,7 +399,7 @@ let bi = bound_ids adt lh <- lhTCM - lhbi <- mapM (freshIdN . TyApp (TyCon lh TYPE) . TyVar) bi + lhbi <- mapM (freshIdN . TyApp (TyCon lh (TyFun TYPE TYPE)) . TyVar) bi d1 <- freshIdN (TyCon n TYPE) d2 <- freshIdN (TyCon n TYPE) @@ -382,6 +414,7 @@ mkOrdCases :: Primitive -> KnownValues -> Id -> Id -> Name -> AlgDataTy -> LHStateM Expr mkOrdCases pr kv i1 i2 n (DataTyCon { data_cons = [dc]}) | n == KV.tyInt kv = mkPrimOrdCases pr TyLitInt i1 i2 dc + | n == KV.tyInteger kv = mkPrimOrdCases pr TyLitInt i1 i2 dc | n == KV.tyFloat kv = mkPrimOrdCases pr TyLitFloat i1 i2 dc | n == KV.tyDouble kv = mkPrimOrdCases pr TyLitDouble i1 i2 dc | otherwise = mkTrueE @@ -404,38 +437,46 @@ ) (Var b2) - let c2 = Case (Var i2) i2' [Alt (DataAlt dc [b2]) eq] + let c2 = Case (Var i2) i2' b [Alt (DataAlt dc [b2]) eq] - return $ Case (Var i1) i1' [Alt (DataAlt dc [b1]) c2] + return $ Case (Var i1) i1' b [Alt (DataAlt dc [b1]) c2] lhPPFunc :: Name -> AlgDataTy -> LHStateM Expr lhPPFunc n adt = do let bi = bound_ids adt lh <- lhTCM - lhbi <- mapM (freshIdN . TyApp (TyCon lh TYPE) . TyVar) bi + lhbi <- mapM (freshIdN . TyApp (TyCon lh (TyFun TYPE TYPE)) . TyVar) bi b <- tyBoolT fs <- mapM (\v -> freshIdN (TyFun (TyVar v) b)) bi - d <- freshIdN (TyCon n TYPE) + let k = foldr (const (TyApp TYPE)) TYPE bi + t = foldl' TyApp (TyCon n k) (map TyVar bi) + d <- freshIdN t -- (TyCon n TYPE) - let lhm = M.fromList $ zip (map idName bi) lhbi - let fnm = M.fromList $ zip (map idName bi) fs + let lhm = HM.fromList $ zip (map idName bi) lhbi + let fnm = HM.fromList $ zip (map idName bi) fs e <- lhPPCase lhm fnm adt d let e' = mkLams (map (TypeL,) bi ++ map (TermL,) lhbi ++ map (TermL,) fs ++ [(TermL, d)]) e return e' -type PPFuncMap = M.Map Name Id +type PPFuncMap = HM.HashMap Name Id lhPPCase :: LHDictMap -> PPFuncMap -> AlgDataTy -> Id -> LHStateM Expr -lhPPCase lhm fnm adt i = do +lhPPCase lhm fnm (DataTyCon { data_cons = dcs }) i = do ci <- freshIdN (typeOf i) + tBool <- tyBoolT - return . Case (Var i) ci =<< mapM (lhPPAlt lhm fnm) (dataCon adt) + return . Case (Var i) ci tBool =<< mapM (lhPPAlt lhm fnm) dcs +lhPPCase lhm fnm (NewTyCon { rep_type = rt }) i = do + pp <- lhPPCall lhm fnm rt + let c = Cast (Var i) (typeOf i :~ rt) + return $ App pp c + lhPPAlt :: LHDictMap -> PPFuncMap -> DataCon -> LHStateM Alt lhPPAlt lhm fnm dc = do ba <- freshIdsN $ anonArgumentTypes dc @@ -464,13 +505,21 @@ return . mkApp $ lhv:[Type t, dict] ++ undefs -- ++ [Var i] | TyVar (Id n _) <- t - , Just f <- M.lookup n fnm = return $ Var f -- App (Var f) (Var i) + , Just f <- HM.lookup n fnm = return $ Var f -- App (Var f) (Var i) | TyVar _ <- tyAppCenter t = do i <- freshIdN t return . Lam TermL i =<< mkTrueE | TyFun _ _ <- t = do - i <- freshIdN t - return . Lam TermL i =<< mkTrueE + let ts = anonArgumentTypes $ PresType t + rt = returnType $ PresType t + let_is <- freshIdsN ts + bind_i <- freshIdN t + let bind_app = mkApp $ Var bind_i:map Var let_is + pp <- lhPPCall lhm fnm rt + let pp_app = App pp bind_app + return . Lam TermL bind_i $ Let (zip let_is $ map (SymGen SNoLog) ts) pp_app + -- i <- freshIdN t + -- return . Lam TermL i =<< mkTrueE | TyForAll _ _ <- t = do i <- freshIdN t return . Lam TermL i =<< mkTrueE @@ -495,8 +544,10 @@ ne <- lhNeM pp <- lhPPM - createExtractors' lh [eq, ne, lt, le, gt, ge, pp] + ord <- lhOrdM + createExtractors' lh [eq, ne, lt, le, gt, ge, pp, ord] + createExtractors' :: Name -> [Name] -> LHStateM () createExtractors' lh ns = mapM_ (uncurry (createExtractors'' lh (length ns))) $ zip [0..] ns @@ -506,18 +557,19 @@ bi <- freshIdsN $ replicate i TyUnknown - li <- freshIdN (TyCon lh (TyApp TYPE TYPE)) - ci <- freshIdN (TyCon lh (TyApp TYPE TYPE)) + li <- freshIdN (TyCon lh (TyFun TYPE TYPE)) + ci <- freshIdN (TyCon lh (TyFun TYPE TYPE)) b <- freshIdN TYPE let d = DataCon lh (TyForAll - (NamedTyBndr b) + b (TyFun (TyVar b) - (TyApp (TyCon lh (TyApp TYPE TYPE)) (TyVar b)) + (TyApp (TyCon lh (TyFun TYPE TYPE)) (TyVar b)) ) ) - let c = Case (Var li) ci [Alt (DataAlt d bi) (Var $ bi !! j)] + let vi = bi !! j + c = Case (Var li) ci (typeOf vi) [Alt (DataAlt d bi) (Var vi)] let e = Lam TypeL a $ Lam TermL li c insertMeasureM n e diff --git a/src/G2/Liquid/TCValues.hs b/src/G2/Liquid/TCValues.hs --- a/src/G2/Liquid/TCValues.hs +++ b/src/G2/Liquid/TCValues.hs @@ -3,11 +3,15 @@ import G2.Language.Naming import G2.Language.Syntax +import Data.Monoid ((<>)) +import qualified Data.Sequence as S + -- | Stores variable names that are used in the LH encoding. -- There are two reasons a name might exist: -- (1) It corresponds to something that only makes sense in the context of LH -- (i.e. the LH typeclass) --- (2) It is a copy of a function that normally exists, but that copy has no assertion added. +-- (2) It is a copy of a function that normally exists, but that copy has no assertion added. +-- (3) We only care about the specific name in LH code (the Set data type) data TCValues = TCValues { lhTC :: Name , lhNumTC :: Name , lhOrdTC :: Name @@ -26,18 +30,33 @@ , lhDiv :: Name , lhNegate :: Name , lhMod :: Name + , lhFromInteger :: Name , lhToInteger :: Name + , lhFromRational :: Name + + , lhToRatioFunc :: Name + , lhNumOrd :: Name , lhAnd :: Name , lhOr :: Name + , lhNot :: Name - , lhPP :: Name } deriving (Eq, Show, Read) + , lhImplies :: Name + , lhIff :: Name + , lhPP :: Name + + , lhOrd :: Name + + , lhSet :: Maybe Name } deriving (Eq, Show, Read) + instance Named TCValues where - names tcv = [ lhTC tcv + names tcv = + S.fromList + [ lhTC tcv , lhNumTC tcv , lhOrdTC tcv , lhEq tcv @@ -55,14 +74,26 @@ , lhNegate tcv , lhMod tcv , lhFromInteger tcv + , lhToInteger tcv + + , lhFromRational tcv + + , lhToRatioFunc tcv + , lhNumOrd tcv , lhAnd tcv , lhOr tcv + , lhNot tcv - , lhPP tcv] + , lhImplies tcv + , lhIff tcv + , lhPP tcv + + , lhOrd tcv] <> maybe S.empty (S.singleton) (lhSet tcv) + rename old new tcv = TCValues { lhTC = rename old new $ lhTC tcv , lhNumTC = rename old new $ lhNumTC tcv , lhOrdTC = rename old new $ lhOrdTC tcv @@ -80,11 +111,25 @@ , lhDiv = rename old new $ lhDiv tcv , lhNegate = rename old new $ lhNegate tcv , lhMod = rename old new $ lhMod tcv + , lhFromInteger = rename old new $ lhFromInteger tcv , lhToInteger = rename old new $ lhToInteger tcv + + , lhFromRational = rename old new $ lhFromRational tcv + + , lhToRatioFunc = rename old new $ lhToRatioFunc tcv + , lhNumOrd = rename old new $ lhNumOrd tcv , lhAnd = rename old new $ lhAnd tcv , lhOr = rename old new $ lhOr tcv + , lhNot = rename old new $ lhNot tcv - , lhPP = rename old new $ lhPP tcv } + , lhImplies = rename old new $ lhImplies tcv + , lhIff = rename old new $ lhIff tcv + + , lhPP = rename old new $ lhPP tcv + + , lhOrd = rename old new $ lhOrd tcv + + , lhSet = rename old new $ lhSet tcv } diff --git a/src/G2/Liquid/TyVarBags.hs b/src/G2/Liquid/TyVarBags.hs new file mode 100644 --- /dev/null +++ b/src/G2/Liquid/TyVarBags.hs @@ -0,0 +1,426 @@ +-- This module creates IR functions to extract an arbitrary (non-deterministic) +-- value of type a_i from a type of the form T a_1 ... a_n. If there are no +-- values with type a_i, the function calls `Assume False`. + +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +module G2.Liquid.TyVarBags ( TyVarBags + , InstFuncs + , existentialInstRed + , createBagAndInstFuncs + + , extractTyVarCall + , wrapExtractCalls + , instTyVarCall + + , existentialInstId + , postSeqExistentialInstId + , putExistentialInstInExprEnv + , putSymbolicExistentialInstInExprEnv + , addTicksToDeepSeqCases) where + +import G2.Execution.Reducer +import G2.Language +import qualified G2.Language.ExprEnv as E +import G2.Language.Monad +import qualified G2.Language.Stack as Stck +import G2.Liquid.Types + +import Control.Monad +import qualified Data.HashSet as S +import qualified Data.HashMap.Lazy as HM +import qualified Data.Map.Lazy as M +import qualified Data.Text as T + +-- | The bag and instantiation functions rely on each other, so we have to make them together +createBagAndInstFuncs :: [Name] -- ^ Which types do we need bag functions for? + -> [Name] -- ^ Which types do we need instantiation functions for? + -> LHStateM () +createBagAndInstFuncs bag_func_ns inst_func_ns = do + tenv <- typeEnv + + let bag_func_ns' = relNames tenv S.empty bag_func_ns + bag_tenv = HM.filterWithKey (\n _ -> n `S.member` bag_func_ns') tenv + bag_names <- assignBagFuncNames bag_tenv + setTyVarBags bag_names + + let inst_func_ns' = relNames tenv S.empty inst_func_ns + inst_tenv = HM.filterWithKey (\n _ -> n `S.member` inst_func_ns') tenv + inst_names <- assignInstFuncNames inst_tenv + setInstFuncs inst_names + + createBagFuncs bag_names bag_tenv + createInstFuncs inst_names inst_tenv + +relNames :: TypeEnv -> S.HashSet Name -> [Name] -> S.HashSet Name +relNames _ rel [] = rel +relNames tenv rel (n:ns) = + if S.member n rel + then relNames tenv rel ns + else relNames tenv (S.insert n rel) ns' + where + ns' = case HM.lookup n tenv of + Nothing -> ns + Just r -> namesList r ++ ns + +createBagFuncs :: TyVarBags -- ^ Which types do we need bag functions for? + -> TypeEnv + -> LHStateM () +createBagFuncs func_names tenv = do + mapM_ (uncurry (createBagFunc func_names)) (HM.toList tenv) + +-- | Creates a mapping of type names to bag creation function names +assignBagFuncNames :: ExState s m => TypeEnv -> m TyVarBags +assignBagFuncNames tenv = + return . M.fromList + =<< mapM + (\(n@(Name n' m _ _), adt) -> do + let dc = head (dataCon adt) + bi = bound_ids adt + mkName i = Name (n' `T.append` "_create_bag_" `T.append` (T.pack . show $ i)) m 0 Nothing + + fn <- mapM + (\(i, tbi) -> do + n_fn <- freshSeededNameN (mkName i) + let t = foldr (\ntb -> TyForAll ntb) + (TyFun (returnType dc) (TyVar tbi)) bi + return $ Id n_fn t) + $ zip [0 :: Int ..] bi + return (n, fn) + ) (HM.toList tenv) + +createBagFunc :: TyVarBags -> Name -> AlgDataTy -> LHStateM () +createBagFunc func_names tn adt + | Just fs <- M.lookup tn func_names = + mapM_ (uncurry (createBagFunc' func_names tn adt)) $ zip fs (bound_ids adt) + | otherwise = error "createBagFunc: type not found" + +createBagFunc' :: TyVarBags + -> Name + -> AlgDataTy + -> Id -- ^ The Id of the function to create + -> Id -- ^ The Id of the TyVar to extract + -> LHStateM () +createBagFunc' func_names tn adt fn tyvar_id = do + bi <- freshIdsN $ map (const TYPE) (bound_ids adt) + adt_i <- freshIdN $ mkFullAppedTyCon tn (map TyVar bi) TYPE + + cse <- createBagFuncCase func_names adt_i tyvar_id bi adt + let e = mkLams (map (TypeL,) bi) $ Lam TermL adt_i cse + + insertE (idName fn) e + +-- | Examines the passed `Id` adt_i, which is the ADT to extract the tyvar tyvar_id from, +-- and constructs an expression to actually nondeterministically extract a tyvar_id. +createBagFuncCase :: TyVarBags + -> Id + -> Id + -> [Id] + -> AlgDataTy + -> LHStateM Expr +createBagFuncCase func_names adt_i tyvar_id bi (DataTyCon { bound_ids = adt_bi + , data_cons = dc }) = do + bindee <- freshIdN (typeOf adt_i) + let ty_map = zip adt_bi (map TyVar bi) + alts <- mapM (createBagFuncCaseAlt func_names tyvar_id ty_map) dc + + return $ Case (Var adt_i) bindee (typeOf $ head alts) alts +createBagFuncCase func_names adt_i tyvar_id bi (NewTyCon { bound_ids = adt_bi + , rep_type = rt }) = do + let rt' = foldr (uncurry retype) rt $ zip adt_bi (map TyVar bi) + cst = Cast (Var adt_i) (typeOf adt_i :~ rt') + clls <- extractTyVarCall func_names todo_emp tyvar_id cst + wrapExtractCalls clls +createBagFuncCase _ _ _ _ (TypeSynonym {}) = + error "creatBagFuncCase: TypeSynonyms unsupported" + +createBagFuncCaseAlt :: TyVarBags -> Id -> [(Id, Type)] -> DataCon -> LHStateM Alt +createBagFuncCaseAlt func_names tyvar_id ty_map dc = do + let at = anonArgumentTypes dc + is <- freshIdsN at + let is' = foldr (uncurry retype) is ty_map + tyvar_id' = maybe tyvar_id id $ tyVarId =<< lookup tyvar_id ty_map + es <- return . concat =<< mapM (extractTyVarCall func_names todo_emp tyvar_id' . Var) is' + case null es of + True -> do + flse <- mkFalseE + return $ Alt (DataAlt dc is') + (Assume Nothing flse (Prim Undefined (TyVar tyvar_id))) + False -> return $ Alt (DataAlt dc is') (NonDet es) + where + tyVarId (TyVar i) = Just i + tyVarId _ = Nothing + +todo_emp :: [a] +todo_emp = [] + +-- | Creates a set of expressions to get all TyVars i out of an +-- expression e. +extractTyVarCall :: TyVarBags + -> [(Id, Id)] -- ^ Mapping of TyVar Ids to Functions to create those TyVars + -> Id + -> Expr + -> LHStateM [Expr] +extractTyVarCall func_names is_fs i e + | TyVar i' <- t + , i == i' = return [e] + | TyCon n tc_t:ts <- unTyApp t + , Just fn <- M.lookup n func_names = do + let is = anonArgumentTypes (PresType tc_t) + ty_ars = map Type $ take (length is) ts + nds = map (\f -> App (mkApp (Var f:ty_ars)) e) fn + nds' <- mapM (extractTyVarCall func_names is_fs i) nds + return (concat nds') + | TyFun _ _ <- t = do + let ars_ty = anonArgumentTypes $ PresType t + tvs = tyVarIds . returnType $ PresType t + + inst_fs <- getInstFuncs + inst_ars <- mapM (instTyVarCall' inst_fs is_fs) ars_ty + let call_f = mkApp $ e:inst_ars + + cll <- if i `elem` tvs then extractTyVarCall func_names is_fs i call_f else return [] + return cll + | otherwise = return [] + where + t = typeOf e + +wrapExtractCalls :: ExState s m => [Expr] -> m Expr +wrapExtractCalls clls = do + case null clls of + True -> do + -- flse <- mkFalseE + return (Var existentialInstId) + False -> return $ NonDet clls + +-- | Creates functions to, for each type (T a_1 ... a_n), create a nondeterministic value. +-- Each a_1 ... a_n has an associated function, allowing the caller to decide how to instantiate +-- these values. +createInstFuncs :: InstFuncs -- ^ Which types do we need instantiation functions for? + -> TypeEnv + -> LHStateM () +createInstFuncs func_names tenv = do + mapM_ (uncurry (createInstFunc func_names)) (HM.toList tenv) + +-- | Creates a mapping of type names to instantatiation function names +assignInstFuncNames :: ExState s m => TypeEnv -> m InstFuncs +assignInstFuncNames tenv = + return . M.fromList + =<< mapM + (\(tn@(Name n m _ _), adt) -> do + let bi = bound_ids adt + fn <- freshSeededNameN (Name (n `T.append` "_inst_") m 0 Nothing) + + let adt_i = mkFullAppedTyCon tn (map TyVar bi) TYPE + let t = foldr (\ntb -> TyForAll ntb) + (foldr (\i -> TyFun (TyVar i)) adt_i bi) bi + + return (tn, Id fn t) + ) (HM.toList tenv) + +createInstFunc :: InstFuncs -> Name -> AlgDataTy -> LHStateM () +createInstFunc func_names tn adt + | Just fn <- M.lookup tn func_names = do + bi <- freshIdsN $ map (const TYPE) (bound_ids adt) + inst_fs <- freshIdsN $ map TyVar bi + + cse <- createInstFunc' func_names (zip bi inst_fs) adt + let e = mkLams (map (TypeL,) bi) $ mkLams (map (TermL,) inst_fs) cse + + insertE (idName fn) e + | otherwise = error "createInstFunc: type not found" + +createInstFunc' :: InstFuncs -> [(Id, Id)] -> AlgDataTy -> LHStateM Expr +createInstFunc' func_names is_fs (DataTyCon { data_cons = dcs }) = do + dc' <- mapM (\dc -> do + let apped_dc = mkApp (Data dc:map (Type . TyVar . fst) is_fs) + ars_ty = anonArgumentTypes dc + + is_fs' = zipWith (\i (_, f) -> (i, f)) (leadingTyForAllBindings dc) is_fs + + ars <- mapM (instTyVarCall' func_names is_fs') ars_ty + bnds <- mapM freshIdN ars_ty + let vrs = map Var bnds + + let e = mkApp $ apped_dc:vrs + e' <- foldM wrapPrimsInCase e vrs + return $ Let (zip bnds ars) e') dcs + return (NonDet dc') +createInstFunc' _ _ (NewTyCon { rep_type = _ }) = do + -- rt_val <- instTyVarCall' func_names is_fs rt + return $ Cast undefined undefined +createInstFunc' _ _ _ = error "createInstFunc': unhandled datatype" + +-- | Creates an instTyVarCall function call to create an expression of type t with appropriate TyVars +instTyVarCall :: ExState s m => + InstFuncs + -> [(Id, Id)] -- ^ Mapping of TyVar Ids to Functions to create those TyVars + -> Type + -> m Expr +instTyVarCall func_names is_fs t = do + tUnit <- tyUnitT + ui <- freshIdN tUnit + cll <- instTyVarCall' func_names is_fs t + return $ Lam TermL ui cll + +instTyVarCall' :: ExState s m => + InstFuncs + -> [(Id, Id)] -- ^ Mapping of TyVar Ids to Functions to create those TyVars + -> Type + -> m Expr +instTyVarCall' func_names is_fs t + | TyVar i <- t + , Just f <- lookup i is_fs = do + return $ Var f + | TyVar i <- t = do + flse <- mkFalseE + return . Assume Nothing flse . Prim Undefined $ TyVar i + + | TyCon n tc_t:ts <- unTyApp t + , Just fn <- M.lookup n func_names = do + let tyc_is = anonArgumentTypes (PresType tc_t) + ty_ts = take (length tyc_is) ts + + ty_ars = map Type ty_ts + func_ars <- mapM (\t' -> case t' of + TyVar i + | Just i' <- lookup i is_fs -> return (Var i') + _ -> do + cll <- instTyVarCall' func_names is_fs t' + return cll) ty_ts + let_ids <- freshIdsN $ map typeOf func_ars + let bnds = zip let_ids func_ars + + return . Let bnds . mkApp $ Var fn:ty_ars ++ map Var let_ids + | otherwise = do + let tfa = leadingTyForAllBindings $ PresType t + tfa_is = zipWith (\i1 (i2, _) -> (i1, TyVar i2)) tfa is_fs + + rt = foldr (uncurry retype) (returnType $ PresType t) tfa_is + return $ SymGen SNoLog rt + +-- | Primitive operation function calls do not force evaluation of the +-- underlying primitive value- the assumption is that this is already a literal +-- or a symbolic value. Thus, if we have a SymGen being passed to a primitive +-- operation, our rules will not know how to handle it. +-- Thus, we wrap SymGen's of primitive types in case statements. +wrapPrimsInCase :: ExState s m => Expr -> Expr -> m Expr +wrapPrimsInCase e e' + | isPrimType t = do + i <- freshIdN t + return $ Case e' i (typeOf e) [Alt Default e] + | otherwise = return e + where + t = typeOf e' + +---------------------------------------- +-- Existential Inst + +-- Suppose a function returns a value with a polymorphic type, without taking +-- any of those types as arguments. This is common with functions that return +-- the "empty" case of data structures, such as Data.Map.empty. +-- In this case, we instantiate with an "existential" value, +-- that basically says some value may exist, but we do not know specifically what it is + +existentialInstId :: Id +existentialInstId = Id (Name "EXISTENTIAL_INST_NAME" Nothing 0 Nothing) TyUnknown + +postSeqExistentialInstId :: Id +postSeqExistentialInstId = Id (Name "POST_SEQ_EXISTENTIAL_INST_NAME" Nothing 0 Nothing) TyUnknown + + +-- | Place this in a Tick in the first Alt of a Case, to treat the case normally, +-- even if the existential Id is in the bindee +existentialCaseName :: Name +existentialCaseName = Name "EXISTENTIAL_CASE_NAME" Nothing 0 Nothing + +putExistentialInstInExprEnv :: State t -> State t +putExistentialInstInExprEnv s@(State { expr_env = eenv }) = + s { expr_env = E.insert + (idName existentialInstId) + (Var existentialInstId) + eenv } + +putSymbolicExistentialInstInExprEnv :: State t -> State t +putSymbolicExistentialInstInExprEnv s@(State { expr_env = eenv }) = + s { expr_env = E.insertSymbolic + existentialInstId + eenv + } + +{-# INLINE existentialInstRed #-} +existentialInstRed :: Monad m => Reducer m () t +existentialInstRed = mkSimpleReducer (const ()) existInstRedRules + +existInstRedRules :: Monad m => RedRules m () t +existInstRedRules rv s@(State { expr_env = eenv + , curr_expr = CurrExpr Evaluate e }) + b@(Bindings { name_gen = ng }) + | Var i <- e + , i == existentialInstId = + let + s' = s { expr_env = E.insertSymbolic i eenv + , curr_expr = CurrExpr Return e } + in + return (InProgress, [(s', rv)], b) + | Case (Var i) bnd _ ([Alt (DataAlt _ params) (Tick (NamedLoc n) ae)]) <- e + , i == existentialInstId + , n == existentialCaseName = + let + (n_bnd, ng') = freshSeededName (idName bnd) ng + (n_params, ng'') = freshSeededNames (map idName params) ng' + + eenv' = E.insertSymbolic postSeqExistentialInstId eenv + eenv'' = foldr (\en -> E.insert en (Var existentialInstId)) eenv' n_params + n_e = rename (idName bnd) n_bnd $ foldr (uncurry rename) ae (zip (map idName params) n_params) + in + return ( InProgress + , [(s { expr_env = eenv'' + , curr_expr = CurrExpr Evaluate n_e }, rv)] + , b { name_gen = ng'' }) + | Case (Var i) _ _ ([Alt _ (Tick (NamedLoc n) ae)]) <- e + , i == existentialInstId + , n == existentialCaseName = + let + eenv' = E.insertSymbolic postSeqExistentialInstId eenv + in + return ( InProgress + , [(s { expr_env = eenv' + , curr_expr = CurrExpr Evaluate ae }, rv)] + , b) + | Case (Var i) _ _ _ <- e + , i == existentialInstId = + let + s' = s { curr_expr = CurrExpr Return (Var i) } + in + return (InProgress, [(s', rv)], b) +existInstRedRules rv s@(State { curr_expr = CurrExpr Return e + , exec_stack = stck }) b + + | Just (AssumeFrame _, stck') <- Stck.pop stck + , Var i <- e + , i == existentialInstId = + return (InProgress, [(s { exec_stack = stck' }, rv)], b) + | Just (AssertFrame _ _, stck') <- Stck.pop stck + , Var i <- e + , i == existentialInstId = + return (InProgress, [(s { exec_stack = stck' }, rv)], b) +existInstRedRules rv s b = return (NoProgress, [(s, rv)], b) + +addTicksToDeepSeqCases :: Walkers -> State t -> State t +addTicksToDeepSeqCases w s@(State { expr_env = eenv }) = + s { expr_env = foldr addTicksToDeepSeqCases' eenv (map idName $ M.elems w)} + +addTicksToDeepSeqCases' :: Name -> ExprEnv -> ExprEnv +addTicksToDeepSeqCases' n eenv = + case E.lookup n eenv of + Just e -> E.insert n (modify addTicksToDeepSeqCases'' e) eenv + Nothing -> eenv + +addTicksToDeepSeqCases'' :: Expr -> Expr +addTicksToDeepSeqCases'' (Case e i t (Alt am ae:as)) = + Case e i t $ Alt am (Tick (NamedLoc existentialCaseName) ae):as +addTicksToDeepSeqCases'' e = e diff --git a/src/G2/Liquid/Types.hs b/src/G2/Liquid/Types.hs --- a/src/G2/Liquid/Types.hs +++ b/src/G2/Liquid/Types.hs @@ -1,63 +1,113 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PatternSynonyms #-} module G2.Liquid.Types ( LHOutput (..) - , Measures - , LHState (..) - , LHStateM (..) - , ExState (..) - , AnnotMap (..) - , consLHState - , deconsLHState - , measuresM - , assumptionsM - , annotsM - , runLHStateM - , evalLHStateM - , execLHStateM - , lookupMeasure - , lookupMeasureM - , insertMeasureM - , mapMeasuresM - , lookupAssumptionM - , insertAssumptionM - , mapAssumptionsM - , lookupAnnotM - , insertAnnotM - , mapAnnotsExpr - , andM - , orM - , notM - , iffM - , lhTCM - , lhOrdTCM - , lhEqM - , lhNeM - , lhLtM - , lhLeM - , lhGtM - , lhGeM - , lhLtE - , lhLeE - , lhGtE - , lhGeE + , CounterExample (..) + , HigherOrderFuncCall + , Measures + , LHState (..) + , LHStateM (..) + , NamingM (..) + , ExState (..) + , AnnotMap (..) + , Abstracted (..) + , AbstractedInfo (..) + , Assumptions + , Posts + , TyVarBags + , InstFuncs - , lhPlusM - , lhMinusM - , lhTimesM - , lhDivM - , lhNegateM - , lhModM - , lhFromIntegerM - , lhToIntegerM - , lhNumOrdM + -- For compatibility with new LH versions +#if MIN_VERSION_liquidhaskell(0,8,10) + , GhcInfo, GhcSrc, GhcSpec + , pattern GI, giSpec, giSrc + , pattern SP, gsSig, gsData, gsQual, gsVars, gsTerm + , pattern Src, giTarget, giCbs, giDefVars +#endif - , lhAndE - , lhOrE - - , lhPPM ) where + , tcValuesM + , mapAbstractedFCs + , mapAbstractedInfoFCs + , consLHState + , deconsLHState + , measuresM + , lhKnownValuesM + , lhRenamedTCM + , assumptionsM + , postsM + , annotsM + , tyVarBagsM + , runLHStateM + , evalLHStateM + , execLHStateM + , lookupMeasure + , lookupMeasureM + , insertMeasureM + , mapMeasuresM + , mapMeasuresWithKeyM + , putMeasuresM + , lookupAssumptionM + , insertAssumptionM + , mapAssumptionsM + , lookupPostM + , insertPostM + , mapPostM + , lookupAnnotM + , insertAnnotM + , mapAnnotsExpr + , lookupRenamedTCDict + , insertTyVarBags + , lookupTyVarBags + , setTyVarBags + , getTyVarBags + , insertInstFuncs + , lookupInstFuncs + , setInstFuncs + , getInstFuncs + + , andM + , orM + , notM + , iffM + , lhTCM + , lhOrdTCM + , lhEqM + , lhNeM + , lhLtM + , lhLeM + , lhGtM + , lhGeM + , lhLtE + , lhLeE + , lhGtE + , lhGeE + + , lhPlusM + , lhMinusM + , lhTimesM + , lhDivM + , lhNegateM + , lhModM + , lhFromIntegerM + , lhToIntegerM + + , lhFromRationalM + + , lhToRatioFuncM + + , lhNumTCM + , lhNumOrdM + + , lhAndE + , lhOrE + + , lhPPM + , lhOrdM ) where + import Data.Coerce import qualified Data.HashMap.Lazy as HM import Data.List @@ -69,25 +119,180 @@ import qualified G2.Language.ExprEnv as E import qualified G2.Language.KnownValues as KV import G2.Language.Monad +import G2.Language.TypeClasses import G2.Liquid.TCValues -import Language.Haskell.Liquid.Types +#if MIN_VERSION_liquidhaskell(0,8,10) +import qualified Language.Haskell.Liquid.Types as LT (TargetInfo (..), TargetSrc (..), TargetSpec (..)) +#else +import Language.Haskell.Liquid.Types (GhcInfo) +#endif + import Language.Haskell.Liquid.Constraint.Types import Language.Fixpoint.Types.Constraints +import Data.Monoid ((<>)) + +-- LiquidHaskell renamed these types. +-- This preserves compatibility with the old version of LiquidHaskell, and the new versions of LiquidHaskell. +#if MIN_VERSION_liquidhaskell(0,8,10) +type GhcInfo = LT.TargetInfo +type GhcSrc = LT.TargetSrc +type GhcSpec= LT.TargetSpec + +pattern GI{giSrc,giSpec} = LT.TargetInfo giSrc giSpec + + +pattern Src + { giIncDir + , giTarget + , giTargetMod + , giCbs + , gsTcs + , gsCls + , giDerVars + , giImpVars + , giDefVars + , giUseVars + , gsExports + , gsFiTcs + , gsFiDcs + , gsPrimTcs + , gsQualImps + , gsAllImps + , gsTyThings + } = LT.TargetSrc giIncDir giTarget giTargetMod giCbs gsTcs gsCls giDerVars giImpVars + giDefVars giUseVars gsExports gsFiTcs gsFiDcs gsPrimTcs gsQualImps + gsAllImps gsTyThings + + + + +pattern SP + { gsSig + , gsQual + , gsData + , gsName + , gsVars + , gsTerm + , gsRefl + , gsLaws + , gsImps + , gsConfig + } = LT.TargetSpec gsSig gsQual gsData gsName gsVars gsTerm gsRefl gsLaws gsImps gsConfig + +#endif + data LHOutput = LHOutput { ghcI :: GhcInfo , cgI :: CGInfo , solution :: FixSolution } +type HigherOrderFuncCall = L.FuncCall + +data CounterExample = DirectCounter Abstracted + [Abstracted] + [HigherOrderFuncCall] -- ^ Symbolic higher order functions evaluated while creating the counterexample + | CallsCounter Abstracted -- ^ The caller, abstracted result + Abstracted -- ^ The callee + [Abstracted] + [HigherOrderFuncCall] -- ^ Symbolic higher order functions evaluated while creating the counterexample + deriving (Eq, Show, Read) + type Measures = L.ExprEnv -type Assumptions = M.Map L.Name L.Expr +-- | Assumptions include: +-- (1) a list of `(LamUse, Id)` used to refer to the expression arguments in the assumption +-- (2) assumptions to wrap individual arguments (in particular, higher order arguments). +-- (3) an assumption regarding the whole expression, +type Assumptions = M.Map L.Name ([(L.LamUse, L.Id)], [Maybe L.Expr], L.Expr) +type Posts = M.Map L.Name L.Expr newtype AnnotMap = AM { unAnnotMap :: HM.HashMap L.Span [(Maybe T.Text, L.Expr)] } deriving (Eq, Show, Read) +-- Abstracted values +data Abstracted = Abstracted { abstract :: L.FuncCall + , real :: L.FuncCall + , hits_lib_err_in_real :: Bool + , func_calls_in_real :: [L.FuncCall] } + deriving (Eq, Show, Read) + +data AbstractedInfo = AbstractedInfo { init_call :: Abstracted + , abs_violated :: Maybe Abstracted + , abs_calls :: [Abstracted] + , ai_all_calls :: [L.FuncCall] + + , ai_higher_order_calls :: [L.FuncCall] } + deriving (Eq, Show, Read) + +mapAbstractedFCs :: (L.FuncCall -> L.FuncCall) -> Abstracted -> Abstracted +mapAbstractedFCs f (Abstracted { abstract = a + , real = r + , hits_lib_err_in_real = err + , func_calls_in_real = fcr }) = + Abstracted { abstract = f a + , real = f r + , hits_lib_err_in_real = err + , func_calls_in_real = map f fcr} + +mapAbstractedInfoFCs :: (L.FuncCall -> L.FuncCall) -> AbstractedInfo -> AbstractedInfo +mapAbstractedInfoFCs f (AbstractedInfo { init_call = ic, abs_violated = av, abs_calls = ac, ai_all_calls= allc, ai_higher_order_calls = a_higher}) = + AbstractedInfo { init_call = mapAbstractedFCs f ic + , abs_violated = fmap (mapAbstractedFCs f) av + , abs_calls = map (mapAbstractedFCs f) ac + , ai_all_calls = map f allc + , ai_higher_order_calls = map f a_higher } + +instance L.ASTContainer Abstracted L.Expr where + containedASTs ab = L.containedASTs (abstract ab) ++ L.containedASTs (real ab) + modifyContainedASTs f (Abstracted { abstract = a + , real = r + , hits_lib_err_in_real = err + , func_calls_in_real = fcir }) = + Abstracted { abstract = L.modifyContainedASTs f a + , real = L.modifyContainedASTs f r + , hits_lib_err_in_real = err + , func_calls_in_real = L.modifyContainedASTs f fcir} + +instance L.ASTContainer Abstracted L.Type where + containedASTs ab = L.containedASTs (abstract ab) ++ L.containedASTs (real ab) + modifyContainedASTs f (Abstracted { abstract = a + , real = r + , hits_lib_err_in_real = err + , func_calls_in_real = fcir }) = + Abstracted { abstract = L.modifyContainedASTs f a + , real = L.modifyContainedASTs f r + , hits_lib_err_in_real = err + , func_calls_in_real = L.modifyContainedASTs f fcir } + +instance L.Named Abstracted where + names a = L.names (abstract a) <> L.names (real a) <> L.names (func_calls_in_real a) + rename old new a = a { abstract = L.rename old new (abstract a) + , real = L.rename old new (real a) + , func_calls_in_real = L.rename old new (func_calls_in_real a) } + renames hm a = a { abstract = L.renames hm (abstract a) + , real = L.renames hm (real a) + , func_calls_in_real = L.renames hm (func_calls_in_real a) } + +instance L.Named AbstractedInfo where + names a = L.names (init_call a) <> L.names (abs_violated a) <> L.names (abs_calls a) <> L.names (ai_all_calls a) <> L.names (ai_higher_order_calls a) + rename old new a = AbstractedInfo { init_call = L.rename old new (init_call a) + , abs_violated = L.rename old new (abs_violated a) + , abs_calls = L.rename old new (abs_calls a) + , ai_all_calls = L.rename old new (ai_all_calls a) + , ai_higher_order_calls = L.rename old new (ai_higher_order_calls a) } + renames hm a = AbstractedInfo { init_call = L.renames hm (init_call a) + , abs_violated = L.renames hm (abs_violated a) + , abs_calls = L.renames hm (abs_calls a) + , ai_all_calls = L.renames hm (ai_all_calls a) + , ai_higher_order_calls = L.renames hm (ai_higher_order_calls a) } + +-- | See G2.Liquid.TyVarBags +type TyVarBags = M.Map L.Name [L.Id] +type InstFuncs = M.Map L.Name L.Id + -- [LHState] -- measures is an extra expression environment, used to build Assertions. -- This distinction between functions for code, and functions for asserts is important because @@ -105,18 +310,28 @@ -- LiquidHaskell ASTs data LHState = LHState { state :: L.State [L.FuncCall] , measures :: Measures + , lh_known_values :: KV.KnownValues + , lh_tcs :: L.TypeClasses , tcvalues :: TCValues , assumptions :: Assumptions + , posts :: Posts , annots :: AnnotMap + , tyvar_bags :: TyVarBags + , inst_funcs :: InstFuncs } deriving (Eq, Show, Read) -consLHState :: L.State [L.FuncCall] -> Measures -> TCValues -> LHState -consLHState s meas tcv = +consLHState :: L.State [L.FuncCall] -> Measures -> KV.KnownValues -> L.TypeClasses -> TCValues -> LHState +consLHState s meas kv tc tcv = LHState { state = s , measures = meas + , lh_known_values = kv + , lh_tcs = tc , tcvalues = tcv , assumptions = M.empty - , annots = AM HM.empty } + , posts = M.empty + , annots = AM HM.empty + , tyvar_bags = M.empty + , inst_funcs = M.empty } deconsLHState :: LHState -> L.State [L.FuncCall] deconsLHState (LHState { state = s @@ -128,31 +343,54 @@ (lh_s, _) <- SM.get return $ measures lh_s +lhKnownValuesM :: LHStateM KV.KnownValues +lhKnownValuesM = do + (lh_s, _) <- SM.get + return $ lh_known_values lh_s + +lhRenamedTCM :: LHStateM L.TypeClasses +lhRenamedTCM = do + (lh_s, _) <- SM.get + return $ lh_tcs lh_s + assumptionsM :: LHStateM Assumptions assumptionsM = do (lh_s, _) <- SM.get return $ assumptions lh_s +postsM :: LHStateM Posts +postsM = do + (lh_s, _) <- SM.get + return $ posts lh_s + annotsM :: LHStateM AnnotMap annotsM = do (lh_s, _) <- SM.get return $ annots lh_s +tyVarBagsM :: LHStateM TyVarBags +tyVarBagsM = do + (lh_s, _) <- SM.get + return $ tyvar_bags lh_s + + newtype LHStateM a = LHStateM { unSM :: (SM.State (LHState, L.Bindings) a) } deriving (Applicative, Functor, Monad) instance SM.MonadState (LHState, L.Bindings) LHStateM where state f = LHStateM (SM.state f) -instance ExState (LHState, L.Bindings) LHStateM where +instance NamingM (LHState, L.Bindings) LHStateM where + nameGen = readRecord $ L.name_gen . snd + putNameGen = rep_name_genM + +instance ExprEnvM (LHState, L.Bindings) LHStateM where exprEnv = readRecord $ expr_env . fst putExprEnv = rep_expr_envM +instance ExState (LHState, L.Bindings) LHStateM where typeEnv = readRecord $ type_env . fst putTypeEnv = rep_type_envM - nameGen = readRecord $ L.name_gen . snd - putNameGen = rep_name_genM - knownValues = readRecord $ known_values . fst putKnownValues = rep_known_valuesM @@ -166,6 +404,9 @@ inputNames = readRecord $ L.input_names . snd fixedInputs = readRecord $ L.fixed_inputs . snd + pathConds = readRecord $ path_conds . fst + putPathConds = rep_path_condsM + runLHStateM :: LHStateM a -> LHState -> L.Bindings -> (a, (LHState, L.Bindings)) runLHStateM (LHStateM s) lh_s b = SM.runState s (lh_s, b) @@ -235,6 +476,16 @@ let s' = s {L.type_classes = tc} SM.put $ (lh_s {state = s'}, b) +path_conds :: LHState -> L.PathConds +path_conds = liftState L.path_conds + +rep_path_condsM :: L.PathConds -> LHStateM () +rep_path_condsM ce = do + (lh_s, b) <- SM.get + let s = state lh_s + let s' = s {L.path_conds = ce} + SM.put $ (lh_s {state = s'}, b) + liftLHState :: (LHState -> a) -> LHStateM a liftLHState f = do (lh_s, _) <- SM.get @@ -259,10 +510,21 @@ meas' <- E.mapM f meas SM.put $ (s { measures = meas' }, b) -lookupAssumptionM :: L.Name -> LHStateM (Maybe L.Expr) +mapMeasuresWithKeyM :: (L.Name -> L.Expr -> LHStateM L.Expr) -> LHStateM () +mapMeasuresWithKeyM f = do + (s@(LHState { measures = meas }), b) <- SM.get + meas' <- E.mapWithKeyM f meas + SM.put $ (s { measures = meas' }, b) + +putMeasuresM :: Measures -> LHStateM () +putMeasuresM meas = do + (s, b) <- SM.get + SM.put $ (s { measures = meas }, b) + +lookupAssumptionM :: L.Name -> LHStateM (Maybe ([(L.LamUse, L.Id)], [Maybe L.Expr], L.Expr)) lookupAssumptionM n = liftLHState (M.lookup n . assumptions) -insertAssumptionM :: L.Name -> L.Expr -> LHStateM () +insertAssumptionM :: L.Name -> ([(L.LamUse, L.Id)], [Maybe L.Expr], L.Expr) -> LHStateM () insertAssumptionM n e = do (lh_s, b) <- SM.get let assumpt = assumptions lh_s @@ -272,9 +534,25 @@ mapAssumptionsM :: (L.Expr -> LHStateM L.Expr) -> LHStateM () mapAssumptionsM f = do (s@(LHState { assumptions = assumpt }), b) <- SM.get - assumpt' <- mapM f assumpt + assumpt' <- mapM (modifyContainedASTsM f) assumpt SM.put $ (s { assumptions = assumpt' },b) +lookupPostM :: L.Name -> LHStateM (Maybe L.Expr) +lookupPostM n = liftLHState (M.lookup n . posts) + +insertPostM :: L.Name -> L.Expr -> LHStateM () +insertPostM n e = do + (lh_s, b) <- SM.get + let pst = posts lh_s + let pst' = M.insert n e pst + SM.put $ (lh_s {posts = pst'}, b) + +mapPostM :: (L.Expr -> LHStateM L.Expr) -> LHStateM () +mapPostM f = do + (s@(LHState { posts = pst }), b) <- SM.get + pst' <- mapM f pst + SM.put $ (s { posts = pst' },b) + insertAnnotM :: L.Span -> Maybe T.Text -> L.Expr -> LHStateM () insertAnnotM spn t e = do (s@(LHState { annots = an }),b) <- SM.get @@ -297,34 +575,84 @@ annots' <- modifyContainedASTsM f (annots lh_s) SM.put $ (lh_s {annots = annots'}, b) +lookupRenamedTCDict :: L.Name -> L.Type -> LHStateM (Maybe L.Id) +lookupRenamedTCDict n t = do + tc <- lhRenamedTCM + return $ lookupTCDict tc n t + +insertTyVarBags :: L.Name -> [L.Id] -> LHStateM () +insertTyVarBags n is = do + (lh_s, b) <- SM.get + let tyvar_bags' = M.insert n is (tyvar_bags lh_s) + SM.put $ (lh_s {tyvar_bags = tyvar_bags'}, b) + +lookupTyVarBags :: L.Name -> LHStateM (Maybe [L.Id]) +lookupTyVarBags n = do + (lh_s, _) <- SM.get + return $ M.lookup n (tyvar_bags lh_s) + +setTyVarBags :: TyVarBags -> LHStateM () +setTyVarBags m = do + (lh_s, b) <- SM.get + SM.put (lh_s {tyvar_bags = m}, b) + +getTyVarBags :: LHStateM TyVarBags +getTyVarBags = return . tyvar_bags . fst =<< SM.get + +insertInstFuncs :: L.Name -> L.Id -> LHStateM () +insertInstFuncs n i = do + (lh_s, b) <- SM.get + let inst_funcs' = M.insert n i (inst_funcs lh_s) + SM.put $ (lh_s {inst_funcs = inst_funcs'}, b) + +lookupInstFuncs :: L.Name -> LHStateM (Maybe L.Id) +lookupInstFuncs n = do + (lh_s, _) <- SM.get + return $ M.lookup n (inst_funcs lh_s) + +setInstFuncs :: M.Map L.Name L.Id -> LHStateM () +setInstFuncs m = do + (lh_s, b) <- SM.get + SM.put (lh_s {inst_funcs = m}, b) + +getInstFuncs :: LHStateM InstFuncs +getInstFuncs = return . inst_funcs . fst =<< SM.get + -- | andM -- The version of 'and' in the measures andM :: LHStateM L.Expr andM = do m <- measuresM - return (L.mkAnd m) + n <- lhAndM + return (m E.! n) -- | orM -- The version of 'or' in the measures orM :: LHStateM L.Expr orM = do m <- measuresM - return (L.mkOr m) + n <- lhOrM + return (m E.! n) -- | notM -- The version of 'not' in the measures notM :: LHStateM L.Expr notM = do m <- measuresM - return (L.mkNot m) + n <- lhNotM + return (m E.! n) -- | iffM -- The version of 'iff' in the measures iffM :: LHStateM L.Expr iffM = do m <- measuresM - return (L.mkIff m) + n <- lhIffM + return (m E.! n) +tcValuesM :: LHStateM TCValues +tcValuesM = liftTCValues id + liftTCValues :: (TCValues -> a) -> LHStateM a liftTCValues f = do (lh_s, _) <- SM.get @@ -357,20 +685,28 @@ lhGeM :: LHStateM L.Name lhGeM = liftTCValues lhGe +lhAndM :: LHStateM L.Name +lhAndM = liftTCValues lhAnd + +lhOrM :: LHStateM L.Name +lhOrM = liftTCValues lhOr + +lhNotM :: LHStateM L.Name +lhNotM = liftTCValues lhNot + +lhIffM :: LHStateM L.Name +lhIffM = liftTCValues lhIff + binT :: LHStateM L.Type binT = do a <- freshIdN L.TYPE let tva = L.TyVar a - ord <- lhOrdTCM lh <- lhTCM bool <- tyBoolT - let ord' = L.TyCon ord L.TYPE - let lh' = L.TyCon lh L.TYPE + let lh' = L.TyCon lh (L.TyFun L.TYPE L.TYPE) - return $ L.TyForAll (L.NamedTyBndr a) - (L.TyFun - ord' + return $ L.TyForAll a (L.TyFun lh' (L.TyFun @@ -381,7 +717,6 @@ ) ) ) - ) lhLtE :: LHStateM L.Id lhLtE = do @@ -435,7 +770,7 @@ let num' = L.TyCon num L.TYPE - return $ L.TyForAll (L.NamedTyBndr a) + return $ L.TyForAll a (L.TyFun num' (L.TyFun @@ -444,6 +779,30 @@ ) ) +lhToRatioFuncM :: LHStateM L.Id +lhToRatioFuncM = do + n <- liftTCValues lhToRatioFunc + return . L.Id n =<< ratioFuncT + +ratioFuncT :: LHStateM L.Type +ratioFuncT = do + a <- freshIdN L.TYPE + let tva = L.TyVar a + integral <- return . KV.integralTC =<< knownValues + + let integral' = L.TyCon integral L.TYPE + + return $ L.TyForAll a + (L.TyFun + integral' + (L.TyFun + tva + (L.TyFun + tva + L.TyUnknown) + ) + ) + lhToIntegerM :: LHStateM L.Id lhToIntegerM = do n <- liftTCValues lhToInteger @@ -458,7 +817,7 @@ let integral' = L.TyCon integral L.TYPE - return $ L.TyForAll (L.NamedTyBndr a) + return $ L.TyForAll a (L.TyFun integral' (L.TyFun @@ -466,6 +825,31 @@ integerT ) ) + + +lhFromRationalM :: LHStateM L.Id +lhFromRationalM = do + n <- liftTCValues lhFromRational + return . L.Id n =<< fractionalT + +fractionalT :: LHStateM L.Type +fractionalT = do + a <- freshIdN L.TYPE + let tva = L.TyVar a + fractional <- return . KV.fractionalTC =<< knownValues + rationalT <- tyRationalT + + let fractional' = L.TyCon fractional L.TYPE + + return $ L.TyForAll a + (L.TyFun + fractional' + (L.TyFun + rationalT + tva + ) + ) + lhNumOrdM :: LHStateM L.Id lhNumOrdM = do num <- lhNumTCM @@ -479,6 +863,9 @@ lhPPM :: LHStateM L.Name lhPPM = liftTCValues lhPP + +lhOrdM :: LHStateM L.Name +lhOrdM = liftTCValues lhOrd lhAndE :: LHStateM L.Expr lhAndE = do diff --git a/src/G2/Nebula.hs b/src/G2/Nebula.hs new file mode 100644 --- /dev/null +++ b/src/G2/Nebula.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE CPP, FlexibleContexts #-} + +module G2.Nebula (plugin) where + +#if MIN_VERSION_GLASGOW_HASKELL(9,0,2,0) +import GHC.Plugins +#else +import GhcPlugins +#endif + +import G2.Config +import G2.Equiv.Config +import G2.Equiv.Verifier +import qualified G2.Initialization.Types as IT +import G2.Interface +import G2.Language as L +import qualified G2.Language.ExprEnv as E +import qualified G2.Solver as S +import G2.Translation + +import Data.IORef +import System.IO.Unsafe +import Data.List +import qualified Data.Text as T +import Options.Applicative + +-- | During symbolic execution, we need to know definitions, types, etc. +-- from previously compiled modules. We also need to avoid reusing the same +-- names. We use `compiledModules` to store both previously compiled modules +-- and existing Expression/Type Name maps. +compiledModules :: IORef (Maybe (ExtractedG2, NameMap, TypeNameMap)) +compiledModules = unsafePerformIO $ newIORef Nothing +{-# NOINLINE compiledModules #-} + +plugin :: Plugin +plugin = defaultPlugin { installCoreToDos = install } + +install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] +install cmd_lne todo = do + env <- getHscEnv + let pr_nebula_config = getNebulaConfigPlugin cmd_lne + (entry, nebula_config) <- liftIO $ handleParseResult pr_nebula_config + return $ CoreDoPluginPass "Nebula" (nebulaPluginPass entry nebula_config env):todo + +nebulaPluginPass :: Maybe String -> NebulaConfig -> HscEnv -> ModGuts -> CoreM ModGuts +nebulaPluginPass m_entry nebula_config env modguts = do + _ <- liftIO $ nebulaPluginPass' m_entry nebula_config env modguts + return modguts + +nebulaPluginPass' :: Maybe String -> NebulaConfig -> HscEnv -> ModGuts -> IO () +nebulaPluginPass' m_entry nebula_config env modguts = do + config <- getConfigDirect + -- We want simpl to be False so the simplifier does not run, because + -- this plugin get's inserted into the simplifier. Thus, running the implifier + -- results in an infinite loop. + let tconfig = (simplTranslationConfig {simpl = False, load_rewrite_rules = True, hpc_ticks = False}) + ems = EnvModSumModGuts env [] [modguts] + + prev_comp <- readIORef compiledModules + (prev_exg2, prev_nm, prev_tnm) <- case prev_comp of + Just prev -> return prev + Nothing -> translateBase tconfig config [] Nothing + + (new_nm, new_tm, exg2) <- hskToG2ViaEMS tconfig ems prev_nm prev_tnm + + let merged_exg2 = mergeExtractedG2s [exg2, prev_exg2] + injected_exg2 = specialInject merged_exg2 + writeIORef compiledModules $ Just (merged_exg2, new_nm, new_tm) + + let simp_state = initSimpleState injected_exg2 + + (init_state, bindings) = initStateFromSimpleState simp_state Nothing False + (\_ ng _ _ _ _ _ -> (Prim Undefined TyBottom, [], [], ng)) + (E.higherOrderExprs . IT.expr_env) + config + + let total = [] + case m_entry of + Just entry -> do + let tentry = T.pack entry + let rule = find (\r -> tentry == L.ru_name r) (rewrite_rules bindings) + rule' = case rule of + Just r -> r + Nothing -> error "not found" + _ <- checkRulePrinting config nebula_config init_state bindings total rule' + return () + Nothing -> do + let mod_name = T.pack . moduleNameString . moduleName . mg_module $ modguts + mapM_ (checkRulePrinting config nebula_config init_state bindings total) + $ filter (\r -> L.ru_module r == mod_name) (rewrite_rules bindings) + +checkRulePrinting :: (ASTContainer t L.Type, ASTContainer t L.Expr) => Config + -> NebulaConfig + -> State t + -> Bindings + -> [T.Text] -- ^ names of forall'd variables required to be total + -> RewriteRule + -> IO (S.Result () () ()) +checkRulePrinting config nebula_config init_state bindings total rule = do + let rule_name = T.unpack $ L.ru_name rule + nebula_config' = case log_rule nebula_config of + Just n -> if n == rule_name then nebula_config + else nebula_config {log_states = NoLog} + Nothing -> nebula_config + putStrLn $ "Log-rule nebula config = " ++ show (log_rule nebula_config) + putStrLn $ "Checking " ++ rule_name + res <- checkRule config nebula_config' init_state bindings total rule + case res of + S.SAT _ -> putStrLn $ rule_name ++ " - counterexample found" + S.UNSAT _ -> putStrLn $ rule_name ++ " - verified" + S.Unknown _ _ -> putStrLn $ rule_name ++ " - unknown result" + return res + diff --git a/src/G2/Postprocessing/Interface.hs b/src/G2/Postprocessing/Interface.hs --- a/src/G2/Postprocessing/Interface.hs +++ b/src/G2/Postprocessing/Interface.hs @@ -5,6 +5,6 @@ import G2.Language import G2.Postprocessing.NameSwitcher -runPostprocessing :: (ASTContainer m Expr, Named m) => Bindings -> m -> m +runPostprocessing :: Named m => Bindings -> m -> m runPostprocessing b = switchNames b diff --git a/src/G2/Preprocessing/AdjustTypes.hs b/src/G2/Preprocessing/AdjustTypes.hs --- a/src/G2/Preprocessing/AdjustTypes.hs +++ b/src/G2/Preprocessing/AdjustTypes.hs @@ -36,14 +36,14 @@ -- ) -- We remove $unpackCString, and convert the LitString to a list unpackString :: ASTContainer t Expr => State t -> State t -unpackString s@(State {type_env = tenv, known_values = kv}) = modifyASTsFix (unpackString' tenv kv) s +unpackString s@(State {type_env = tenv, known_values = kv}) = modifyASTs (unpackString' tenv kv) s unpackString' :: TypeEnv -> KnownValues -> Expr -> Expr -unpackString' _ _ (App (Var (Id (Name "unpackCString#" _ _ _) _)) e) = e +unpackString' tenv kv (App (Var (Id (Name "unpackCString#" _ _ _) _)) e) = unpackString' tenv kv e unpackString' tenv kv (Lit (LitString s)) = let - cns = mkCons kv tenv - em = mkEmpty kv tenv + cns = App (mkCons kv tenv) (Type (tyChar kv)) + em = App (mkEmpty kv tenv) (Type (tyChar kv)) char = mkDCChar kv tenv in diff --git a/src/G2/Preprocessing/NameCleaner.hs b/src/G2/Preprocessing/NameCleaner.hs --- a/src/G2/Preprocessing/NameCleaner.hs +++ b/src/G2/Preprocessing/NameCleaner.hs @@ -14,8 +14,10 @@ , cleanNamesFromList , allowedStartSymbols , allowedSymbol + , cleanName ) where +import Data.Foldable import qualified Data.HashMap.Lazy as HM import qualified Data.HashSet as S import qualified Data.Text as T @@ -51,7 +53,7 @@ cleanNames :: (ASTContainer t Expr, ASTContainer t Type, Named t) => State t -> CleanedNames -> NameGen -> (State t, CleanedNames, NameGen) cleanNames s cl_names ng = (renames hns s, cl_names', ng') where - (ns, ng') = createNamePairs ng . filter (not . allowedName) $ allNames s + (ns, ng') = createNamePairs ng . filter (not . allowedName) . map idName . E.symbolicIds $ expr_env s -- ++ altIds s hns = HM.fromList ns cl_names' = foldr (\(old, new) -> HM.insert new old) cl_names (HM.toList hns) @@ -59,13 +61,13 @@ cleanNames' :: Named n => NameGen -> n -> (n, NameGen) cleanNames' ng n = (renames hns n, ng') where - (ns, ng') = createNamePairs ng . filter (not . allowedName) $ names n + (ns, ng') = createNamePairs ng . filter (not . allowedName) . toList $ names n hns = HM.fromList ns cleanNamesFromList :: Named n => NameGen -> [Name] -> n -> (n, NameGen) cleanNamesFromList ng ns n = (renames hns n, ng') where - (ns', ng') = createNamePairs ng . filter (not . allowedName) $ names ns + (ns', ng') = createNamePairs ng . filter (not . allowedName) . toList $ names ns hns = HM.fromList ns' createNamePairs :: NameGen -> [Name] -> ([(Name, Name)], NameGen) @@ -73,18 +75,23 @@ where go :: NameGen -> [(Name, Name)] -> [Name] -> ([(Name, Name)], NameGen) go ng rns [] = (rns, ng) - go ng rns (name@(Name n m i l):ns) = + go ng rns (name:ns) = let - n' = T.filter (\x -> x `S.member` allowedSymbol) n - m' = fmap (T.filter $ \x -> x `S.member` allowedSymbol) m - - -- No reserved symbols start with a $, so this ensures both uniqueness - -- and starting with an allowed symbol - n'' = "$" `T.append` n' - - (new_name, ng') = freshSeededName (Name n'' m' i l) ng + name' = cleanName name + (new_name, ng') = freshSeededName name' ng in go ng' ((name, new_name):rns) ns -allNames :: (ASTContainer t Expr, ASTContainer t Type, Named t) => State t -> [Name] -allNames s = exprNames s ++ E.keys (expr_env s) +cleanName :: Name -> Name +cleanName nm@(Name n m i l) + | allowedName nm = nm + | otherwise = + let + n' = T.filter (\x -> x `S.member` allowedSymbol) n + m' = fmap (T.filter $ \x -> x `S.member` allowedSymbol) m + + -- No reserved symbols start with a $, so this ensures both uniqueness + -- and starting with an allowed symbol + n'' = "$" `T.append` n' + in + Name n'' m' i l diff --git a/src/G2/QuasiQuotes/FloodConsts.hs b/src/G2/QuasiQuotes/FloodConsts.hs --- a/src/G2/QuasiQuotes/FloodConsts.hs +++ b/src/G2/QuasiQuotes/FloodConsts.hs @@ -16,7 +16,8 @@ floodConstantsChecking ne s = case floodConstants ne s of Just s' -> - if all (pathCondMaybeSatisfiable (known_values s')) (PC.toList $ path_conds s') + if all (pathCondMaybeSatisfiable (type_env s') (known_values s')) + (PC.toList $ path_conds s') then Just s' else Nothing Nothing -> Nothing @@ -57,16 +58,14 @@ -- Attempts to determine if a PathCond is satisfiable. A return value of False -- means the PathCond is definitely unsatisfiable. A return value of True means -- the PathCond may or may not be satisfiable. -pathCondMaybeSatisfiable :: KnownValues -> PathCond -> Bool -pathCondMaybeSatisfiable _ (AltCond l1 (Lit l2) b) = (l1 == l2) == b -pathCondMaybeSatisfiable _ (AltCond _ _ _) = True -pathCondMaybeSatisfiable kv (ExtCond e b) = +pathCondMaybeSatisfiable :: TypeEnv -> KnownValues -> PathCond -> Bool +pathCondMaybeSatisfiable _ _ (AltCond l1 (Lit l2) b) = (l1 == l2) == b +pathCondMaybeSatisfiable _ _ (AltCond _ _ _) = True +pathCondMaybeSatisfiable tenv kv (ExtCond e b) = let - r = evalPrims kv e + r = evalPrims tenv kv e tr = mkBool kv True fal = mkBool kv False in if (r == tr && not b) || (r == fal && b) then False else True -pathCondMaybeSatisfiable _ (ConsCond dc1 (Data dc2) b) = (dc1 == dc2) == b -pathCondMaybeSatisfiable _ (PCExists _) = True diff --git a/src/G2/QuasiQuotes/G2Rep.hs b/src/G2/QuasiQuotes/G2Rep.hs --- a/src/G2/QuasiQuotes/G2Rep.hs +++ b/src/G2/QuasiQuotes/G2Rep.hs @@ -1,4 +1,3 @@ --- Hides the warnings about deriving {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} diff --git a/src/G2/QuasiQuotes/Internals/G2Rep.hs b/src/G2/QuasiQuotes/Internals/G2Rep.hs --- a/src/G2/QuasiQuotes/Internals/G2Rep.hs +++ b/src/G2/QuasiQuotes/Internals/G2Rep.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} @@ -53,23 +54,43 @@ , genG2UnRep (length tvs) cs , genG2Type tyConName]] where +#if MIN_VERSION_GLASGOW_HASKELL(9,0,2,0) + apply t (PlainTV name _) = appT t (varT name) + apply t (KindedTV name _ _) = appT t (varT name) + + mkCxt (PlainTV name _) = conT ''G2Rep `appT` varT name + mkCxt (KindedTV name _ _) = conT ''G2Rep `appT` varT name +#else apply t (PlainTV name) = appT t (varT name) apply t (KindedTV name _) = appT t (varT name) mkCxt (PlainTV name) = conT ''G2Rep `appT` varT name mkCxt (KindedTV name _) = conT ''G2Rep `appT` varT name +#endif +#if MIN_VERSION_GLASGOW_HASKELL(9,0,2,0) +genG2Rep :: TH.Name -> [TyVarBndr ()] -> [Con] -> Q Dec +#else genG2Rep :: TH.Name -> [TyVarBndr] -> [Con] -> Q Dec +#endif genG2Rep tyConName tvs cs = funD 'g2Rep (map (genG2RepClause tyConName tvs) cs) +#if MIN_VERSION_GLASGOW_HASKELL(9,0,2,0) +genG2RepClause :: TH.Name -> [TyVarBndr ()] -> Con -> Q Clause +#else genG2RepClause :: TH.Name -> [TyVarBndr] -> Con -> Q Clause +#endif genG2RepClause tyConName tvs (NormalC name fieldTypes) = genG2RepClause' tyConName tvs name fieldTypes genG2RepClause tyConName tvs (InfixC st1 n st2) = genG2RepClause' tyConName tvs n [st1, st2] genG2RepClause _ _ con = error $ "genG2RepClause: Unhandled case." ++ show con +#if MIN_VERSION_GLASGOW_HASKELL(9,0,2,0) +genG2RepClause' :: TH.Name -> [TyVarBndr ()] -> TH.Name -> [StrictType] -> Q Clause +#else genG2RepClause' :: TH.Name -> [TyVarBndr] -> TH.Name -> [StrictType] -> Q Clause +#endif genG2RepClause' tyConName tvs dcNme fieldTypes = do tenv <- newName "tenv_rep" cleaned <- newName "cleaned" @@ -85,7 +106,8 @@ `appE` litE (integerL $ toInteger $ length fieldTypes) `appE` qqNameToQExp qqTyConName `appE` qqNameToQExp qqName - `appE` (varE 'qqMap `appE` varE cleaned `appE` varE tenv) + `appE` (varE 'qqMap `appE` varE cleaned `appE` [|HM.keys $(varE tenv)|]) + `appE` (varE 'qqMap `appE` varE cleaned `appE` [|map dcName . concatMap dataCon . HM.elems $ $(varE tenv)|]) `appE` varE tenv) tys = map (\tyv -> conE 'Type @@ -100,8 +122,13 @@ clause pats body [] where +#if MIN_VERSION_GLASGOW_HASKELL(9,0,2,0) + tyVBToType (PlainTV name _) = varT name + tyVBToType (KindedTV name _ _) = varT name +#else tyVBToType (PlainTV name) = varT name tyVBToType (KindedTV name _) = varT name +#endif -- | Looks up a `DataCon` with the given type and data constructor name. -- Falls back to creating a data constructor from scratch, if the data constructor @@ -110,17 +137,16 @@ -- available when the QuasiQuoter is compiled qqDataConLookupFallBack :: Int -- The number of TyVars -> Int -- The number of arguments - -> QQName -> QQName -> QQMap -> TypeEnv -> DataCon -qqDataConLookupFallBack tyv_n arg_n qqtn qqdc qqm tenv - | Just dc <- qqDataConLookup qqtn qqdc qqm tenv = dc + -> QQName -> QQName -> QQMap -> QQMap -> TypeEnv -> DataCon +qqDataConLookupFallBack tyv_n arg_n qqtn qqdc type_nm_qqm dc_nm_qqm tenv + | Just dc <- qqDataConLookup qqtn qqdc type_nm_qqm dc_nm_qqm tenv = dc | otherwise = let n = G2.Name "unknown" Nothing 0 Nothing i = Id n TYPE - ntb = NamedTyBndr i t = mkTyFun $ replicate (arg_n + 1) (TyCon n TYPE) - t' = foldr TyForAll t (replicate tyv_n ntb) + t' = foldr TyForAll t (replicate tyv_n i) in DataCon (qqNameToName0 qqdc) t' @@ -165,9 +191,9 @@ let guardRet = return (guardPat, ret) clause pats (guardedB [guardRet]) [] - fnt -> do + fnt@(fnt_h:_) -> do tenv <- newName "tenv_unrep" - let pats = varP tenv:[varP expr] + let pats = if usesTEnvUnRep (snd fnt_h) then varP tenv:[varP expr] else wildP:[varP expr] ret <- appsE $ conE dcNme:map (newFieldUnRep tenv) fnt let guardRet = return (guardPat, ret) @@ -179,7 +205,7 @@ expr <- newName "expr" let pats = [wildP, varP expr] - clause pats (normalB [|error $ "Unhandled case in g2UnRep" ++ show $(varE expr) |]) [] + clause pats (normalB [|error $ "Unhandled case in g2UnRep " ++ show $(varE expr) |]) [] newFieldUnRep :: TH.Name -> (TH.Name, StrictType) -> Q Exp newFieldUnRep _ (x, (_, ConT n)) @@ -193,6 +219,12 @@ newFieldUnRep tenv (x, _) = do varE 'g2UnRep `appE` varE tenv `appE` varE x +usesTEnvUnRep :: StrictType -> Bool +usesTEnvUnRep (_, ConT n) = + let nb = nameBase n in + not (nb == "Int#" || nb == "Float#" || nb == "Double#" || nb == "Char#") +usesTEnvUnRep _ = True + genG2Type :: TH.Name -> Q Dec genG2Type tyConName = funD 'g2Type [genG2TypeClause tyConName] @@ -232,7 +264,7 @@ intPrimFromLit (Lit (LitInt x)) = case fromInteger x of I# x' -> x' -intPrimFromLit _ = error "intPrimFromLit: Unhandled Expr" +intPrimFromLit e = error $ "intPrimFromLit: Unhandled Expr" ++ show e floatPrimFromLit :: G2.Expr -> Float# floatPrimFromLit (Lit (LitFloat x)) = diff --git a/src/G2/QuasiQuotes/Parser.hs b/src/G2/QuasiQuotes/Parser.hs --- a/src/G2/QuasiQuotes/Parser.hs +++ b/src/G2/QuasiQuotes/Parser.hs @@ -36,7 +36,7 @@ symbVarRegex = mkRegex $ "[?][(]" ++ paddedIdRs ++ "::[^!?|]*" lamDividerRegex :: Regex -lamDividerRegex = mkRegex $ "->" ++ whiteSpaceRs ++ "[?]" +lamDividerRegex = mkRegex $ "->" ++ whiteSpaceRs ++ "*" ++ "[?]" dividerRegex :: Regex dividerRegex = mkRegex $ "[" ++ bar ++ "]" diff --git a/src/G2/QuasiQuotes/QuasiQuotes.hs b/src/G2/QuasiQuotes/QuasiQuotes.hs --- a/src/G2/QuasiQuotes/QuasiQuotes.hs +++ b/src/G2/QuasiQuotes/QuasiQuotes.hs @@ -11,9 +11,11 @@ import G2.Execution.Interface import G2.Execution.Memory import G2.Execution.Reducer +import G2.Execution.Rules import G2.Initialization.MkCurrExpr import G2.Interface import G2.Language as G2 +import qualified G2.Language.PathConds as PC import qualified G2.Language.Typing as Ty import G2.Solver import G2.Translation.Cabal.Cabal @@ -26,11 +28,15 @@ import G2.QuasiQuotes.Parser import qualified Control.Concurrent.Lock as Lock +import Control.Monad.IO.Class import Data.Data +import qualified Data.HashSet as HS +import qualified Data.HashMap.Lazy as HM import Data.List import qualified Data.Map as M import Data.Maybe +import qualified Data.Sequence as Seq import Data.IORef import qualified Data.Text as T @@ -54,6 +60,7 @@ -- aquired/released by each quasiquoter's compilation oneByOne :: IORef Lock.Lock oneByOne = unsafePerformIO $ newIORef =<< Lock.new +{-# NOINLINE oneByOne #-} acquireIORefLock :: IO () acquireIORefLock = do @@ -82,8 +89,8 @@ -- Get names for the lambdas for the regular inputs exG2 <- parseHaskellQ' qext config <- runIO qqConfig - let (init_s, _, init_b) = initState' exG2 (T.pack functionName) (Just $ T.pack moduleName) - (mkCurrExpr Nothing Nothing) config + let (init_s, init_b) = initStateWithCall' exG2 (T.pack functionName) (Just $ T.pack moduleName) + (mkCurrExpr Nothing Nothing) (mkArgTys) config runIO $ releaseIORefLock @@ -98,7 +105,7 @@ Completed xs b -> do case elimUnusedCompleted xs b of (xs'@(s:_), b') -> do - let xs'' = listE $ map (moveOutTypeEnvState tenv_name) xs' + let xs'' = listE $ map (moveOutStatePieces tenv_name) xs' xs''' = addCompRegVarPasses (varE state_name) tenv_name cleaned_names_name ns (inputIds s b') b' @@ -118,13 +125,13 @@ in return (foldr (\n -> lamE [n]) [| return (Nothing :: Maybe $(tup_t)) |] ns_pat , [| return [] :: IO [State ()] |] - , M.empty + , HM.empty , b') NonCompleted s b -> do let (s', b') = elimUnusedNonCompleted s b - s'' = moveOutTypeEnvState tenv_name s' + s'' = moveOutStatePieces tenv_name s' s''' = addedNonCompRegVarBinds (varE state_name) tenv_name cleaned_names_name ns (inputIds s' b') b' @@ -140,7 +147,7 @@ let tenv_exp = liftDataT tenv `sigE` [t| TypeEnv |] - bindings_exp = liftDataT (bindings_final { name_gen = mkNameGen ()}) + bindings_exp = liftDataT bindings_final letE [ valD (varP state_name) (normalB state_exp) [] , valD (varP tenv_name) (normalB tenv_exp) [] @@ -150,10 +157,15 @@ liftDataT :: Data a => a -> Q Exp liftDataT = dataToExpQ (\a -> case liftText <$> cast a of je@(Just _) -> je - Nothing -> liftLoc <$> cast a) + Nothing -> case liftLoc <$> cast a of + jl@(Just _) -> jl + Nothing -> liftMaybeSpan <$> cast a) where liftText txt = appE (varE 'T.pack) (stringE (T.unpack txt)) liftLoc (G2.Loc l c f) = conE 'G2.Loc `appE` intE l `appE` intE c `appE` stringE f + + liftMaybeSpan :: Maybe Span -> Q Exp + liftMaybeSpan _ = conE 'Nothing intE i = [| i |] parseHaskellQ' :: QuotedExtract-> Q ExtractedG2 @@ -189,8 +201,8 @@ projs <- cabalSrcDirs cabal' config <- qqConfig - translateLoaded projs [filepath] [] - simplTranslationConfig + translateLoaded projs [filepath] + (simplTranslationConfig { interpreter = True }) config) return exG2 where @@ -220,11 +232,12 @@ runIO $ do let (s', b') = addAssume s b - SomeSolver con <- initSolverInfinite config - case qqRedHaltOrd con of + SomeSolver solver <- initSolverInfinite config + let simplifier = IdSimplifier + case qqRedHaltOrd config solver simplifier of (SomeReducer red, SomeHalter hal, SomeOrderer ord) -> do - let (s'', b'') = runG2Pre [] s' b' - hal' = hal :<~> ZeroHalter 2000 :<~> LemmingsHalter + let (s'', b'') = runG2Pre emptyMemConfig s' b' + hal' = hal <~> zeroHalter 2000 <~> lemmingsHalter (xs, b''') <- runExecutionToProcessed red hal' ord s'' b'' case xs of @@ -239,14 +252,15 @@ _ = False -- | As soon as one States has been discarded, discard all States -data LemmingsHalter = LemmingsHalter - -instance Halter LemmingsHalter () t where - initHalt _ _ = () - updatePerStateHalt _ _ _ _ = () - discardOnStart _ _ pr _ = not . null . discarded $ pr - stopRed _ _ _ _ = Continue - stepHalter _ _ _ _ _ = () +lemmingsHalter :: Monad m => Halter m () t +lemmingsHalter = + (mkSimpleHalter + (const ()) + (\_ _ _ -> ()) + (\_ _ _ -> return Continue) + (\_ _ _ _ -> ())) { discardOnStart = discard } + where + discard _ pr _ = not . null . discarded $ pr fileName :: String fileName = "THTemp.hs" @@ -257,19 +271,18 @@ functionName :: String functionName = "g2Expr" -qqRedHaltOrd :: Solver conv => conv -> (SomeReducer (), SomeHalter (), SomeOrderer ()) -qqRedHaltOrd conv = +qqRedHaltOrd :: (MonadIO m, Solver solver, Simplifier simplifier) => Config -> solver -> simplifier -> (SomeReducer m (), SomeHalter m (), SomeOrderer m ()) +qqRedHaltOrd config solver simplifier = let - tr_ng = mkNameGen () + share = sharing config + state_name = G2.Name "state" Nothing 0 Nothing in - ( SomeReducer - (NonRedPCRed :<~| TaggerRed state_name tr_ng) - <~| (SomeReducer (StdRed conv)) + ( taggerRed state_name :== Finished .--> nonRedPCRed :== Finished --> stdRed share retReplaceSymbFuncVar solver simplifier , SomeHalter - (DiscardIfAcceptedTag state_name - :<~> AcceptHalter) - , SomeOrderer NextOrderer) + (discardIfAcceptedTagHalter state_name + <~> acceptIfViolatedHalter) + , SomeOrderer nextOrderer) addAssume :: State t -> Bindings -> (State t, Bindings) addAssume s@(State { curr_expr = CurrExpr er e }) b@(Bindings { name_gen = ng }) = @@ -283,13 +296,45 @@ type CleanedNamesName = TH.Name -- We have the TypeEnv separately from the state, and it is a waste to lift it to TH twice. --- This avoids having to do that -moveOutTypeEnvState :: Data t => TypeEnvName -> State t -> Q Exp -moveOutTypeEnvState tenv_name s = do - let s' = s { type_env = M.empty } - s_exp = liftDataT s' - [| $(s_exp) { type_env = $(varE tenv_name) } |] +-- Further, we cannot directly apply Data to the PathConds, since they use and IORef +moveOutStatePieces :: Data t => TypeEnvName -> State t -> Q Exp +moveOutStatePieces tenv_name s = do + let -- s' = s { type_env = M.empty, path_conds = undefined } + -- s_exp = liftDataT s' + expr_env_exp = liftDataT (expr_env s) + curr_expr_exp = liftDataT (curr_expr s) + non_red_path_conds_exp = liftDataT (non_red_path_conds s) + true_assert_exp = liftDataT (true_assert s) + assert_ids_exp = liftDataT (assert_ids s) + type_classes_exp = liftDataT (type_classes s) + exec_stack_exp = liftDataT (exec_stack s) + model_exp = liftDataT (model s) + known_values_exp = liftDataT (known_values s) + rules_exp = liftDataT (rules s) + num_steps_exp = liftDataT (num_steps s) + tags_exp = liftDataT (tags s) + track_exp = liftDataT (track s) + + pc_exp = liftDataT . PC.toList $ path_conds s + + [| State { expr_env = $(expr_env_exp) + , type_env = $(varE tenv_name) + , curr_expr = $(curr_expr_exp) + , path_conds = PC.fromList $(pc_exp) + , non_red_path_conds = $(non_red_path_conds_exp) + , true_assert = $(true_assert_exp) + , assert_ids = $(assert_ids_exp) + , type_classes = $(type_classes_exp) + , exec_stack = $(exec_stack_exp) + , model = $(model_exp) + , known_values = $(known_values_exp) + , rules = $(rules_exp) + , num_steps = $(num_steps_exp) + , tags = $(tags_exp) + , sym_gens = Seq.empty + , track = $(track_exp) } |] + -- Returns an Q Exp represeting a [(Name, Expr)] list regVarBindings :: [TH.Name] -> TypeEnvName -> CleanedNamesName -> InputIds -> Bindings -> Q Exp regVarBindings ns tenv_name cleaned_name is (Bindings { input_names = ins, cleaned_names = cleaned }) = do @@ -331,7 +376,7 @@ elimUnusedCompleted xs b = let b' = b { deepseq_walkers = M.empty - , higher_order_inst = [] } + , higher_order_inst = HS.empty } xs' = map (\s -> s { type_classes = initTypeClasses [] , rules = [] }) xs @@ -343,7 +388,7 @@ elimUnusedNonCompleted s b = let b' = b { deepseq_walkers = M.empty - , higher_order_inst = [] } + , higher_order_inst = HS.empty } s' = s { type_classes = initTypeClasses [] , rules = [] } in @@ -353,16 +398,15 @@ type StateListExp = Q Exp type BindingsExp = Q Exp -data ErrorHalter = ErrorHalter - -instance Halter ErrorHalter () t where - initHalt _ _ = () - updatePerStateHalt _ _ _ _ = () - - stopRed _ _ _ (State { curr_expr = CurrExpr _ (G2.Prim Error _)}) = Discard - stopRed _ _ _ _ = Continue - - stepHalter _ _ _ _ _ = () +errorHalter :: Monad m => Halter m () t +errorHalter = mkSimpleHalter + (const ()) + (\_ _ _ -> ()) + stop + (\_ _ _ _ -> ()) + where + stop _ _ (State { curr_expr = CurrExpr _ (G2.Prim Error _)}) = return Discard + stop _ _ _ = return Continue executeAndSolveStates :: StateExp -> BindingsExp -> Q Exp executeAndSolveStates s b = do @@ -371,20 +415,13 @@ executeAndSolveStates' :: Bindings -> State () -> IO (Maybe (ExecRes ())) executeAndSolveStates' b s = do config <- qqConfig - SomeSolver con <- initSolverInfinite config - case qqRedHaltOrd con of + SomeSolver solver <- initSolverInfinite config + let simplifier = IdSimplifier + case qqRedHaltOrd config solver simplifier of (SomeReducer red, SomeHalter hal, _) -> do - -- let hal' = hal :<~> ErrorHalter - -- :<~> MaxOutputsHalter (Just 1) - -- :<~> BranchAdjSwitchEveryNHalter 2000 20 - -- :<~> SwitchEveryNHalter 2000 - let hal' = hal :<~> ErrorHalter :<~> VarLookupLimit 3 :<~> MaxOutputsHalter (Just 1) - -- (res, _) <- runG2Post red hal' PickLeastUsedOrderer con s b - -- (res, _) <- runG2Post (red :<~ Logger "qq") hal' ((IncrAfterN 2000 SymbolicADTOrderer) - -- :<-> BucketSizeOrderer 6) con s b - (res, _) <- runG2Post (red) hal' ((IncrAfterN 2000 ADTHeightOrderer) - :<-> BucketSizeOrderer 6) con s b - -- (res, _) <- runG2Post (red) hal' (BucketSizeOrderer 3) con s b + let hal' = hal <~> errorHalter <~> varLookupLimitHalter 3 <~> maxOutputsHalter (Just 1) + ord = incrAfterN 2000 (adtHeightOrderer 0 Nothing) <-> bucketSizeOrderer 6 + (res, _) <- runG2Post red hal' ord solver simplifier s b case res of exec_res:_ -> return $ Just exec_res @@ -400,20 +437,22 @@ , ASTContainer t G2.Type) => Bindings -> [State t] -> IO (Maybe (ExecRes t)) solveStates' b xs = do config <- qqConfig - SomeSolver con <- initSolverInfinite config - solveStates'' con b xs + SomeSolver solver <- initSolverInfinite config + let simplifier = IdSimplifier + solveStates'' solver simplifier b xs solveStates'' :: ( Named t , ASTContainer t Expr , ASTContainer t G2.Type - , Solver sol) => sol -> Bindings -> [State t] -> IO (Maybe (ExecRes t)) -solveStates'' _ _ [] =return Nothing -solveStates'' sol b (s:xs) = do - m_ex_res <- runG2Solving sol b s + , Solver solver + , Simplifier simplifier) => solver -> simplifier -> Bindings -> [State t] -> IO (Maybe (ExecRes t)) +solveStates'' _ _ _ [] = return Nothing +solveStates'' sol simplifier b (s:xs) = do + m_ex_res <- runG2Solving sol simplifier b s case m_ex_res of Just _ -> do return m_ex_res - Nothing -> solveStates'' sol b xs + Nothing -> solveStates'' sol simplifier b xs -- | Get the values of the symbolic arguments, and returns them in a tuple extractArgs :: InputIds -> CleanedNames -> TypeEnvName -> Q Exp -> Q Exp @@ -424,15 +463,19 @@ Just r' -> return . Just . $(toSymbArgsTuple in_ids cleaned tenv) $ conc_args r' Nothing -> return Nothing |] --- | Returns a function to turn the first (length of InputIds) elements of a list into a tuple +-- | If (length of InputIds) is greater than 1, returns a function to turn the first (length of InputIds) elements of +-- a list into a tuple. +-- Otherwise, simply returns the singular value directly. toSymbArgsTuple :: InputIds -> CleanedNames -> TypeEnvName -> Q Exp toSymbArgsTuple in_ids cleaned tenv_name = do + let mkTup = if length in_ids > 1 then tupE else head lst <- newName "lst" lamE [varP lst] - (tupE $ map (\(i, n) -> [| g2UnRep $(varE tenv_name) ($(varE lst) !! n) :: $(toTHType cleaned (Ty.typeOf i)) |]) $ zip in_ids ([0..] :: [Int])) + (mkTup $ map (\(i, n) -> [| g2UnRep $(varE tenv_name) ($(varE lst) !! n) :: $(toTHType cleaned (Ty.typeOf i)) |]) $ zip in_ids ([0..] :: [Int])) qqConfig :: IO Config qqConfig = do homedir <- getHomeDirectory - return $ mkConfig homedir [] M.empty + let config = mkConfigDirect homedir [] M.empty + return $ config { extraDefaultMods = [homedir ++ "/.g2/G2Stubs/src/G2/QuasiQuotes/G2Rep.hs"] } diff --git a/src/G2/QuasiQuotes/Support.hs b/src/G2/QuasiQuotes/Support.hs --- a/src/G2/QuasiQuotes/Support.hs +++ b/src/G2/QuasiQuotes/Support.hs @@ -25,9 +25,9 @@ import GHC.Generics (Generic) import Data.Data +import Data.Foldable import Data.Hashable import qualified Data.HashMap.Lazy as HM -import qualified Data.Map as M import qualified Data.Text as T data QQName = QQName T.Text (Maybe T.Text) @@ -40,7 +40,7 @@ qqMap :: Named n => CleanedNames -> n -> QQMap qqMap cn n = let - ns = names n + ns = toList $ names n in HM.fromList $ zip (map (nameToQQName . renames cn) ns) ns @@ -56,19 +56,20 @@ qqNameToName0 (QQName n m) = Name n m 0 Nothing qqAlgDataTyLookup :: QQName -> QQMap -> TypeEnv -> Maybe AlgDataTy -qqAlgDataTyLookup qqn qqm tenv = flip M.lookup tenv =<< HM.lookup qqn qqm +qqAlgDataTyLookup qqn qqm tenv = flip HM.lookup tenv =<< HM.lookup qqn qqm -qqDataConLookup :: QQName -> QQName -> QQMap -> TypeEnv -> Maybe DataCon -qqDataConLookup qqtn qqdcn qqm tenv - | Just adt <- qqAlgDataTyLookup qqtn qqm tenv - , Just dcn <- HM.lookup qqdcn qqm = dataConWithName adt dcn +qqDataConLookup :: QQName -> QQName -> QQMap -> QQMap -> TypeEnv -> Maybe DataCon +qqDataConLookup qqtn qqdcn type_nm_qqm dc_nm_qqm tenv + | Just adt <- qqAlgDataTyLookup qqtn type_nm_qqm tenv + , Just dcn <- HM.lookup qqdcn dc_nm_qqm = dataConWithName adt dcn | otherwise = Nothing toTHType :: CleanedNames -> G2.Type -> Q TH.Type toTHType cleaned (TyFun t1 t2) = appT (appT arrowT $ toTHType cleaned t1) (toTHType cleaned t2) toTHType cleaned (TyApp t1 t2) = appT (toTHType cleaned t1) (toTHType cleaned t2) toTHType cleaned t@(TyCon n _) - | nameOcc (renames cleaned n) == "[]" = listT + | nameOcc (renames cleaned n) == "List" = listT -- GHC 9.6 on + | nameOcc (renames cleaned n) == "[]" = listT -- pre GHC 9.6 | Just i <- tupleNum . nameOcc $ renames cleaned n = tupleT i | otherwise = do tn <- lookupTypeName . T.unpack . nameOcc $ renames cleaned n diff --git a/src/G2/Solver.hs b/src/G2/Solver.hs --- a/src/G2/Solver.hs +++ b/src/G2/Solver.hs @@ -1,18 +1,22 @@ -- | Solver -- Export module for G2.Solver. module G2.Solver - ( module G2.Solver.ADTSolver, + ( module G2.Solver.ADTNumericalSolver, module G2.Solver.Converters, module G2.Solver.Language, module G2.Solver.Interface, + module G2.Solver.Maximize, module G2.Solver.ParseSMT, + module G2.Solver.Simplifier, module G2.Solver.SMT2, module G2.Solver.Solver ) where -import G2.Solver.ADTSolver +import G2.Solver.ADTNumericalSolver import G2.Solver.Converters import G2.Solver.Language import G2.Solver.Interface +import G2.Solver.Maximize import G2.Solver.ParseSMT +import G2.Solver.Simplifier import G2.Solver.SMT2 import G2.Solver.Solver diff --git a/src/G2/Solver/ADTNumericalSolver.hs b/src/G2/Solver/ADTNumericalSolver.hs new file mode 100644 --- /dev/null +++ b/src/G2/Solver/ADTNumericalSolver.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE OverloadedStrings #-} + +module G2.Solver.ADTNumericalSolver ( ADTNumericalSolver (..) + , adtNumericalSolFinite + , adtNumericalSolInfinite) where + +import G2.Language.ArbValueGen +import G2.Language.Support +import G2.Language.Syntax +import qualified G2.Language.PathConds as PC +import G2.Solver.Solver + +-- | Converts constraints about ADTs to numerical constraints before sending them to other solvers +data ADTNumericalSolver solver = ADTNumericalSolver ArbValueFunc solver + +adtNumericalSolFinite :: solver -> ADTNumericalSolver solver +adtNumericalSolFinite = ADTNumericalSolver arbValue + +adtNumericalSolInfinite :: solver -> ADTNumericalSolver solver +adtNumericalSolInfinite = ADTNumericalSolver arbValueInfinite + +instance Solver solver => Solver (ADTNumericalSolver solver) where + check (ADTNumericalSolver _ sol) s pc = return . fst =<< checkConsistency (Tr sol) s pc + solve (ADTNumericalSolver avf sol) s b is pc = do + (r, _) <- solve' avf (Tr sol) s b is pc + return r + close (ADTNumericalSolver _ s) = close s + +instance TrSolver solver => TrSolver (ADTNumericalSolver solver) where + checkTr (ADTNumericalSolver avf sol) s pc = do + (r, sol') <- checkConsistency sol s pc + return (r, ADTNumericalSolver avf sol') + solveTr (ADTNumericalSolver avf sol) s b is pc = do + (r, sol') <- solve' avf sol s b is pc + return (r, ADTNumericalSolver avf sol') + closeTr (ADTNumericalSolver _ s) = closeTr s + +checkConsistency :: TrSolver solver => solver -> State t -> PathConds -> IO (Result () () (), solver) +checkConsistency solver s pc + | PC.null pc = return (SAT (), solver) + | otherwise = do + checkTr solver s pc + +solve' :: TrSolver solver => ArbValueFunc -> solver -> State t -> Bindings -> [Id] -> PathConds -> IO (Result Model () (), solver) +solve' _ sol s b is pc = do + solveTr sol s b is pc diff --git a/src/G2/Solver/ADTSolver.hs b/src/G2/Solver/ADTSolver.hs deleted file mode 100644 --- a/src/G2/Solver/ADTSolver.hs +++ /dev/null @@ -1,206 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} - -module G2.Solver.ADTSolver ( ADTSolver (..) - , adtSolverFinite - , adtSolverInfinite - , checkConsistency - , findConsistent) where - -import G2.Language.ArbValueGen -import G2.Language.Casts -import G2.Language.Expr -import qualified G2.Language.ExprEnv as E -import G2.Language.Naming -import G2.Language.Support -import G2.Language.Syntax -import G2.Language.PathConds hiding (map, filter, null) -import qualified G2.Language.PathConds as PC -import G2.Language.Typing -import G2.Solver.Solver - -import Data.List -import qualified Data.Map as M -import Data.Maybe -import Prelude hiding (null) -import qualified Prelude as Pre -import Data.Tuple - -data ADTSolver = ADTSolver ArbValueFunc - -adtSolverFinite :: ADTSolver -adtSolverFinite = ADTSolver arbValue - -adtSolverInfinite :: ADTSolver -adtSolverInfinite = ADTSolver arbValueInfinite - -instance Solver ADTSolver where - check _ s = return .checkConsistency (known_values s) (expr_env s) (type_env s) - solve (ADTSolver avf) s b is = solveADTs avf s b (nub is) - --- | Attempts to detemine if the given PathConds are consistent. --- Returns Just True if they are, Just False if they are not, --- and Nothing if it can't decide. -checkConsistency :: KnownValues -> ExprEnv -> TypeEnv -> PathConds -> Result -checkConsistency kv eenv tenv pc - | all PC.isPCExists $ PC.toList pc = SAT - | otherwise = - maybe (Unknown "Non-ADT path constraints") - (\me -> if not (Pre.null me) then SAT else UNSAT) - $ findConsistent kv eenv tenv $ PC.filter (not . PC.isPCExists) pc - --- | Attempts to find expressions (Data d) or (Coercion (Data d), (t1 :~ t2)) consistent with the given path --- constraints. Returns Just [...] if it can determine [...] are consistent. --- Just [] means there are no consistent Expr. Nothing nmeans it could not be --- determined if there were any consistent data constructors. --- In practice, the result should always be Just [...] if all the path conds --- are about ADTs. -findConsistent :: KnownValues -> ExprEnv -> TypeEnv -> PathConds -> Maybe [Expr] -findConsistent kv eenv tenv = fmap fst . findConsistent' kv eenv tenv - -head' :: [a] -> Maybe a -head' (x:_) = Just x -head' _ = Nothing - -findConsistent' :: KnownValues -> ExprEnv -> TypeEnv -> PathConds -> Maybe ([Expr], [(Id, Type)]) -findConsistent' kv eenv tenv pc = - let - pc' = unsafeElimCast $ toList pc - - -- Adding Coercions - pcNT = fmap (pcInCastType tenv) . head' $ toList pc - cons = findConsistent'' kv tenv eenv pc' - in - case cons of - Just (cons', bi) -> - let - cons'' = simplifyCasts . map (castReturnType $ fromJust pcNT) $ cons' - in - -- We can't use the ADT solver when we have a Boolean, because the RHS of the - -- DataAlt might be a primitive. - if any isExtCond pc' || pcNT == Just (tyBool kv) then Nothing else Just (cons'', bi) - Nothing -> Nothing - -findConsistent'' :: KnownValues -> TypeEnv -> ExprEnv -> [PathCond] -> Maybe ([Expr], [(Id, Type)]) -findConsistent'' kv tenv eenv pc = - let - is = nub . map (\(Id n t') -> Id n (typeStripCastType tenv t')) $ concatMap (varIdsInPC kv) pc - - t = pcVarType tenv pc - cons = maybe Nothing (flip getCastedAlgDataTy tenv) t - - in - case (cons, is) of - (Just (DataTyCon _ dc, bi), [i]) -> - let - dc' = case E.lookup (idName i) eenv of - Just e - | Data spec_dc:_ <- unApp e -> [spec_dc] - _ -> dc - - - cons' = fmap (map Data) $ findConsistent''' dc' pc - in - maybe Nothing (Just . (, bi)) cons' - _ -> Nothing - -findConsistent''' :: [DataCon] -> [PathCond] -> Maybe [DataCon] -findConsistent''' dcs ((ConsCond dc _ True):pc) = - findConsistent''' (filter ((==) (dcName dc) . dcName) dcs) pc -findConsistent''' dcs ((ConsCond dc _ False):pc) = - findConsistent''' (filter ((/=) (dcName dc) . dcName) dcs) pc --- findConsistent''' dcs (PCExists _:pc) = findConsistent''' dcs pc -findConsistent''' dcs [] = Just dcs -findConsistent''' _ _ = Nothing - -solveADTs :: ArbValueFunc -> State t -> Bindings -> [Id] -> PathConds -> IO (Result, Maybe Model) -solveADTs avf s@(State { expr_env = eenv, model = m }) b [Id n t] pc - | not $ E.isSymbolic n eenv - , Just e <- E.lookup n eenv = return (SAT, Just . liftCasts $ M.insert n e m ) - -- We can't use the ADT solver when we have a Boolean, because the RHS of the - -- DataAlt might be a primitive. - | TyCon tn k <- tyAppCenter t - , ts <- tyAppArgs t - , t /= tyBool (known_values s) = - do - let (r, s', _) = addADTs avf n tn ts k s b (PC.filter (not . isPCExists) pc) - - case r of - SAT -> return (r, Just . liftCasts $ model s') - r' -> return (r', Nothing) -solveADTs _ _ _ _ _ = return (Unknown "Unhandled path constraints in ADTSolver", Nothing) - --- | Determines an ADT based on the path conds. The path conds form a witness. --- In particular, refer to findConsistent in Solver/ADTSolver.hs -addADTs :: ArbValueFunc -> Name -> Name -> [Type] -> Kind -> State t -> Bindings -> PathConds -> (Result, State t, Bindings) -addADTs avf n tn ts k s b pc - | PC.null pc = - let - (bse, av) = avf (mkTyApp (TyCon tn k:ts)) (type_env s) (arb_value_gen b) - m' = M.singleton n bse - in - (SAT, (s {model = M.union m' (model s)}), (b {arb_value_gen = av})) - | Just (dcs@(fdc:_), bi) <- findConsistent' (known_values s) (expr_env s) (type_env s) pc = - let - eenv = expr_env s - ts2 = map snd bi - -- We map names over the arguments of a DataCon, to make sure we have the correct - -- number of undefined's. - ts'' = case exprInCasts fdc of - Data (DataCon _ ts') -> anonArgumentTypes $ PresType ts' - _ -> [] -- [Name "b" Nothing 0 Nothing] - - (ns, _) = childrenNames n (map (const $ Name "a" Nothing 0 Nothing) ts'') (name_gen b) - - (av, vs) = mapAccumL (\av_ (n', t') -> - case E.lookup n' eenv of - Just e -> (av_, e) - Nothing -> swap $ avf t' (type_env s) av_) (arb_value_gen b) $ zip ns ts'' - - dc = mkApp $ fdc:map Type ts2 ++ vs - - m = M.insert n dc (model s) - in - case not . Pre.null $ dcs of - True -> (SAT, s { model = M.union m (model s) }, b { arb_value_gen = av }) - False -> (UNSAT, s, b) - | otherwise = (UNSAT, s, b) - --- Various helper functions - -isExtCond :: PathCond -> Bool -isExtCond (ExtCond _ _) = True -isExtCond _ = False - -pcVarType :: TypeEnv -> [PathCond] -> Maybe Type -pcVarType tenv (AltCond _ (Var (Id _ t)) _:pc) = pcVarType' t tenv pc -pcVarType tenv (ConsCond _ (Var (Id _ t)) _:pc) = pcVarType' t tenv pc -pcVarType _ _ = Nothing - -pcVarType' :: Type -> TypeEnv -> [PathCond] -> Maybe Type -pcVarType' t tenv (AltCond _ (Var (Id _ t')) _:pc) = - if t == t' then pcVarType' t tenv pc else Nothing -pcVarType' t tenv (ConsCond _ (Var (Id _ t')) _:pc) = - if t == t' then pcVarType' t tenv pc else Nothing -pcVarType' n _ [] = Just n -pcVarType' _ _ _ = Nothing - -pcInCastType :: TypeEnv -> PathCond -> Type -pcInCastType _ (AltCond _ e _) = typeInCasts e -pcInCastType _ (ExtCond e _) = typeInCasts e -pcInCastType _ (ConsCond _ e _) = typeInCasts e -pcInCastType tenv (PCExists (Id _ t)) = typeStripCastType tenv t - -castReturnType :: Type -> Expr -> Expr -castReturnType t e = - let - te = typeOf e - tr = replaceReturnType te t - in - Cast e (te :~ tr) - -replaceReturnType :: Type -> Type -> Type -replaceReturnType (TyForAll b t) r = TyForAll b $ replaceReturnType t r -replaceReturnType (TyFun t1 t2@(TyFun _ _)) r = TyFun t1 $ replaceReturnType t2 r -replaceReturnType (TyFun t _) r = TyFun t r -replaceReturnType _ r = r diff --git a/src/G2/Solver/Converters.hs b/src/G2/Solver/Converters.hs --- a/src/G2/Solver/Converters.hs +++ b/src/G2/Solver/Converters.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} @@ -11,21 +12,30 @@ -- (3) SMTASTs/Sorts to Exprs/Types module G2.Solver.Converters ( toSMTHeaders - , toSolver + , toSolverText , exprToSMT --WOULD BE NICE NOT TO EXPORT THIS , typeToSMT --WOULD BE NICE NOT TO EXPORT THIS , toSolverAST --WOULD BE NICE NOT TO EXPORT THIS + , sortName , smtastToExpr , modelAsExpr + + , addHeaders + , checkConstraintsPC + , checkModelPC , checkConstraints - , checkModel + , solveConstraints + , constraintsToModelOrUnsatCore + , constraintsToModelOrUnsatCoreNoReset , SMTConverter (..) ) where -import Data.List +import qualified Data.HashMap.Lazy as HM +import qualified Data.HashSet as HS import qualified Data.Map as M -import Data.Maybe import Data.Monoid +import Data.Ratio import qualified Data.Text as T +import qualified Text.Builder as TB import G2.Language hiding (Assert, vars) import qualified G2.Language.ExprEnv as E @@ -36,122 +46,101 @@ -- | Used to describe the specific output format required by various solvers -- By defining these functions, we can automatically convert from the SMTHeader and SMTAST -- datatypes, to a form understandable by the solver. -class Solver con => SMTConverter con ast out io | con -> ast, con -> out, con -> io where - getIO :: con -> io +class Solver con => SMTConverter con where closeIO :: con -> IO () - empty :: con -> out - merge :: con -> out -> out -> out - - checkSat :: con -> io -> out -> IO Result - checkSatGetModel :: con -> io -> out -> [SMTHeader] -> [(SMTName, Sort)] -> IO (Result, Maybe SMTModel) - checkSatGetModelGetExpr :: con -> io -> out -> [SMTHeader] -> [(SMTName, Sort)] -> ExprEnv -> CurrExpr -> IO (Result, Maybe SMTModel, Maybe Expr) - - assert :: con -> ast -> out - varDecl :: con -> SMTName -> ast -> out - setLogic :: con -> Logic -> out + reset :: con -> IO () - (.>=) :: con -> ast -> ast -> ast - (.>) :: con -> ast -> ast -> ast - (.=) :: con -> ast -> ast -> ast - (./=) :: con -> ast -> ast -> ast - (.<) :: con -> ast -> ast -> ast - (.<=) :: con -> ast -> ast -> ast + checkSatInstr :: con -> IO () + maybeCheckSatResult :: con -> IO (Maybe (Result () () ())) - (.&&) :: con -> ast -> ast -> ast - (.||) :: con -> ast -> ast -> ast - (.!) :: con -> ast -> ast - (.=>) :: con -> ast -> ast -> ast - (.<=>) :: con -> ast -> ast -> ast + getModelInstrResult :: con -> [(SMTName, Sort)] -> IO SMTModel + getUnsatCoreInstrResult :: con -> IO UnsatCore - (.+) :: con -> ast -> ast -> ast - (.-) :: con -> ast -> ast -> ast - (.*) :: con -> ast -> ast -> ast - (./) :: con -> ast -> ast -> ast - smtQuot :: con -> ast -> ast -> ast - smtModulo :: con -> ast -> ast -> ast - smtSqrt :: con -> ast -> ast - neg :: con -> ast -> ast - strLen :: con -> ast -> ast - itor :: con -> ast -> ast + setProduceUnsatCores :: con -> IO () - ite :: con -> ast -> ast -> ast -> ast + addFormula :: con -> [SMTHeader] -> IO () - --values - int :: con -> Integer -> ast - float :: con -> Rational -> ast - double :: con -> Rational -> ast - char :: con -> Char -> ast - bool :: con -> Bool -> ast - cons :: con -> SMTName -> [ast] -> Sort -> ast - var :: con -> SMTName -> ast -> ast + checkSatNoReset :: con -> [SMTHeader] -> IO (Result () () ()) + checkSatGetModelOrUnsatCoreNoReset :: con -> [SMTHeader] -> [(SMTName, Sort)] -> IO (Result SMTModel UnsatCore ()) - --sorts - sortInt :: con -> ast - sortFloat :: con -> ast - sortDouble :: con -> ast - sortChar :: con -> ast - sortBool :: con -> ast + checkSat :: con -> [SMTHeader] -> IO (Result () () ()) + checkSat con headers = do + reset con + checkSatNoReset con headers + checkSatGetModel :: con -> [SMTHeader] -> [(SMTName, Sort)] -> IO (Result SMTModel () ()) + checkSatGetModelOrUnsatCore :: con -> [SMTHeader] -> [(SMTName, Sort)] -> IO (Result SMTModel UnsatCore ()) + checkSatGetModelOrUnsatCore con out get = do + reset con + setProduceUnsatCores con + checkSatGetModelOrUnsatCoreNoReset con out get - varName :: con -> SMTName -> Sort -> ast + -- Incremental + push :: con -> IO () + pop :: con -> IO () --- | Checks if the path constraints are satisfiable -checkConstraints :: SMTConverter con ast out io => con -> PathConds -> IO Result -checkConstraints con pc = do - let pc' = unsafeElimCast pc +addHeaders :: SMTConverter con => con -> [SMTHeader] -> IO () +addHeaders = addFormula - let headers = toSMTHeaders pc' - let formula = toSolver con headers +checkConstraintsPC :: SMTConverter con => con -> PathConds -> IO (Result () () ()) +checkConstraintsPC con pc = do + let headers = toSMTHeaders pc + checkConstraints con headers - checkSat con (getIO con) formula +checkConstraints :: SMTConverter con => con -> [SMTHeader] -> IO (Result () () ()) +checkConstraints = checkSat -- | Checks if the constraints are satisfiable, and returns a model if they are -checkModel :: SMTConverter con ast out io => ArbValueFunc -> con -> State t -> Bindings -> [Id] -> PathConds -> IO (Result, Maybe Model) -checkModel avf con s b is pc = return . fmap liftCasts =<< checkModel' avf con s b is pc +checkModelPC :: SMTConverter con => ArbValueFunc -> con -> State t -> Bindings -> [Id] -> PathConds -> IO (Result Model () ()) +checkModelPC avf con s b is pc = return . liftCasts =<< checkModel' avf con s b is pc -- | We split based on whether we are evaluating a ADT or a literal. -- ADTs can be solved using our efficient addADTs, while literals require -- calling an SMT solver. -checkModel' :: SMTConverter con ast out io => ArbValueFunc -> con -> State t -> Bindings -> [Id] -> PathConds -> IO (Result, Maybe Model) +checkModel' :: SMTConverter con => ArbValueFunc -> con -> State t -> Bindings -> [Id] -> PathConds -> IO (Result Model () ()) checkModel' _ _ s _ [] _ = do - return (SAT, Just $ model s) + return (SAT $ model s) checkModel' avf con s b (i:is) pc - | (idName i) `M.member` (model s) = checkModel' avf con s b is pc + | (idName i) `HM.member` (model s) = checkModel' avf con s b is pc | otherwise = do (m, av) <- getModelVal avf con s b i pc case m of - Just m' -> checkModel' avf con (s {model = M.union m' (model s)}) (b {arb_value_gen = av}) is pc - Nothing -> return (UNSAT, Nothing) + SAT m' -> checkModel' avf con (s {model = HM.union m' (model s)}) (b {arb_value_gen = av}) is pc + r -> return r -getModelVal :: SMTConverter con ast out io => ArbValueFunc -> con -> State t -> Bindings -> Id -> PathConds -> IO (Maybe Model, ArbValueGen) -getModelVal avf con s b (Id n _) pc = do - let (Just (Var (Id n' t))) = E.lookup n (expr_env s) +getModelVal :: SMTConverter con => ArbValueFunc -> con -> State t -> Bindings -> Id -> PathConds -> IO (Result Model () (), ArbValueGen) +getModelVal avf con (State { expr_env = eenv, type_env = tenv, known_values = kv }) b (Id n _) pc = do + let (Just (Var (Id n' t))) = E.lookup n eenv case PC.null pc of True -> let - (e, av) = avf t (type_env s) (arb_value_gen b) + (e, av) = avf t tenv (arb_value_gen b) in - return (Just $ M.singleton n' e, av) + return (SAT $ HM.singleton n' e, av) False -> do - m <- checkNumericConstraints con pc + m <- solveNumericConstraintsPC con kv tenv pc return (m, arb_value_gen b) -checkNumericConstraints :: SMTConverter con ast out io => con -> PathConds -> IO (Maybe Model) -checkNumericConstraints con pc = do +solveNumericConstraintsPC :: SMTConverter con => con -> KnownValues -> TypeEnv -> PathConds -> IO (Result Model () ()) +solveNumericConstraintsPC con kv tenv pc = do let headers = toSMTHeaders pc - let formula = toSolver con headers + let vs = map (\(n', srt) -> (nameToStr n', srt)) . HS.toList . pcVars $ pc - let vs = map (\(n', srt) -> (nameToStr n', srt)) . pcVars $ PC.toList pc + m <- solveConstraints con headers vs + case m of + SAT m' -> return . SAT $ modelAsExpr kv tenv m' + UNSAT () -> return $ UNSAT () + Unknown s () -> return $ Unknown s () - let io = getIO con - (_, m) <- checkSatGetModel con io formula headers vs +solveConstraints :: SMTConverter con => con -> [SMTHeader] -> [(SMTName, Sort)] -> IO (Result SMTModel () ()) +solveConstraints con headers vs = checkSatGetModel con headers vs - let m' = fmap modelAsExpr m +constraintsToModelOrUnsatCore :: SMTConverter con => con -> [SMTHeader] -> [(SMTName, Sort)] -> IO (Result SMTModel UnsatCore ()) +constraintsToModelOrUnsatCore = checkSatGetModelOrUnsatCore - case m' of - Just m'' -> return $ Just m'' - Nothing -> return Nothing +constraintsToModelOrUnsatCoreNoReset :: SMTConverter con => con -> [SMTHeader] -> [(SMTName, Sort)] -> IO (Result SMTModel UnsatCore ()) +constraintsToModelOrUnsatCoreNoReset = checkSatGetModelOrUnsatCoreNoReset -- | Here we convert from a State, to an SMTHeader. This SMTHeader can later -- be given to an SMT solver by using toSolver. @@ -163,11 +152,11 @@ toSMTHeaders = addSetLogic . toSMTHeaders' toSMTHeaders' :: PathConds -> [SMTHeader] -toSMTHeaders' pc = +toSMTHeaders' pc = let pc' = PC.toList pc - in - nub (pcVarDecls pc') + in + (pcVarDecls pc) ++ (pathConsToSMTHeaders pc') @@ -181,13 +170,15 @@ nia = isNIA xs nra = isNRA xs nira = isNIRA xs + uflia = isUFLIA xs sl = if lia then SetLogic QF_LIA else if lra then SetLogic QF_LRA else if lira then SetLogic QF_LIRA else if nia then SetLogic QF_NIA else if nra then SetLogic QF_NRA else - if nira then SetLogic QF_NIRA else SetLogic ALL + if nira then SetLogic QF_NIRA else + if uflia then SetLogic QF_UFLIA else SetLogic ALL in sl:xs @@ -197,6 +188,7 @@ isNIA' :: SMTAST -> All isNIA' (_ :* _) = All True isNIA' (_ :/ _) = All True +isNIA' (_ `Modulo` _) = All True isNIA' s = isLIA' s isLIA :: (ASTContainer m SMTAST) => m -> Bool @@ -278,13 +270,21 @@ isNIRA' (ItoR _) = All True isNIRA' s = All $ getAll (isNIA' s) || getAll (isNRA' s) +isUFLIA :: (ASTContainer m SMTAST) => m -> Bool +isUFLIA = getAll . evalASTs isUFLIA' + +isUFLIA' :: SMTAST -> All +isUFLIA' (Func _ xs) = mconcat $ map isUFLIA' xs +isUFLIA' s = isLIA' s + isCore' :: SMTAST -> All isCore' (_ := _) = All True -isCore' (_ :&& _) = All True -isCore' (_ :|| _) = All True +isCore' (SmtAnd _) = All True +isCore' (SmtOr _) = All True isCore' ((:!) _) = All True isCore' (_ :=> _) = All True isCore' (_ :<=> _) = All True +isCore' (Func _ _) = All True isCore' (VBool _) = All True isCore' (V _ s) = All $ isCoreSort s isCore' _ = All False @@ -296,32 +296,34 @@ ------------------------------------------------------------------------------- pathConsToSMTHeaders :: [PathCond] -> [SMTHeader] -pathConsToSMTHeaders = map Assert . mapMaybe pathConsToSMT +pathConsToSMTHeaders = map pathConsToSMT -pathConsToSMT :: PathCond -> Maybe SMTAST -pathConsToSMT (AltCond l e b) = +pathConsToSMT :: PathCond -> SMTHeader +pathConsToSMT (MinimizePC e) = Minimize $ exprToSMT e +pathConsToSMT (SoftPC pc) = AssertSoft (pathConsToSMT' pc) Nothing +pathConsToSMT pc = Assert (pathConsToSMT' pc) + +pathConsToSMT' :: PathCond -> SMTAST +pathConsToSMT' (AltCond l e b) = let exprSMT = exprToSMT e altSMT = altToSMT l e in - Just $ if b then exprSMT := altSMT else (:!) (exprSMT := altSMT) -pathConsToSMT (ExtCond e b) = - let - exprSMT = exprToSMT e - in - Just $ if b then exprSMT else (:!) exprSMT -pathConsToSMT (ConsCond (DataCon (Name "True" _ _ _) _) e b) = + if b then exprSMT := altSMT else (:!) (exprSMT := altSMT) +pathConsToSMT' (ExtCond e b) = let exprSMT = exprToSMT e in - Just $ if b then exprSMT else (:!) exprSMT -pathConsToSMT (ConsCond (DataCon (Name "False" _ _ _) _) e b) = + if b then exprSMT else (:!) exprSMT +pathConsToSMT' (AssumePC (Id n t) num pc) = let - exprSMT = exprToSMT e + idSMT = V (nameToStr n) (typeToSMT t) -- exprToSMT (Var i) + intSMT = VInt $ toInteger num -- exprToSMT (Lit (LitInt $ toInteger num)) + pcSMT = map (pathConsToSMT' . PC.unhashedPC) $ HS.toList pc in - Just $ if b then (:!) $ exprSMT else exprSMT -pathConsToSMT (ConsCond (DataCon _ _) _ _) = error "Non-bool DataCon in pathConsToSMT" -pathConsToSMT (PCExists _) = Nothing + (idSMT := intSMT) :=> SmtAnd pcSMT +pathConsToSMT' (MinimizePC _) = error "pathConsToSMT': unsupported nesting of MinimizePC." +pathConsToSMT' (SoftPC _) = error "pathConsToSMT': unsupported nesting of SoftPC." exprToSMT :: Expr -> SMTAST exprToSMT (Var (Id n t)) = V (nameToStr n) (typeToSMT t) @@ -365,15 +367,20 @@ funcToSMT1Prim :: Primitive -> Expr -> SMTAST funcToSMT1Prim Negate a = Neg (exprToSMT a) +funcToSMT1Prim Abs e = AbsSMT (exprToSMT e) funcToSMT1Prim SqRt e = SqrtSMT (exprToSMT e) funcToSMT1Prim Not e = (:!) (exprToSMT e) funcToSMT1Prim IntToFloat e = ItoR (exprToSMT e) funcToSMT1Prim IntToDouble e = ItoR (exprToSMT e) +funcToSMT1Prim IntToString e = FromInt (exprToSMT e) +funcToSMT1Prim Chr e = FromCode (exprToSMT e) +funcToSMT1Prim OrdChar e = ToCode (exprToSMT e) +funcToSMT1Prim StrLen e = StrLenSMT (exprToSMT e) funcToSMT1Prim err _ = error $ "funcToSMT1Prim: invalid Primitive " ++ show err funcToSMT2Prim :: Primitive -> Expr -> Expr -> SMTAST -funcToSMT2Prim And a1 a2 = exprToSMT a1 :&& exprToSMT a2 -funcToSMT2Prim Or a1 a2 = exprToSMT a1 :|| exprToSMT a2 +funcToSMT2Prim And a1 a2 = SmtAnd [exprToSMT a1, exprToSMT a2] +funcToSMT2Prim Or a1 a2 = SmtOr [exprToSMT a1, exprToSMT a2] funcToSMT2Prim Implies a1 a2 = exprToSMT a1 :=> exprToSMT a2 funcToSMT2Prim Iff a1 a2 = exprToSMT a1 :<=> exprToSMT a2 funcToSMT2Prim Ge a1 a2 = exprToSMT a1 :>= exprToSMT a2 @@ -388,6 +395,9 @@ funcToSMT2Prim Div a1 a2 = exprToSMT a1 :/ exprToSMT a2 funcToSMT2Prim Quot a1 a2 = exprToSMT a1 `QuotSMT` exprToSMT a2 funcToSMT2Prim Mod a1 a2 = exprToSMT a1 `Modulo` exprToSMT a2 +funcToSMT2Prim Rem a1 a2 = exprToSMT a1 :- ((exprToSMT a1 `QuotSMT` exprToSMT a2) :* exprToSMT a2) -- TODO: more efficient encoding? +funcToSMT2Prim RationalToDouble a1 a2 = exprToSMT a1 :/ exprToSMT a2 +funcToSMT2Prim StrAppend a1 a2 = exprToSMT a1 :++ exprToSMT a2 funcToSMT2Prim op lhs rhs = error $ "funcToSMT2Prim: invalid case with (op, lhs, rhs): " ++ show (op, lhs, rhs) altToSMT :: Lit -> Expr -> SMTAST @@ -397,31 +407,21 @@ altToSMT (LitChar c) _ = VChar c altToSMT am _ = error $ "Unhandled " ++ show am -createVarDecls :: [(Name, Sort)] -> [SMTHeader] -createVarDecls [] = [] -createVarDecls ((n,SortChar):xs) = +createUniqVarDecls :: [(Name, Sort)] -> [SMTHeader] +createUniqVarDecls [] = [] +createUniqVarDecls ((n,SortChar):xs) = let - lenAssert = Assert $ StrLen (V (nameToStr n) SortChar) := VInt 1 + lenAssert = Assert $ StrLenSMT (V (nameToStr n) SortChar) := VInt 1 in - VarDecl (nameToStr n) SortChar:lenAssert:createVarDecls xs -createVarDecls ((n,s):xs) = VarDecl (nameToStr n) s:createVarDecls xs + VarDecl (nameToBuilder n) SortChar:lenAssert:createUniqVarDecls xs +createUniqVarDecls ((n,s):xs) = VarDecl (nameToBuilder n) s:createUniqVarDecls xs -pcVarDecls :: [PathCond] -> [SMTHeader] -pcVarDecls = createVarDecls . pcVars +pcVarDecls :: PathConds -> [SMTHeader] +pcVarDecls = createUniqVarDecls . HS.toList . pcVars -- Get's all variable required for a list of `PathCond` -pcVars :: [PathCond] -> [(Name, Sort)] -pcVars [] = [] -pcVars (PCExists i:xs) = idToNameSort i : pcVars xs -pcVars (AltCond _ e _:xs) = vars e ++ pcVars xs -pcVars (p:xs)= vars p ++ pcVars xs - -vars :: (ASTContainer m Expr) => m -> [(Name, Sort)] -vars = evalASTs vars' - where - vars' :: Expr -> [(Name, Sort)] - vars' (Var i) = [idToNameSort i] - vars' _ = [] +pcVars :: PathConds -> HS.HashSet (Name, Sort) +pcVars = HS.map idToNameSort . PC.allIds idToNameSort :: Id -> (Name, Sort) idToNameSort (Id n t) = (n, typeToSMT t) @@ -435,75 +435,176 @@ typeToSMT TyLitFloat = SortFloat typeToSMT TyLitChar = SortChar typeToSMT (TyCon (Name "Bool" _ _ _) _) = SortBool -typeToSMT (TyForAll (AnonTyBndr _) t) = typeToSMT t +#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0) +typeToSMT (TyApp (TyCon (Name "List" _ _ _) _) (TyCon (Name "Char" _ _ _) _)) = SortString +#else +typeToSMT (TyApp (TyCon (Name "[]" _ _ _) _) (TyCon (Name "Char" _ _ _) _)) = SortString +#endif typeToSMT t = error $ "Unsupported type in typeToSMT: " ++ show t -toSolver :: SMTConverter con ast out io => con -> [SMTHeader] -> out -toSolver con [] = empty con -toSolver con (Assert ast:xs) = - merge con (assert con $ toSolverAST con ast) (toSolver con xs) -toSolver con (VarDecl n s:xs) = merge con (toSolverVarDecl con n s) (toSolver con xs) -toSolver con (SetLogic lgc:xs) = merge con (toSolverSetLogic con lgc) (toSolver con xs) +merge :: TB.Builder -> TB.Builder -> TB.Builder +merge x y = x <> "\n" <> y -toSolverAST :: SMTConverter con ast out io => con -> SMTAST -> ast -toSolverAST con (x :>= y) = (.>=) con (toSolverAST con x) (toSolverAST con y) -toSolverAST con (x :> y) = (.>) con (toSolverAST con x) (toSolverAST con y) -toSolverAST con (x := y) = (.=) con (toSolverAST con x) (toSolverAST con y) -toSolverAST con (x :/= y) = (./=) con (toSolverAST con x) (toSolverAST con y) -toSolverAST con (x :< y) = (.<) con (toSolverAST con x) (toSolverAST con y) -toSolverAST con (x :<= y) = (.<=) con (toSolverAST con x) (toSolverAST con y) +comment :: String -> TB.Builder +comment s = "; " <> TB.string s -toSolverAST con (x :&& y) = (.&&) con (toSolverAST con x) (toSolverAST con y) -toSolverAST con (x :|| y) = (.||) con (toSolverAST con x) (toSolverAST con y) -toSolverAST con ((:!) x) = (.!) con $ toSolverAST con x -toSolverAST con (x :=> y) = (.=>) con (toSolverAST con x) (toSolverAST con y) -toSolverAST con (x :<=> y) = (.<=>) con (toSolverAST con x) (toSolverAST con y) +assertSoftSolver :: TB.Builder -> Maybe T.Text -> TB.Builder +assertSoftSolver ast Nothing = function1 "assert-soft" ast +assertSoftSolver ast (Just lab) = "(assert-soft " <> ast <> " :id " <> TB.text lab <> ")" -toSolverAST con (x :+ y) = (.+) con (toSolverAST con x) (toSolverAST con y) -toSolverAST con (x :- y) = (.-) con (toSolverAST con x) (toSolverAST con y) -toSolverAST con (x :* y) = (.*) con (toSolverAST con x) (toSolverAST con y) -toSolverAST con (x :/ y) = (./) con (toSolverAST con x) (toSolverAST con y) -toSolverAST con (x `QuotSMT` y) = smtQuot con (toSolverAST con x) (toSolverAST con y) -toSolverAST con (x `Modulo` y) = smtModulo con (toSolverAST con x) (toSolverAST con y) -toSolverAST con (SqrtSMT x) = smtSqrt con $ toSolverAST con x -toSolverAST con (Neg x) = neg con $ toSolverAST con x -toSolverAST con (StrLen x) = strLen con $ toSolverAST con x -toSolverAST con (ItoR x) = itor con $ toSolverAST con x +defineFun :: String -> [(String, Sort)] -> Sort -> SMTAST -> TB.Builder +defineFun fn ars ret body = + "(define-fun " <> (TB.string fn) <> " (" + <> TB.intercalate " " (map (\(n, s) -> "(" <> TB.string n <> " " <> sortName s <> ")") ars) <> ")" + <> " (" <> sortName ret <> ") " <> toSolverAST body <> ")" -toSolverAST con (Ite x y z) = - ite con (toSolverAST con x) (toSolverAST con y) (toSolverAST con z) +declareFun :: String -> [Sort] -> Sort -> TB.Builder +declareFun fn ars ret = + "(declare-fun " <> TB.string fn <> " (" + <> TB.intercalate " " (map sortName ars) <> ")" + <> " (" <> sortName ret <> "))" -toSolverAST con (VInt i) = int con i -toSolverAST con (VFloat f) = float con f -toSolverAST con (VDouble i) = double con i -toSolverAST con (VChar c) = char con c -toSolverAST con (VBool b) = bool con b -toSolverAST con (V n s) = varName con n s -toSolverAST _ ast = error $ "toSolverAST: invalid SMTAST: " ++ show ast +toSolverText :: [SMTHeader] -> TB.Builder +toSolverText [] = "" +toSolverText (Assert ast:xs) = + merge (function1 "assert" $ toSolverAST ast) (toSolverText xs) +toSolverText (AssertSoft ast lab:xs) = + merge (assertSoftSolver (toSolverAST ast) lab) (toSolverText xs) +toSolverText (Minimize ast:xs) = + merge (function1 "minimize" $ toSolverAST ast) (toSolverText xs) +toSolverText (DefineFun f ars ret body:xs) = + merge (defineFun f ars ret body) (toSolverText xs) +toSolverText (DeclareFun f ars ret:xs) = + merge (declareFun f ars ret) (toSolverText xs) +toSolverText (VarDecl n s:xs) = merge (toSolverVarDecl n s) (toSolverText xs) +toSolverText (SetLogic lgc:xs) = merge (toSolverSetLogic lgc) (toSolverText xs) +toSolverText (Comment c:xs) = merge (comment c) (toSolverText xs) -toSolverVarDecl :: SMTConverter con ast out io => con -> SMTName -> Sort -> out -toSolverVarDecl con n s = varDecl con n (sortName con s) +toSolverAST :: SMTAST -> TB.Builder +toSolverAST (x :>= y) = function2 ">=" (toSolverAST x) (toSolverAST y) +toSolverAST (x :> y) = function2 ">" (toSolverAST x) (toSolverAST y) +toSolverAST (x := y) = function2 "=" (toSolverAST x) (toSolverAST y) +toSolverAST (x :/= y) = function1 "not" $ function2 "=" (toSolverAST x) (toSolverAST y) +toSolverAST (x :< y) = function2 "<" (toSolverAST x) (toSolverAST y) +toSolverAST (x :<= y) = function2 "<=" (toSolverAST x) (toSolverAST y) -sortName :: SMTConverter con ast out io => con -> Sort -> ast -sortName con SortInt = sortInt con -sortName con SortFloat = sortFloat con -sortName con SortDouble = sortDouble con -sortName con SortChar = sortChar con -sortName con SortBool = sortBool con +toSolverAST (SmtAnd []) = "true" +toSolverAST (SmtAnd [x]) = toSolverAST x +toSolverAST (SmtAnd xs) = functionList "and" $ map (toSolverAST) xs +toSolverAST (SmtOr []) = "false" +toSolverAST (SmtOr [x]) = toSolverAST x +toSolverAST (SmtOr xs) = functionList "or" $ map (toSolverAST) xs -toSolverSetLogic :: SMTConverter con ast out io => con -> Logic -> out -toSolverSetLogic = setLogic +toSolverAST ((:!) x) = function1 "not" $ toSolverAST x +toSolverAST (x :=> y) = function2 "=>" (toSolverAST x) (toSolverAST y) +toSolverAST (x :<=> y) = function2 "=" (toSolverAST x) (toSolverAST y) +toSolverAST (x :+ y) = function2 "+" (toSolverAST x) (toSolverAST y) +toSolverAST (x :- y) = function2 "-" (toSolverAST x) (toSolverAST y) +toSolverAST (x :* y) = function2 "*" (toSolverAST x) (toSolverAST y) +toSolverAST (x :/ y) = function2 "/" (toSolverAST x) (toSolverAST y) +toSolverAST (x `QuotSMT` y) = function2 "div" (toSolverAST x) (toSolverAST y) +toSolverAST (x `Modulo` y) = function2 "mod" (toSolverAST x) (toSolverAST y) +toSolverAST (AbsSMT x) = "(abs " <> toSolverAST x <> ")" +toSolverAST (SqrtSMT x) = "(^ " <> toSolverAST x <> " 0.5)" +toSolverAST (Neg x) = function1 "-" $ toSolverAST x + +toSolverAST (ArrayConst v indS valS) = + let + sort_arr = "(Array " <> sortName indS <> " " <> sortName valS <> ")" + in + "((as const " <> sort_arr <> ") " <> (toSolverAST v) <> ")" + +toSolverAST (ArraySelect arr ind) = + function2 "select" (toSolverAST arr) (toSolverAST ind) + +toSolverAST (ArrayStore arr ind val) = + function3 "store" (toSolverAST arr) (toSolverAST ind) (toSolverAST val) + +toSolverAST (Func n xs) = smtFunc n $ map (toSolverAST) xs + +toSolverAST (x :++ y) = function2 "str.++" (toSolverAST x) (toSolverAST y) +toSolverAST (FromInt x) = function1 "str.from_int" $ toSolverAST x +toSolverAST (StrLenSMT x) = function1 "str.len" $ toSolverAST x +toSolverAST (ItoR x) = function1 "to_real" $ toSolverAST x + +toSolverAST (Ite x y z) = + function3 "ite" (toSolverAST x) (toSolverAST y) (toSolverAST z) + +toSolverAST (FromCode chr) = function1 "str.from_code" (toSolverAST chr) +toSolverAST (ToCode chr) = function1 "str.to_code" (toSolverAST chr) + +toSolverAST (VInt i) = if i >= 0 then showText i else "(- " <> showText (abs i) <> ")" +toSolverAST (VFloat f) = "(/ " <> showText (numerator f) <> " " <> showText (denominator f) <> ")" +toSolverAST (VDouble d) = "(/ " <> showText (numerator d) <> " " <> showText (denominator d) <> ")" +toSolverAST (VChar c) = "\"" <> TB.string [c] <> "\"" +toSolverAST (VBool b) = if b then "true" else "false" +toSolverAST (V n _) = TB.string n + +toSolverAST (Named x n) = "(! " <> toSolverAST x <> " :named " <> TB.string n <> ")" + +toSolverAST ast = error $ "toSolverAST: invalid SMTAST: " ++ show ast + +smtFunc :: String -> [TB.Builder] -> TB.Builder +smtFunc n [] = TB.string n +smtFunc n xs = "(" <> TB.string n <> " " <> TB.intercalate " " xs <> ")" + +{-# INLINE showText #-} +showText :: Show a => a -> TB.Builder +showText = TB.string . show + +functionList :: TB.Builder -> [TB.Builder] -> TB.Builder +functionList f xs = "(" <> f <> " " <> (TB.intercalate " " xs) <> ")" + +function1 :: TB.Builder -> TB.Builder -> TB.Builder +function1 f a = "(" <> f <> " " <> a <> ")" + +{-# INLINE function2 #-} +function2 :: TB.Builder -> TB.Builder -> TB.Builder -> TB.Builder +function2 f a b = "(" <> f <> " " <> a <> " " <> b <> ")" + +function3 :: TB.Builder -> TB.Builder -> TB.Builder -> TB.Builder -> TB.Builder +function3 f a b c = "(" <> f <> " " <> a <> " " <> b <> " " <> c <> ")" + +toSolverVarDecl :: SMTNameBldr -> Sort -> TB.Builder +toSolverVarDecl n s = "(declare-const " <> n <> " " <> sortName s <> ")" + +sortName :: Sort -> TB.Builder +sortName SortInt = "Int" +sortName SortFloat = "Real" +sortName SortDouble = "Real" +sortName SortString = "String" +sortName SortChar = "String" +sortName SortBool = "Bool" +sortName (SortArray ind val) = "(Array " <> sortName ind <> " " <> sortName val <> ")" +sortName _ = error "sortName: unsupported Sort" + +toSolverSetLogic :: Logic -> TB.Builder +toSolverSetLogic lgc = + let + s = case lgc of + QF_LIA -> "QF_LIA" + QF_LRA -> "QF_LRA" + QF_LIRA -> "QF_LIRA" + QF_NIA -> "QF_NIA" + QF_NRA -> "QF_NRA" + QF_NIRA -> "QF_NIRA" + QF_UFLIA -> "QF_UFLIA" + _ -> "ALL" + in + "(set-logic " <> s <> ")" + -- | Converts an `SMTAST` to an `Expr`. -smtastToExpr :: SMTAST -> Expr -smtastToExpr (VInt i) = (Lit $ LitInt i) -smtastToExpr (VFloat f) = (Lit $ LitFloat f) -smtastToExpr (VDouble d) = (Lit $ LitDouble d) -smtastToExpr (VBool b) = - Data (DataCon (Name (T.pack $ show b) Nothing 0 Nothing) (TyCon (Name "Bool" Nothing 0 Nothing) TYPE)) -smtastToExpr (VChar c) = Lit $ LitChar c -smtastToExpr (V n s) = Var $ Id (strToName n) (sortToType s) -smtastToExpr _ = error "Conversion of this SMTAST to an Expr not supported." +smtastToExpr :: KnownValues -> TypeEnv -> SMTAST -> Expr +smtastToExpr _ _ (VInt i) = (Lit $ LitInt i) +smtastToExpr _ _ (VFloat f) = (Lit $ LitFloat f) +smtastToExpr _ _ (VDouble d) = (Lit $ LitDouble d) +smtastToExpr kv _ (VBool True) = mkTrue kv +smtastToExpr kv _ (VBool False) = mkFalse kv +smtastToExpr kv tenv (VString cs) = mkG2List kv tenv (tyChar kv) $ map (App (mkDCChar kv tenv) . Lit . LitChar) cs +smtastToExpr _ _ (VChar c) = Lit $ LitChar c +smtastToExpr _ _ (V n s) = Var $ Id (certainStrToName n) (sortToType s) +smtastToExpr _ _ _ = error "Conversion of this SMTAST to an Expr not supported." -- | Converts a `Sort` to an `Type`. sortToType :: Sort -> Type @@ -512,7 +613,14 @@ sortToType (SortDouble) = TyLitDouble sortToType (SortChar) = TyLitChar sortToType (SortBool) = TyCon (Name "Bool" Nothing 0 Nothing) TYPE +sortToType _ = error "Conversion of this Sort to a Type not supported." -- | Coverts an `SMTModel` to a `Model`. -modelAsExpr :: SMTModel -> Model -modelAsExpr = M.mapKeys strToName . M.map smtastToExpr +modelAsExpr :: KnownValues -> TypeEnv ->SMTModel -> Model +modelAsExpr kv tenv = HM.fromList . M.toList . M.mapKeys strToName . M.map (smtastToExpr kv tenv) + +certainStrToName :: String -> Name +certainStrToName s = + case maybe_StrToName s of + Just n -> n + Nothing -> Name (T.pack s) Nothing 0 Nothing diff --git a/src/G2/Solver/Interface.hs b/src/G2/Solver/Interface.hs --- a/src/G2/Solver/Interface.hs +++ b/src/G2/Solver/Interface.hs @@ -15,75 +15,94 @@ import G2.Solver.Converters import G2.Solver.Solver -import Data.Maybe (mapMaybe) -import qualified Data.Map as M +import Data.Function +import qualified Data.List as L +import Data.Maybe (mapMaybe, isJust, fromJust) +import qualified Data.HashMap.Lazy as HM +import qualified Data.Sequence as S -subModel :: State t -> Bindings -> ([Expr], Expr, Maybe FuncCall) +subModel :: State t -> Bindings -> ([Expr], Expr, Maybe FuncCall, S.Seq Expr) subModel (State { expr_env = eenv , curr_expr = CurrExpr _ cexpr , assert_ids = ais , type_classes = tc - , model = m}) + , model = m + , sym_gens = gens }) (Bindings {input_names = inputNames}) = let - ais' = fmap (subVarFuncCall m eenv tc) ais + ais' = fmap (subVarFuncCall True m eenv tc) ais - -- We do not inline Lambdas, because higher order function arguments + -- We do not inline all Lambdas, because higher order function arguments -- get preinserted into the model. -- See [Higher-Order Model] in G2.Execution.Reducers - is = mapMaybe (\n -> case E.lookup n eenv of + is = mapMaybe toVars inputNames + gs = fmap fromJust . S.filter isJust $ fmap toVars gens + + sv = subVar False m eenv tc (is, cexpr, ais', gs) + in + untilEq (simplifyLams . pushCaseAppArgIn) sv + where + toVars n = case E.lookup n eenv of Just e@(Lam _ _ _) -> Just . Var $ Id n (typeOf e) Just e -> Just e - Nothing -> Nothing) inputNames - in - filterTC tc $ subVar m eenv tc (is, cexpr, ais') + Nothing -> Nothing -subVarFuncCall :: Model -> ExprEnv -> TypeClasses -> FuncCall -> FuncCall -subVarFuncCall em eenv tc fc@(FuncCall {arguments = ars}) = - subVar em eenv tc $ fc {arguments = filter (not . isTC tc) ars} + untilEq f x = let x' = f x in if x == x' then x' else untilEq f x' -subVar :: (ASTContainer m Expr) => Model -> ExprEnv -> TypeClasses -> m -> m -subVar em eenv tc = modifyContainedASTs (subVar' em eenv tc []) . filterTC tc +subVarFuncCall :: Bool -> Model -> ExprEnv -> TypeClasses -> FuncCall -> FuncCall +subVarFuncCall inLam em eenv tc fc@(FuncCall {arguments = ars}) = + subVar inLam em eenv tc $ fc {arguments = filter (not . isTC tc) ars} -subVar' :: Model -> ExprEnv -> TypeClasses -> [Id] -> Expr -> Expr -subVar' em eenv tc is v@(Var i@(Id n _)) +subVar :: (ASTContainer m Expr) => Bool -> Model -> ExprEnv -> TypeClasses -> m -> m +subVar inLam em eenv tc = modifyContainedASTs (subVar' inLam em eenv tc []) + +subVar' :: Bool -> Model -> ExprEnv -> TypeClasses -> [Id] -> Expr -> Expr +subVar' inLam em eenv tc is v@(Var i@(Id n _)) | i `notElem` is - , Just e <- M.lookup n em = - subVar' em eenv tc (i:is) $ filterTC tc e + , Just e <- HM.lookup n em = + subVar' inLam em eenv tc (i:is) e | i `notElem` is , Just e <- E.lookup n eenv - , (isExprValueForm eenv e && notLam e) || isApp e || isVar e = - subVar' em eenv tc (i:is) $ filterTC tc e + -- We want to inline a lambda only if inLam is true (we want to inline all lambdas), + -- or if it's module is Nothing (and its name is likely uninteresting/unknown to the user) + , (isExprValueForm eenv e && (notLam e || inLam || nameModule n == Nothing)) || isApp e || isVar e || isLitCase e = + subVar' inLam em eenv tc (i:is) e | otherwise = v -subVar' em eenv tc is e = modifyChildren (subVar' em eenv tc is) e - -notLam :: Expr -> Bool -notLam (Lam _ _ _) = False -notLam _ = True +subVar' inLam mdl eenv tc is cse@(Case e _ _ as) = + case subVar' inLam mdl eenv tc is e of + Lit l + | Just (Alt _ ae) <- L.find (\(Alt (LitAlt l') _) -> l == l') as -> + subVar' inLam mdl eenv tc is ae + _ -> modifyChildren (subVar' inLam mdl eenv tc is) cse +subVar' inLam em eenv tc is e = modifyChildren (subVar' inLam em eenv tc is) e isApp :: Expr -> Bool isApp (App _ _) = True isApp _ = False +notLam :: Expr -> Bool +notLam (Lam _ _ _) = False +notLam _ = True + isVar :: Expr -> Bool isVar (Var _) = True isVar _ = False -filterTC :: ASTContainer m Expr => TypeClasses -> m -> m -filterTC tc = modifyASTs (filterTC' tc) - -filterTC' :: TypeClasses -> Expr -> Expr -filterTC' tc a@(App e e') = - case tcCenter tc $ typeOf e' of - True -> filterTC' tc e - False -> a -filterTC' _ e = e - -tcCenter :: TypeClasses -> Type -> Bool -tcCenter tc (TyCon n _) = isTypeClassNamed n tc -tcCenter tc (TyFun t _) = tcCenter tc t -tcCenter _ _ = False +isLitCase :: Expr -> Bool +isLitCase (Case e _ _ _) = isPrimType (typeOf e) +isLitCase _ = False isTC :: TypeClasses -> Expr -> Bool isTC tc (Var (Id _ (TyCon n _))) = isTypeClassNamed n tc isTC _ _ = False + +-- | Rewrites a case statement returning a function type, and applied to a variable argument, +-- so that the variable argument is moved into each branch of the case statement. +-- This composes with `simplifyLams` to get better simplication for symbolic function concretizations. +pushCaseAppArgIn :: ASTContainer c Expr => c -> c +pushCaseAppArgIn = modifyASTs pushCaseAppArgIn' + +pushCaseAppArgIn' :: Expr -> Expr +pushCaseAppArgIn' (App (Case scrut bind t as) v@(Var _)) = + Case scrut bind t $ map (\(Alt am e) -> Alt am (App e v) ) as +pushCaseAppArgIn' e = e diff --git a/src/G2/Solver/Language.hs b/src/G2/Solver/Language.hs --- a/src/G2/Solver/Language.hs +++ b/src/G2/Solver/Language.hs @@ -3,6 +3,7 @@ {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE DeriveGeneric #-} module G2.Solver.Language ( module G2.Solver.Language @@ -12,59 +13,91 @@ import G2.Language.AST import G2.Solver.Solver +import GHC.Generics (Generic) +import Data.Hashable +import qualified Data.HashSet as HS import qualified Data.Map as M +import Text.Builder +import qualified Data.Text as T +type SMTNameBldr = Builder type SMTName = String --- | These define the two kinds of top level calls we give to the SMT solver. --- An assertion says the given SMTAST is true --- A sort decl declares a new sort. -data SMTHeader = Assert SMTAST - | VarDecl SMTName Sort +-- | These define the kinds of top level calls we give to the SMT solver. +data SMTHeader = Assert !SMTAST + | AssertSoft !SMTAST (Maybe T.Text) + | Minimize !SMTAST + | DefineFun SMTName [(SMTName, Sort)] Sort !SMTAST + | DeclareFun SMTName [Sort] Sort + | VarDecl SMTNameBldr Sort | SetLogic Logic - deriving (Show, Eq) + | Comment String + deriving (Show) -- | Various logics supported by (some) SMT solvers -data Logic = ALL | QF_LIA | QF_LRA | QF_NIA | QF_NRA | QF_LIRA | QF_NIRA deriving (Show, Eq) +data Logic = ALL + | QF_LIA + | QF_LRA + | QF_NIA + | QF_NRA + | QF_LIRA + | QF_NIRA + | QF_UFLIA + deriving (Show, Eq) -- | These correspond to first order logic, arithmetic operators, and variables, as supported by an SMT Solver -- Its use should be confined to interactions with G2.SMT.* -data SMTAST = (:>=) SMTAST SMTAST - | (:>) SMTAST SMTAST - | (:=) SMTAST SMTAST - | (:/=) SMTAST SMTAST - | (:<) SMTAST SMTAST - | (:<=) SMTAST SMTAST +data SMTAST = (:>=) !SMTAST !SMTAST + | (:>) !SMTAST !SMTAST + | (:=) !SMTAST !SMTAST + | (:/=) !SMTAST !SMTAST + | (:<) !SMTAST !SMTAST + | (:<=) !SMTAST !SMTAST - | (:&&) SMTAST SMTAST - | (:||) SMTAST SMTAST - | (:!) SMTAST - | (:=>) SMTAST SMTAST - | (:<=>) SMTAST SMTAST + | SmtAnd ![SMTAST] + | SmtOr ![SMTAST] + | (:!) !SMTAST + | (:=>) !SMTAST !SMTAST + | (:<=>) !SMTAST !SMTAST - | (:+) SMTAST SMTAST - | (:-) SMTAST SMTAST -- ^ Subtraction - | (:*) SMTAST SMTAST - | (:/) SMTAST SMTAST - | SqrtSMT SMTAST - | QuotSMT SMTAST SMTAST - | Modulo SMTAST SMTAST - | Neg SMTAST -- ^ Unary negation + | (:+) !SMTAST !SMTAST + | (:-) !SMTAST !SMTAST -- ^ Subtraction + | (:*) !SMTAST !SMTAST + | (:/) !SMTAST !SMTAST + | AbsSMT !SMTAST + | SqrtSMT !SMTAST + | QuotSMT !SMTAST !SMTAST + | Modulo !SMTAST !SMTAST + | Neg !SMTAST -- ^ Unary negation - | StrLen SMTAST + | ArrayConst !SMTAST Sort Sort + | ArrayStore !SMTAST !SMTAST !SMTAST + | ArraySelect !SMTAST !SMTAST - | Ite SMTAST SMTAST SMTAST - | SLet (SMTName, SMTAST) SMTAST + | Func SMTName ![SMTAST] -- ^ Interpreted function + | (:++) !SMTAST !SMTAST -- ^ String append + | FromInt !SMTAST -- ^ Convert Ints to Strings + | StrLenSMT !SMTAST + + | Ite !SMTAST !SMTAST !SMTAST + | SLet (SMTName, SMTAST) !SMTAST + + | FromCode !SMTAST + | ToCode !SMTAST + | VInt Integer | VFloat Rational | VDouble Rational | VChar Char + | VString String | VBool Bool | V SMTName Sort - | ItoR SMTAST -- ^ Integer to real conversion + | ItoR !SMTAST -- ^ Integer to real conversion + + | Named !SMTAST SMTName -- ^ Name a piece of the SMTAST, allowing it to be returned in unsat cores deriving (Show, Eq) -- | Every `SMTAST` has a `Sort` @@ -72,14 +105,64 @@ | SortFloat | SortDouble | SortChar + | SortString | SortBool - deriving (Show, Eq) + | SortArray Sort Sort + | SortFunc [Sort] Sort + deriving (Show, Eq, Ord, Generic) -isSat :: Result -> Bool -isSat SAT = True +instance Hashable Sort + +(.=.) :: SMTAST -> SMTAST -> SMTAST +x .=. y + | x == y = VBool True + | otherwise = x := y + +(.&&.) :: SMTAST -> SMTAST -> SMTAST +(VBool True) .&&. x = x +x .&&. (VBool True) = x +(VBool False) .&&. _ = VBool False +_ .&&. (VBool False) = VBool False +x .&&. y = SmtAnd [x, y] + +(.||.) :: SMTAST -> SMTAST -> SMTAST +(VBool True) .||. _ = VBool True +_ .||. (VBool True) = VBool True +(VBool False) .||. x = x +x .||. (VBool False) = x +x .||. y = SmtOr [x, y] + +mkSMTAnd :: [SMTAST] -> SMTAST +mkSMTAnd = SmtAnd + +mkSMTOr :: [SMTAST] -> SMTAST +mkSMTOr = SmtOr + +isSat :: Result m u um -> Bool +isSat (SAT _) = True isSat _ = False +mkSMTEmptyArray :: Sort -> Sort -> SMTAST +mkSMTEmptyArray = ArrayConst (VBool False) + +mkSMTUniversalArray :: Sort -> Sort -> SMTAST +mkSMTUniversalArray = ArrayConst (VBool True) + +mkSMTUnion :: SMTAST -> SMTAST -> SMTAST +mkSMTUnion s1 s2 = Func "union" [s1, s2] + +mkSMTIntersection :: SMTAST -> SMTAST -> SMTAST +mkSMTIntersection s1 s2 = Func "intersection" [s1, s2] + +mkSMTSingleton :: SMTAST -> Sort -> Sort -> SMTAST +mkSMTSingleton mem srt srt2 = + ArrayStore (ArrayConst (VBool False) srt srt2) mem (VBool True) + +mkSMTIsSubsetOf :: SMTAST -> SMTAST -> SMTAST +mkSMTIsSubsetOf s1 s2 = Func "subset" [s1, s2] + type SMTModel = M.Map SMTName SMTAST +type UnsatCore = HS.HashSet SMTName instance AST SMTAST where children (x :>= y) = [x, y] @@ -89,8 +172,8 @@ children (x :< y) = [x, y] children (x :<= y) = [x, y] - children (x :&& y) = [x, y] - children (x :|| y) = [x, y] + children (SmtAnd xs) = xs + children (SmtOr xs) = xs children ((:!) x) = [x] children (x :=> y) = [x, y] children (x :<=> y) = [x, y] @@ -104,6 +187,9 @@ children (Ite x x' x'') = [x, x', x''] children (SLet (_, x) x') = [x, x'] + children (FromCode x) = [x] + children (ToCode x) = [x] + children _ = [] modifyChildren f (x :>= y) = f x :>= f y @@ -113,8 +199,8 @@ modifyChildren f (x :< y) = f x :< f y modifyChildren f (x :<= y) = f x :<= f y - modifyChildren f (x :&& y) = f x :&& f y - modifyChildren f (x :|| y) = f x :|| f y + modifyChildren f (SmtAnd xs) = SmtAnd (map f xs) + modifyChildren f (SmtOr xs) = SmtOr (map f xs) modifyChildren f ((:!) x) = (:!) (f x) modifyChildren f (x :=> y) = f x :=> f y @@ -124,6 +210,9 @@ modifyChildren f (x :/ y) = f x :/ f y modifyChildren f (Neg x) = Neg (f x) + modifyChildren f (FromCode x) = FromCode (f x) + modifyChildren f (ToCode x) = ToCode (f x) + modifyChildren f (Ite x x' x'') = Ite (f x) (f x') (f x'') modifyChildren f (SLet (n, x) x') = SLet (n, f x) (f x') @@ -134,11 +223,19 @@ modifyChildren _ s = s +-- | DefineFun SMTName [(SMTName, Sort)] Sort !SMTAST + instance ASTContainer SMTHeader SMTAST where containedASTs (Assert a) = [a] + containedASTs (AssertSoft a _) = [a] + containedASTs (Minimize a) = [a] + containedASTs (DefineFun _ _ _ a) = [a] containedASTs _ = [] modifyContainedASTs f (Assert a) = Assert (f a) + modifyContainedASTs f (AssertSoft a lbl) = AssertSoft (f a) lbl + modifyContainedASTs f (Minimize a) = Minimize (f a) + modifyContainedASTs f (DefineFun n ars r a) = DefineFun n ars r (f a) modifyContainedASTs _ s = s instance ASTContainer SMTAST Sort where @@ -148,3 +245,11 @@ modifyContainedASTs f (V n s) = V n (modify f s) modifyContainedASTs f x = modify (modifyContainedASTs f) x +sortOf :: SMTAST -> Sort +sortOf (VInt _) = SortInt +sortOf (VFloat _) = SortFloat +sortOf (VDouble _) = SortDouble +sortOf (VString _) = SortString +sortOf (VChar _) = SortChar +sortOf (VBool _) = SortBool +sortOf _ = error "sortOf: Unhandled SMTAST" diff --git a/src/G2/Solver/Maximize.hs b/src/G2/Solver/Maximize.hs new file mode 100644 --- /dev/null +++ b/src/G2/Solver/Maximize.hs @@ -0,0 +1,161 @@ +module G2.Solver.Maximize ( MaximizeSolver + , mkMaximizeSolver) where + +import G2.Solver.Converters +import G2.Solver.Language +import G2.Solver.Solver + +import Control.Concurrent +import Data.IORef +import Data.List as L +import qualified Data.Map as M +import Text.Builder + +data MaximizeSolver con = MaxSolver (MVar ThreadId) (MVar (Result () () ())) (IORef [SMTHeader]) con + +mkMaximizeSolver :: SMTConverter con => con -> IO (MaximizeSolver con) +mkMaximizeSolver con = do + thread_mvar <- newEmptyMVar + res_mvar <- newEmptyMVar + headers_io_ref <- newIORef [] + return $ MaxSolver thread_mvar res_mvar headers_io_ref con + +instance SMTConverter con => Solver (MaximizeSolver con) where + check solver _ pc = checkConstraintsPC solver pc + solve (MaxSolver _ _ _ con) = solve con + close = closeIO + +instance SMTConverter con => SMTConverter (MaximizeSolver con) where + closeIO (MaxSolver thread_ioref _ _ con) = do + maybe (return ()) killThread =<< tryReadMVar thread_ioref + closeIO con + + reset (MaxSolver thread_mvar res_mvar headers_io_ref con) = do + maybe (return ()) killThread =<< tryReadMVar thread_mvar + _ <- tryTakeMVar thread_mvar + _ <- tryTakeMVar res_mvar + writeIORef headers_io_ref [] + reset con + + checkSatInstr (MaxSolver thread_mvar res_mvar headers_io_ref con) = do + maybe (return ()) killThread =<< tryReadMVar thread_mvar + added <- readIORef headers_io_ref + thread <- forkIO (do + res <- solveSoftAsserts con added + definitelyPutMVar res_mvar res) + definitelyPutMVar thread_mvar thread + return () + + maybeCheckSatResult (MaxSolver _ res_ioref _ _) = tryReadMVar res_ioref + + getModelInstrResult (MaxSolver _ _ _ con) = getModelInstrResult con + getUnsatCoreInstrResult (MaxSolver _ _ _ con) = getUnsatCoreInstrResult con + + setProduceUnsatCores (MaxSolver _ _ _ con) = setProduceUnsatCores con + + addFormula (MaxSolver _ _ headers_io_ref _) form = modifyIORef' headers_io_ref (form ++) + + checkSatGetModelOrUnsatCoreNoReset (MaxSolver _ _ headers_io_ref con) headers vs = do + added <- readIORef headers_io_ref + res <- solveSoftAsserts con (added ++ headers) + case res of + SAT _ -> do + mdl <- getModelInstrResult con vs + return (SAT mdl) + UNSAT _ -> do + uc <- getUnsatCoreInstrResult con + return (UNSAT uc) + Unknown err _ -> return (Unknown err ()) + + -- We don't need to produce a model, because this resets, so we can just ignore all soft assertions + checkSat max_solver@(MaxSolver _ _ _ con) headers = do + reset max_solver + checkSat con $ filter (\h -> case h of AssertSoft _ _ -> False; _ -> True) headers + + checkSatGetModel con@(MaxSolver _ _ _ _) headers vs = do + reset con + res <- solveSoftAsserts con headers + case res of + SAT _ -> do + mdl <- getModelInstrResult con vs + return (SAT mdl) + UNSAT _ -> return (UNSAT ()) + Unknown err _ -> return (Unknown err ()) + + push (MaxSolver _ _ _ con) = push con + pop (MaxSolver _ _ _ con) = pop con + +solveSoftAsserts :: SMTConverter con => con -> [SMTHeader] -> IO (Result () () ()) +solveSoftAsserts con headers = do + let (soft_asserts, other_headers) = + partition (\h -> case h of AssertSoft _ _ -> True; _ -> False) $ elimSetLogic headers + set_logic = getSetLogic headers + soft_assert_sum = + foldr (:+) (VInt 0) + $ map (\(AssertSoft assrt _) -> Ite assrt (VInt 1) (VInt 0)) soft_asserts + new_assert = Assert $ V totalVarName SortInt := soft_assert_sum + var_decl = VarDecl (string totalVarName) SortInt + setProduceUnsatCores con + addHeaders con (set_logic ++ var_decl:other_headers ++ [new_assert]) + solveSoftAsserts' con Nothing 0 0 (genericLength soft_asserts) + +type Minimum = Integer +type Maximum = Integer + +solveSoftAsserts' :: SMTConverter con => + con + -> Maybe SMTModel + -> Int + -> Minimum + -> Maximum + -> IO (Result () () ()) +solveSoftAsserts' con mb_mdl fresh min_ max_ = do + let (target_q, target_r) = (min_ + max_) `quotRem` 2 + target = target_q + target_r + target_assert = Assert $ V totalVarName SortInt :>= VInt target + + putStrLn $ "min = " ++ show min_ ++ ", max = " ++ show max_ ++ ", target = " ++ show target + push con + res <- constraintsToModelOrUnsatCoreNoReset con [target_assert] [(totalVarName, SortInt)] + case res of + SAT mdl | Just (VInt new_min_) <- m_new_min + , new_min_ == max_ -> return $ SAT () + | Just (VInt new_min_) <- m_new_min -> do + -- If we are increasing the minimum depth, we do NOT want to remove + -- our previous limit assertion, so that if we later get a model, that + -- limit assertion is still in place. + solveSoftAsserts' con (Just mdl) (fresh + 1) (new_min_ + 1) max_ + -- Should be unreachable because totalVarName should always be in the model + | otherwise -> error "solveSoftAsserts': Impossible case" + where + m_new_min = M.lookup totalVarName mdl + UNSAT _ | target == 0 -> return $ UNSAT () + | min_ == max_ -> do + pop con + -- get-model is only valid after a check-sat call that returns sat, + -- so we must ensure that the last check-sat did indeed return sat. + _ <- checkSatNoReset con [] + return $ SAT () + -- Should be unreachable, because if min_ is not 0, we have found a model. + -- But if min_ == max_ == 0, target == 0, and we hit the first case. + | min_ == max_ -> error "solveSoftAsserts': Impossible case" + | otherwise -> do + pop con + solveSoftAsserts' con mb_mdl (fresh + 1) min_ (target - 1) + Unknown err _ -> return $ Unknown err () + +definitelyPutMVar :: MVar a -> a -> IO () +definitelyPutMVar mvar a = do + r <- tryPutMVar mvar a + case r of + True -> return () + False -> modifyMVar_ mvar (\_ -> return a) + +totalVarName :: SMTName +totalVarName = "solveSoftAsserts_SUM_VAR" + +getSetLogic :: [SMTHeader] -> [SMTHeader] +getSetLogic = filter (\h -> case h of SetLogic _ -> True; _ -> False) + +elimSetLogic :: [SMTHeader] -> [SMTHeader] +elimSetLogic = filter (\h -> case h of SetLogic _ -> False; _ -> True) diff --git a/src/G2/Solver/ParseSMT.hs b/src/G2/Solver/ParseSMT.hs --- a/src/G2/Solver/ParseSMT.hs +++ b/src/G2/Solver/ParseSMT.hs @@ -148,19 +148,30 @@ stringExpr :: Parser SMTAST stringExpr = do _ <- char '"' - str <- stringExpr' + str <- many stringExpr' _ <- char '"' - return (VChar str) + return (VString str) stringExpr' :: Parser Char stringExpr' = do - try parseHex <|> choice (alphaNum:char '\\':map char ident) + try parseHex <|> try parseUni <|> choice (alphaNum:char '\\':char ' ':map char ident) parseHex :: Parser Char parseHex = do _ <- char '\\' _ <- char 'x' str <- many (choice . map char $ ['0'..'9'] ++ ['a'..'f']) + case readHex str of + [(c, _)] -> return $ chr c + _ -> error $ "stringExpr': Bad string" + +parseUni :: Parser Char +parseUni = do + _ <- char '\\' + _ <- char 'u' + _ <- char '{' + str <- many (choice . map char $ ['0'..'9'] ++ ['a'..'f']) + _ <- char '}' case readHex str of [(c, _)] -> return $ chr c _ -> error $ "stringExpr': Bad string" diff --git a/src/G2/Solver/SMT2.hs b/src/G2/Solver/SMT2.hs --- a/src/G2/Solver/SMT2.hs +++ b/src/G2/Solver/SMT2.hs @@ -1,6 +1,7 @@ -- | This defines an SMTConverter for the SMT2 language -- It provides methods to construct formulas, as well as feed them to an external solver +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} @@ -9,24 +10,28 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeSynonymInstances #-} -module G2.Solver.SMT2 where +module G2.Solver.SMT2 ( Z3 + , CVC4 + , SomeSMTSolver (..) + , getZ3 + , getSMT + , getSMTAV) where import G2.Config.Config import G2.Language.ArbValueGen -import G2.Language.Expr -import G2.Language.Support -import G2.Language.Syntax hiding (Assert) -import G2.Language.Typing import G2.Solver.Language import G2.Solver.ParseSMT import G2.Solver.Solver import G2.Solver.Converters --It would be nice to not import this... import Control.Exception.Base (evaluate) -import Data.List import Data.List.Utils (countElem) +import qualified Data.HashSet as HS import qualified Data.Map as M -import Data.Ratio +import Data.Semigroup +import qualified Data.Text as T +import qualified Data.Text.IO as T +import qualified Text.Builder as TB import System.IO import System.Process @@ -34,279 +39,246 @@ data CVC4 = CVC4 ArbValueFunc (Handle, Handle, ProcessHandle) data SomeSMTSolver where - SomeSMTSolver :: forall con ast out io - . SMTConverter con ast out io => con -> SomeSMTSolver + SomeSMTSolver :: forall con + . SMTConverter con => con -> SomeSMTSolver instance Solver Z3 where - check solver _ pc = checkConstraints solver pc - solve con@(Z3 avf _) = checkModel avf con + check solver _ pc = checkConstraintsPC solver pc + solve con@(Z3 avf _) = checkModelPC avf con close = closeIO instance Solver CVC4 where - check solver _ pc = checkConstraints solver pc - solve con@(CVC4 avf _) = checkModel avf con + check solver _ pc = checkConstraintsPC solver pc + solve con@(CVC4 avf _) = checkModelPC avf con close = closeIO -instance SMTConverter Z3 String String (Handle, Handle, ProcessHandle) where - getIO (Z3 _ hhp) = hhp - closeIO (Z3 _ (h_in, _, _)) = hPutStr h_in "(exit)" +getIOZ3 :: Z3 -> (Handle, Handle, ProcessHandle) +getIOZ3 (Z3 _ hhp) = hhp - empty _ = "" - merge _ = (++) +instance SMTConverter Z3 where + closeIO (Z3 _ (h_in, h_out, ph)) = do +#if MIN_VERSION_process(1,6,4) + cleanupProcess (Just h_in, Just h_out, Nothing, ph) +#else + T.hPutStrLn h_in "(exit)" + _ <- waitForProcess ph + hClose h_in + hClose h_out +#endif - checkSat _ (h_in, h_out, _) formula = do + reset con = do + let (h_in, _, _) = getIOZ3 con + T.hPutStr h_in "(reset)" + + checkSatInstr con = do + let (h_in, _, _) = getIOZ3 con + T.hPutStrLn h_in "(check-sat)" + + maybeCheckSatResult con = do + let (_, h_out, _) = getIOZ3 con + r <- hReady h_out + case r of + True -> return . Just =<< checkSatReadResult h_out + False -> return Nothing + + getModelInstrResult con vs = do + let (h_in, h_out, _) = getIOZ3 con + mdl <- getModelZ3 h_in h_out vs + -- putStrLn "======" + -- putStrLn (show mdl) + let m = parseModel mdl + -- putStrLn $ "m = " ++ show m + -- putStrLn "======" + return m + + getUnsatCoreInstrResult con = do + let (h_in, h_out, _) = getIOZ3 con + uc <- getUnsatCoreZ3 h_in h_out + return (HS.fromList uc) + + setProduceUnsatCores con = do + let (h_in, _, _) = getIOZ3 con + T.hPutStrLn h_in "(set-option :produce-unsat-cores true)" + + addFormula con form = do + let (h_in, _, _) = getIOZ3 con + T.hPutStrLn h_in (TB.run $ toSolverText form) + + checkSatNoReset con formula = do + let (h_in, h_out, _) = getIOZ3 con -- putStrLn "checkSat" - -- putStrLn formula - setUpFormulaZ3 h_in formula + T.hPutStrLn h_in (TB.run $ toSolverText formula) r <- checkSat' h_in h_out + -- T.putStrLn (TB.run $ toSolverText formula) -- putStrLn $ show r return r - checkSatGetModel _ (h_in, h_out, _) formula _ vs = do - setUpFormulaZ3 h_in formula + checkSatGetModel con formula vs = do + let (h_in, h_out, _) = getIOZ3 con + setUpFormulaZ3 h_in (TB.run $ toSolverText formula) -- putStrLn "\n\n checkSatGetModel" - -- putStrLn formula + -- T.putStrLn (TB.run $ toSolverText formula) r <- checkSat' h_in h_out -- putStrLn $ "r = " ++ show r - if r == SAT then do - mdl <- getModelZ3 h_in h_out vs - -- putStrLn "======" - -- putStrLn (show mdl) - let m = parseModel mdl - -- putStrLn $ "m = " ++ show m - -- putStrLn "======" - return (r, Just m) - else do - return (r, Nothing) + case r of + SAT () -> do + mdl <- getModelZ3 h_in h_out vs + -- putStrLn "======" + -- putStrLn (show mdl) + let m = parseModel mdl + -- putStrLn $ "m = " ++ show m + -- putStrLn "======" + return $ SAT m + UNSAT () -> return $ UNSAT () + Unknown s _ -> return $ Unknown s () - checkSatGetModelGetExpr con (h_in, h_out, _) formula _ vs eenv (CurrExpr _ e) = do - setUpFormulaZ3 h_in formula - -- putStrLn "\n\n checkSatGetModelGetExpr" - -- putStrLn formula + checkSatGetModelOrUnsatCoreNoReset con formula vs = do + let (h_in, h_out, _) = getIOZ3 con + let formula' = TB.run $ toSolverText formula + T.putStrLn "\n\n checkSatGetModelOrUnsatCore" + T.putStrLn formula' + + T.hPutStr h_in formula' r <- checkSat' h_in h_out -- putStrLn $ "r = " ++ show r - if r == SAT then do + if r == SAT () then do mdl <- getModelZ3 h_in h_out vs -- putStrLn "======" - -- putStrLn formula - -- putStrLn "" + -- putStrLn $ "r = " ++ show r + -- putStrLn $ "mdl = " ++ show mdl -- putStrLn (show mdl) - -- putStrLn "======" let m = parseModel mdl - - expr <- solveExpr h_in h_out con eenv e - -- putStrLn (show expr) - return (r, Just m, Just expr) + -- putStrLn $ "m = " ++ show m + -- putStrLn "======" + return (SAT m) + else if r == UNSAT () then do + uc <- getUnsatCoreZ3 h_in h_out + return (UNSAT $ HS.fromList uc) else do - return (r, Nothing, Nothing) - - assert _ = function1 "assert" - - varDecl _ n s = "(declare-const " ++ n ++ " " ++ s ++ ")" - - setLogic _ lgc = - let - s = case lgc of - QF_LIA -> "QF_LIA" - QF_LRA -> "QF_LRA" - QF_LIRA -> "QF_LIRA" - QF_NIA -> "QF_NIA" - QF_NRA -> "QF_NRA" - QF_NIRA -> "QF_NIRA" - _ -> "ALL" - in - case lgc of - ALL -> "" - _ -> "(set-logic " ++ s ++ ")" + return (Unknown "" ()) - (.>=) _ = function2 ">=" - (.>) _ = function2 ">" - (.=) _ = function2 "=" - (./=) _ x = function1 "not" . function2 "=" x - (.<=) _ = function2 "<=" - (.<) _ = function2 "<" + push con = do + let (h_in, _, _) = getIOZ3 con + T.hPutStrLn h_in "(push)" - (.&&) _ = function2 "and" - (.||) _ = function2 "or" - (.!) _ = function1 "not" - (.=>) _ = function2 "=>" - (.<=>) _ = function2 "=" + pop con = do + let (h_in, _, _) = getIOZ3 con + T.hPutStrLn h_in "(pop)" - (.+) _ = function2 "+" - (.-) _ = function2 "-" - (.*) _ = function2 "*" - (./) _ = function2 "/" - smtQuot _ = function2 "div" - smtModulo _ = function2 "mod" - smtSqrt _ x = "(^ " ++ x ++ " 0.5)" - neg _ = function1 "-" - strLen _ = function1 "str.len" +getIOCVC4 :: CVC4 -> (Handle, Handle, ProcessHandle) +getIOCVC4 (CVC4 _ hhp) = hhp - itor _ = function1 "to_real" +instance SMTConverter CVC4 where + closeIO (CVC4 _ (h_in, h_out, ph)) = do + hPutStrLn h_in "(exit)" + _ <- waitForProcess ph + hClose h_in + hClose h_out + reset con = do + let (h_in, _, _) = getIOCVC4 con + T.hPutStr h_in "(reset)" - ite _ = function3 "ite" + checkSatInstr con = do + let (h_in, _, _) = getIOCVC4 con + T.hPutStrLn h_in "(check-sat)" - int _ x = if x >= 0 then show x else "(- " ++ show (abs x) ++ ")" - float _ r = - "(/ " ++ show (numerator r) ++ " " ++ show (denominator r) ++ ")" - double _ r = - "(/ " ++ show (numerator r) ++ " " ++ show (denominator r) ++ ")" - char _ c = '"':c:'"':[] - bool _ b = if b then "true" else "false" - var _ n = function1 n + maybeCheckSatResult con = do + let (_, h_out, _) = getIOCVC4 con + r <- hReady h_out + case r of + True -> return . Just =<< checkSatReadResult h_out + False -> return Nothing - sortInt _ = "Int" - sortFloat _ = "Real" - sortDouble _ = "Real" - sortChar _ = "String" - sortBool _ = "Bool" + getModelInstrResult con vs = do + let (h_in, h_out, _) = getIOCVC4 con + mdl <- getModelCVC4 h_in h_out vs + -- putStrLn "======" + -- putStrLn (show mdl) + let m = parseModel mdl + -- putStrLn $ "m = " ++ show m + -- putStrLn "======" + return m - cons _ n asts _ = - if asts /= [] then - "(" ++ n ++ " " ++ (intercalate " " asts) ++ ")" - else - n - varName _ n _ = n + getUnsatCoreInstrResult con = do + let (h_in, h_out, _) = getIOCVC4 con + uc <- getUnsatCoreCVC4 h_in h_out + return (HS.fromList uc) -instance SMTConverter CVC4 String String (Handle, Handle, ProcessHandle) where - getIO (CVC4 _ hhp) = hhp - closeIO (CVC4 _ (h_in, _, _)) = hPutStr h_in "(exit)" + setProduceUnsatCores _ = return () - empty _ = "" - merge _ = (++) + addFormula con form = do + let (h_in, _, _) = getIOCVC4 con + T.hPutStrLn h_in (TB.run $ toSolverText form) - checkSat _ (h_in, h_out, _) formula = do + checkSatNoReset con formula = do + let (h_in, h_out, _) = getIOCVC4 con -- putStrLn "checkSat" + -- let formula = run formulaBldr + -- T.putStrLn (TB.run formula) -- putStrLn formula - setUpFormulaCVC4 h_in formula + T.hPutStrLn h_in (TB.run $ toSolverText formula) r <- checkSat' h_in h_out -- putStrLn $ show r return r - checkSatGetModel _ (h_in, h_out, _) formula _ vs = do - setUpFormulaCVC4 h_in formula + checkSatGetModel con formula vs = do + let (h_in, h_out, _) = getIOCVC4 con + setUpFormulaCVC4 h_in (TB.run $ toSolverText formula) -- putStrLn "\n\n checkSatGetModel" -- putStrLn formula r <- checkSat' h_in h_out -- putStrLn $ "r = " ++ show r - if r == SAT then do - mdl <- getModelCVC4 h_in h_out vs - -- putStrLn "======" - -- putStrLn (show mdl) - let m = parseModel mdl - -- putStrLn $ "m = " ++ show m - -- putStrLn "======" - return (r, Just m) - else do - return (r, Nothing) + case r of + SAT _ -> do + mdl <- getModelCVC4 h_in h_out vs + -- putStrLn "======" + -- putStrLn (show mdl) + let m = parseModel mdl + -- putStrLn $ "m = " ++ show m + -- putStrLn "======" + return (SAT m) + UNSAT _ -> return $ UNSAT () + Unknown s _ -> return $ Unknown s () - checkSatGetModelGetExpr con (h_in, h_out, _) formula _ vs eenv (CurrExpr _ e) = do - setUpFormulaCVC4 h_in formula - -- putStrLn "\n\n checkSatGetModelGetExpr" - -- putStrLn formula + checkSatGetModelOrUnsatCoreNoReset con formula vs = do + let (h_in, h_out, _) = getIOCVC4 con + let formula' = TB.run $ toSolverText formula + T.putStrLn "\n\n checkSatGetModelOrUnsatCore" + T.putStrLn formula' + + T.hPutStr h_in formula' r <- checkSat' h_in h_out - -- putStrLn $ "r = " ++ show r - if r == SAT then do + putStrLn $ "r = " ++ show r + if r == SAT () then do mdl <- getModelCVC4 h_in h_out vs -- putStrLn "======" - -- putStrLn formula - -- putStrLn "" + -- putStrLn $ "r = " ++ show r + -- putStrLn $ "mdl = " ++ show mdl -- putStrLn (show mdl) - -- putStrLn "======" let m = parseModel mdl - - expr <- solveExpr h_in h_out con eenv e - -- putStrLn (show expr) - return (r, Just m, Just expr) + -- putStrLn $ "m = " ++ show m + -- putStrLn "======" + return (SAT m) + else if r == UNSAT () then do + uc <- getUnsatCoreCVC4 h_in h_out + return (UNSAT $ HS.fromList uc) else do - return (r, Nothing, Nothing) - - assert _ = function1 "assert" - - varDecl _ n s = "(declare-const " ++ n ++ " " ++ s ++ ")" - - setLogic _ lgc = - let - s = case lgc of - QF_LIA -> "QF_LIA" - QF_LRA -> "QF_LRA" - QF_LIRA -> "QF_LIRA" - QF_NIA -> "QF_NIA" - QF_NRA -> "QF_NRA" - QF_NIRA -> "QF_NIRA" - _ -> "ALL" - in - case lgc of - ALL -> "" - _ -> "(set-logic " ++ s ++ ")" - - (.>=) _ = function2 ">=" - (.>) _ = function2 ">" - (.=) _ = function2 "=" - (./=) _ = \x -> function1 "not" . function2 "=" x - (.<=) _ = function2 "<=" - (.<) _ = function2 "<" - - (.&&) _ = function2 "and" - (.||) _ = function2 "or" - (.!) _ = function1 "not" - (.=>) _ = function2 "=>" - (.<=>) _ = function2 "=" - - (.+) _ = function2 "+" - (.-) _ = function2 "-" - (.*) _ = function2 "*" - (./) _ = function2 "/" - smtQuot _ = function2 "div" - smtModulo _ = function2 "mod" - smtSqrt _ x = "(^ " ++ x ++ " 0.5)" - neg _ = function1 "-" - strLen _ = function1 "str.len" - - itor _ = function1 "to_real" - - ite _ = function3 "ite" - - int _ x = if x >= 0 then show x else "(- " ++ show (abs x) ++ ")" - float _ r = - "(/ " ++ show (numerator r) ++ " " ++ show (denominator r) ++ ")" - double _ r = - "(/ " ++ show (numerator r) ++ " " ++ show (denominator r) ++ ")" - char _ c = '"':c:'"':[] - bool _ b = if b then "true" else "false" - var _ n = function1 n - - sortInt _ = "Int" - sortFloat _ = "Real" - sortDouble _ = "Real" - sortChar _ = "String" - sortBool _ = "Bool" - - cons _ n asts _ = - if asts /= [] then - "(" ++ n ++ " " ++ (intercalate " " asts) ++ ")" - else - n - varName _ n _ = n - -functionList :: String -> [String] -> String -functionList f xs = "(" ++ f ++ " " ++ (intercalate " " xs) ++ ")" - -function1 :: String -> String -> String -function1 f a = "(" ++ f ++ " " ++ a ++ ")" + return (Unknown "" ()) -function2 :: String -> String -> String -> String -function2 f a b = "(" ++ f ++ " " ++ a ++ " " ++ b ++ ")" + push con = do + let (h_in, _, _) = getIOCVC4 con + T.hPutStrLn h_in "(push)" -function3 :: String -> String -> String -> String -> String -function3 f a b c = "(" ++ f ++ " " ++ a ++ " " ++ b ++ " " ++ c ++ ")" + pop con = do + let (h_in, _, _) = getIOCVC4 con + T.hPutStrLn h_in "(pop)" -- | getProcessHandles -- Ideally, this function should be called only once, and the same Handles should be used @@ -329,15 +301,18 @@ return (h_in, h_out, p) +getZ3 :: Int -> IO Z3 +getZ3 time_out = do + hhp@(h_in, _, _) <- getZ3ProcessHandles time_out + hPutStr h_in "(set-option :pp.decimal true)" + return $ Z3 arbValue hhp + getSMT :: Config -> IO SomeSMTSolver getSMT = getSMTAV arbValue -getSMTInfinite :: Config -> IO SomeSMTSolver -getSMTInfinite = getSMTAV arbValueInfinite - getSMTAV :: ArbValueFunc -> Config -> IO SomeSMTSolver getSMTAV avf (Config {smt = ConZ3}) = do - hhp@(h_in, _, _) <- getZ3ProcessHandles + hhp@(h_in, _, _) <- getZ3ProcessHandles 10000 hPutStr h_in "(set-option :pp.decimal true)" return $ SomeSMTSolver (Z3 avf hhp) getSMTAV avf (Config {smt = ConCVC4}) = do @@ -349,45 +324,46 @@ -- returned handles to interact with Z3 -- Ideally, this function should be called only once, and the same Handles should be used -- in all future calls -getZ3ProcessHandles :: IO (Handle, Handle, ProcessHandle) -getZ3ProcessHandles = getProcessHandles $ proc "z3" ["-smt2", "-in"] +getZ3ProcessHandles :: Int -> IO (Handle, Handle, ProcessHandle) +getZ3ProcessHandles time_out = getProcessHandles $ proc "z3" ["-smt2", "-in", "-t:" ++ show time_out] getCVC4ProcessHandles :: IO (Handle, Handle, ProcessHandle) -getCVC4ProcessHandles = getProcessHandles $ proc "cvc4" ["--lang", "smt2.6", "--produce-models"] +getCVC4ProcessHandles = getProcessHandles $ proc "cvc4" ["--lang", "smt2.6", "--produce-models", "--produce-unsat-cores"] -- | setUpFormulaZ3 -- Writes a function to Z3 -setUpFormulaZ3 :: Handle -> String -> IO () +setUpFormulaZ3 :: Handle -> T.Text -> IO () setUpFormulaZ3 h_in form = do - hPutStr h_in "(reset)" - hPutStr h_in form + T.hPutStr h_in "(reset)" + T.hPutStr h_in form -setUpFormulaCVC4 :: Handle -> String -> IO () +setUpFormulaCVC4 :: Handle -> T.Text -> IO () setUpFormulaCVC4 h_in form = do - hPutStr h_in "(reset)" + T.hPutStr h_in "(reset)" -- hPutStr h_in "(set-logic ALL)\n" - hPutStr h_in form + T.hPutStr h_in form -- Checks if a formula, previously written by setUp formula, is SAT -checkSat' :: Handle -> Handle -> IO Result +checkSat' :: Handle -> Handle -> IO (Result () () ()) checkSat' h_in h_out = do hPutStr h_in "(check-sat)\n" - r <- hWaitForInput h_out (-1) - if r then do - out <- hGetLine h_out - -- putStrLn $ "Z3 out: " ++ out - _ <- evaluate (length out) + _ <- hWaitForInput h_out (-1) + checkSatReadResult h_out - if out == "sat" then - return SAT - else if out == "unsat" then - return UNSAT - else - return (Unknown out) - else do - return (Unknown "") +checkSatReadResult :: Handle -> IO (Result () () ()) +checkSatReadResult h_out = do + out <- hGetLine h_out + -- putStrLn $ "Z3 out: " ++ out + _ <- evaluate (length out) + if out == "sat" then + return $ SAT () + else if out == "unsat" then + return $ UNSAT () + else + return (Unknown out ()) + parseModel :: [(SMTName, String, Sort)] -> SMTModel parseModel = foldr (\(n, s) -> M.insert n s) M.empty . map (\(n, str, s) -> (n, parseToSMTAST str s)) @@ -396,8 +372,10 @@ parseToSMTAST str s = correctTypes s . parseGetValues $ str where correctTypes :: Sort -> SMTAST -> SMTAST - correctTypes (SortFloat) (VDouble r) = VFloat r - correctTypes (SortDouble) (VFloat r) = VDouble r + correctTypes SortFloat (VDouble r) = VFloat r + correctTypes SortDouble (VFloat r) = VDouble r + correctTypes SortChar (VString [c]) = VChar c + correctTypes SortChar (VString _) = error "Invalid Char from parseToSMTAST" correctTypes _ a = a getModelZ3 :: Handle -> Handle -> [(SMTName, Sort)] -> IO [(SMTName, String, Sort)] @@ -414,6 +392,37 @@ return . (:) (n, out, s) =<< getModel' nss +getUnsatCoreZ3 :: Handle -> Handle -> IO [SMTName] +getUnsatCoreZ3 h_in h_out = do + hPutStr h_in "(get-unsat-core)\n" + _ <- hWaitForInput h_out (-1) + out <- hGetLine h_out + putStrLn $ "unsat-core = " ++ out + let out' = tail . init $ out -- drop opening and closing parens + + case words out' of + "error":_ -> error "getUnsatCoreZ3: Error producing unsat core" + w -> return w + +getUnsatCoreCVC4 :: Handle -> Handle -> IO [SMTName] +getUnsatCoreCVC4 h_in h_out = do + hPutStr h_in "(get-unsat-core)\n" + _ <- hWaitForInput h_out (-1) + -- Read in the opening bracket + _ <- hGetLine h_out + out <- getCore + putStrLn $ "unsat-core = " ++ show out + + return out + where + getCore = do + _ <- hWaitForInput h_out (-1) + core <- hGetLine h_out + putStrLn $ "getCore " ++ show core + case core of + ")" -> return [] + _ -> return . (:) core =<< getCore + getModelCVC4 :: Handle -> Handle -> [(SMTName, Sort)] -> IO [(SMTName, String, Sort)] getModelCVC4 h_in h_out ns = do getModel' ns @@ -444,27 +453,3 @@ else do out' <- getLinesMatchParens' h_out n' return $ out ++ out' - -solveExpr :: SMTConverter con [Char] out io => Handle -> Handle -> con -> ExprEnv -> Expr -> IO Expr -solveExpr h_in h_out con eenv e = do - let vs = symbVars eenv e - vs' <- solveExpr' h_in h_out con vs - let vs'' = map smtastToExpr vs' - - return $ foldr (uncurry replaceASTs) e (zip vs vs'') - -solveExpr' :: SMTConverter con [Char] out io => Handle -> Handle -> con -> [Expr] -> IO [SMTAST] -solveExpr' _ _ _ [] = return [] -solveExpr' h_in h_out con (v:vs) = do - v' <- solveExpr'' h_in h_out con v - vs' <- solveExpr' h_in h_out con vs - return (v':vs') - -solveExpr'' :: SMTConverter con [Char] out io => Handle -> Handle -> con -> Expr -> IO SMTAST -solveExpr'' h_in h_out con e = do - let smte = toSolverAST con $ exprToSMT e - hPutStr h_in ("(eval " ++ smte ++ " :completion)\n") - out <- getLinesMatchParens h_out - _ <- evaluate (length out) - - return $ parseToSMTAST out (typeToSMT . typeOf $ e) diff --git a/src/G2/Solver/Simplifier.hs b/src/G2/Solver/Simplifier.hs new file mode 100644 --- /dev/null +++ b/src/G2/Solver/Simplifier.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE OverloadedStrings #-} + +module G2.Solver.Simplifier ( Simplifier (..) + , IdSimplifier (..)) where + +import G2.Language + +class Simplifier simplifier where + -- | Simplifies a PC, by converting it to a form that is easier for the Solver's to handle + simplifyPC :: forall t . simplifier -> State t -> PathCond -> (State t, [PathCond]) + + {-# INLINE simplifyPCs #-} + simplifyPCs :: forall t. simplifier -> State t -> PathCond -> PathConds -> PathConds + simplifyPCs _ _ _ = id + + -- | Reverses the affect of simplification in the model, if needed. + reverseSimplification :: forall t . simplifier -> State t -> Bindings -> Model -> Model + +-- | A simplifier that does no simplification +data IdSimplifier = IdSimplifier + +instance Simplifier IdSimplifier where + simplifyPC _ s pc = (s, [pc]) + reverseSimplification _ _ _ m = m diff --git a/src/G2/Solver/Solver.hs b/src/G2/Solver/Solver.hs --- a/src/G2/Solver/Solver.hs +++ b/src/G2/Solver/Solver.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TupleSections #-} @@ -13,27 +14,28 @@ , groupRelatedFinite , groupRelatedInfinite , CombineSolvers (..) - , UndefinedHigherOrder (..)) where + , UndefinedHigherOrder (..) + , UnknownSolver (..)) where import G2.Language import qualified G2.Language.PathConds as PC import Data.List -import qualified Data.Map as M +import qualified Data.HashMap.Lazy as HM -- | The result of a Solver query -data Result = SAT - | UNSAT - | Unknown String - deriving (Show, Eq) +data Result m u um = SAT m + | UNSAT u + | Unknown String um + deriving (Show, Eq) -- | Defines an interface to interact with Solvers class Solver solver where -- | Checks if the given `PathConds` are satisfiable. - check :: forall t . solver -> State t -> PathConds -> IO Result + check :: forall t . solver -> State t -> PathConds -> IO (Result () () ()) -- | Checks if the given `PathConds` are satisfiable, and, if yes, gives a `Model` -- The model must contain, at a minimum, a value for each passed `Id` - solve :: forall t . solver -> State t -> Bindings -> [Id] -> PathConds -> IO (Result, Maybe Model) + solve :: forall t . solver -> State t -> Bindings -> [Id] -> PathConds -> IO (Result Model () ()) -- | Cleans up when the solver is no longer needed. Default implementation -- does nothing @@ -47,12 +49,12 @@ class TrSolver solver where -- | Checks if the given `PathConds` are satisfiable. -- Allows modifying the solver, to track some state. - checkTr :: forall t . solver -> State t -> PathConds -> IO (Result, solver) + checkTr :: forall t . solver -> State t -> PathConds -> IO (Result () () (), solver) -- | Checks if the given `PathConds` are satisfiable, and, if yes, gives a `Model` -- The model must contain, at a minimum, a value for each passed `Id` -- Allows modifying the solver, to track some state. - solveTr :: forall t . solver -> State t -> Bindings -> [Id] -> PathConds -> IO (Result, Maybe Model, solver) + solveTr :: forall t . solver -> State t -> Bindings -> [Id] -> PathConds -> IO (Result Model () (), solver) -- | Cleans up when the solver is no longer needed. Default implementation -- does nothing @@ -64,7 +66,7 @@ instance Solver solver => TrSolver (Tr solver) where checkTr (Tr sol) s pc = return . (, Tr sol) =<< check sol s pc - solveTr (Tr sol) s b is pc = return . (\(r, m) -> (r, m, Tr sol)) =<< solve sol s b is pc + solveTr (Tr sol) s b is pc = return . (\r -> (r, Tr sol)) =<< solve sol s b is pc closeTr = close . unTr data SomeSolver where @@ -84,26 +86,26 @@ groupRelatedInfinite :: a -> GroupRelated a groupRelatedInfinite = GroupRelated arbValueInfinite -checkRelated :: TrSolver a => a -> State t -> PathConds -> IO (Result, a) +checkRelated :: TrSolver a => a -> State t -> PathConds -> IO (Result () () (), a) checkRelated solver s pc = - checkRelated' solver s $ PC.relatedSets (known_values s) pc + checkRelated' solver s $ PC.relatedSets pc -checkRelated' :: TrSolver a => a -> State t -> [PathConds] -> IO (Result, a) -checkRelated' sol _ [] = return (SAT, sol) +checkRelated' :: TrSolver a => a -> State t -> [PathConds] -> IO (Result () () (), a) +checkRelated' sol _ [] = return (SAT (), sol) checkRelated' sol s (p:ps) = do (c, sol') <- checkTr sol s p case c of - SAT -> checkRelated' sol' s ps + SAT _ -> checkRelated' sol' s ps r -> return (r, sol') -solveRelated :: TrSolver a => ArbValueFunc -> a -> State t -> Bindings -> [Id] -> PathConds -> IO (Result, Maybe Model, a) +solveRelated :: TrSolver a => ArbValueFunc -> a -> State t -> Bindings -> [Id] -> PathConds -> IO (Result Model () (), a) solveRelated avf sol s b is pc = do - solveRelated' avf sol s b M.empty is $ PC.relatedSets (known_values s) pc + solveRelated' avf sol s b HM.empty is $ PC.relatedSets pc -solveRelated' :: TrSolver a => ArbValueFunc -> a -> State t -> Bindings -> Model -> [Id] -> [PathConds] -> IO (Result, Maybe Model, a) +solveRelated' :: TrSolver a => ArbValueFunc -> a -> State t -> Bindings -> Model -> [Id] -> [PathConds] -> IO (Result Model () (), a) solveRelated' avf sol s b m is [] = let - is' = filter (\i -> idName i `M.notMember` m) is + is' = filter (\i -> not $ idName i `HM.member` m) is (_, nv) = mapAccumL (\av_ (Id n t) -> @@ -113,21 +115,21 @@ (v, (n, av_')) ) (arb_value_gen b) is' - m' = foldr (\(n, v) -> M.insert n v) m nv + m' = foldr (\(n, v) -> HM.insert n v) m nv in - return (SAT, Just m', sol) + return (SAT m', sol) solveRelated' avf sol s b m is (p:ps) = do - let is' = concat $ PC.map (PC.varIdsInPC (known_values s)) p + let is' = concat $ PC.map' PC.varIdsInPC p let is'' = ids p rm <- solveTr sol s b is' p case rm of - (SAT, Just m', sol') -> solveRelated' avf sol' s b (M.union m m') (is ++ is'') ps + (SAT m', sol') -> solveRelated' avf sol' s b (HM.union m m') (is ++ is'') ps rm' -> return rm' instance Solver solver => Solver (GroupRelated solver) where check (GroupRelated _ sol) s pc = return . fst =<< checkRelated (Tr sol) s pc solve (GroupRelated avf sol) s b is pc = - return . (\(r, m, _) -> (r, m)) =<< solveRelated avf (Tr sol) s b is pc + return . (\(r, _) -> r) =<< solveRelated avf (Tr sol) s b is pc close (GroupRelated _ s) = close s instance TrSolver solver => TrSolver (GroupRelated solver) where @@ -135,8 +137,8 @@ (r, sol') <- checkRelated sol s pc return (r, GroupRelated avf sol') solveTr (GroupRelated avf sol) s b is pc = do - (r, m, sol') <- solveRelated avf sol s b is pc - return (r, m, GroupRelated avf sol') + (r, sol') <- solveRelated avf sol s b is pc + return (r, GroupRelated avf sol') closeTr (GroupRelated _ s) = closeTr s -- | Allows solvers to be combined, to exploit different solvers abilities @@ -144,54 +146,54 @@ data CombineSolvers a b = a : b -- ^ a :>? b - Try solver a. If it returns Unknown, try solver b -checkWithEither :: (TrSolver a, TrSolver b) => a -> b -> State t -> PathConds -> IO (Result, CombineSolvers a b) +checkWithEither :: (TrSolver a, TrSolver b) => a -> b -> State t -> PathConds -> IO (Result () () (), CombineSolvers a b) checkWithEither a b s pc = do (ra, a') <- checkTr a s pc case ra of - SAT -> return (SAT, a' :?> b) - UNSAT -> return (UNSAT, a' :?> b) - Unknown ua -> do + SAT _ -> return (ra, a' :?> b) + UNSAT _ -> return (ra, a' :?> b) + Unknown ua _ -> do (rb, b') <- checkTr b s pc case rb of - Unknown ub -> return $ (Unknown $ ua ++ ",\n" ++ ub, a' :?> b') + Unknown ub _ -> return $ (Unknown (ua ++ ",\n" ++ ub) (), a' :?> b') rb' -> return (rb', a' :?> b') -solveWithEither :: (TrSolver a, TrSolver b) => a -> b -> State t -> Bindings -> [Id] -> PathConds -> IO (Result, Maybe Model, CombineSolvers a b) +solveWithEither :: (TrSolver a, TrSolver b) => a -> b -> State t -> Bindings -> [Id] -> PathConds -> IO (Result Model () (), CombineSolvers a b) solveWithEither a b s binds is pc = do ra <- solveTr a s binds is pc case ra of - (SAT, m, a') -> return (SAT, m, a' :?> b) - (UNSAT, m, a') -> return (UNSAT, m, a' :?> b) - (Unknown ua, _, a') -> do + (SAT m, a') -> return (SAT m, a' :?> b) + (UNSAT u, a') -> return (UNSAT u, a' :?> b) + (Unknown ua _, a') -> do rb <- solveTr b s binds is pc case rb of - (Unknown ub, _, b') -> return $ (Unknown $ ua ++ ",\n" ++ ub, Nothing, a' :?> b') - (r, m, b') -> return (r, m, a' :?> b') + (Unknown ub (), b') -> return $ (Unknown (ua ++ ",\n" ++ ub) (), a' :?> b') + (r, b') -> return (r, a' :?> b') -- | Fills in unused higher order functions with undefined data UndefinedHigherOrder = UndefinedHigherOrder instance Solver UndefinedHigherOrder where - check _ s pc = + check _ _ pc = let - f = concatMap (PC.varIdsInPC (known_values s)) $ PC.toList pc + f = concatMap PC.varIdsInPC $ PC.toList pc in case f of - [Id _ (TyFun _ _)] -> return SAT - _ -> return $ Unknown "UndefinedHigherOrder" + [Id _ (TyFun _ _)] -> return $ SAT () + _ -> return $ Unknown "UndefinedHigherOrder" () solve _ _ _ [i@(Id _ (TyFun _ _))] _ = - return (SAT, Just $ M.singleton (idName i) (Prim Undefined TyBottom)) - solve _ _ _ _ _ = return (Unknown "UndefinedHigherOrder", Nothing) + return $ SAT (HM.singleton (idName i) (Prim Undefined TyBottom)) + solve _ _ _ _ _ = return (Unknown "UndefinedHigherOrder" ()) instance (Solver a, Solver b) => Solver (CombineSolvers a b) where check (a : b) s pc = return . fst =<< checkWithEither (Tr a) (Tr b) s pc solve (a : (r, m)) =<< solveWithEither (Tr b) (Tr a) s binds is pc + return . (\(r, _) -> r) =<< solveWithEither (Tr b) (Tr a) s binds is pc solve (a :?> b) s binds is pc = - return . (\(r, m, _) -> (r, m)) =<< solveWithEither (Tr a) (Tr b) s binds is pc + return . (\(r, _) -> r) =<< solveWithEither (Tr a) (Tr b) s binds is pc close (a : b) s pc = checkWithEither a b s pc solveTr (a : a' -> return (r, m, a' : return (r, m, a' :?> b') + b' :?> a' -> return (r, a' : return (r, a' :?> b') solveTr (a :?> b) s binds is pc = solveWithEither a b s binds is pc closeTr (a : b) = do closeTr a closeTr b + +instance (ASTContainer m e, ASTContainer u e) => ASTContainer (Result m u um) e where + containedASTs (SAT m) = containedASTs m + containedASTs (UNSAT u) = containedASTs u + containedASTs (Unknown _ _) = [] + + modifyContainedASTs f (SAT m) = SAT (modifyContainedASTs f m) + modifyContainedASTs f (UNSAT u) = UNSAT (modifyContainedASTs f u) + modifyContainedASTs _ u@(Unknown _ _) = u + +-- A solver that returns unknown on all but the most trivial (empty) PCs +data UnknownSolver = UnknownSolver + +instance Solver UnknownSolver where + check _ _ pc + | PC.null pc = return (SAT ()) + | otherwise = return (Unknown "unknown" ()) + solve _ _ _ _ pc + | PC.null pc = return (SAT HM.empty) + | otherwise = return (Unknown "unknown" ()) diff --git a/src/G2/Translation/Cabal/Cabal.hs b/src/G2/Translation/Cabal/Cabal.hs --- a/src/G2/Translation/Cabal/Cabal.hs +++ b/src/G2/Translation/Cabal/Cabal.hs @@ -1,8 +1,21 @@ +{-# LANGUAGE CPP #-} + module G2.Translation.Cabal.Cabal (cabalSrcDirs) where import Distribution.PackageDescription + +#if MIN_VERSION_Cabal(3,8,0) +import Distribution.Simple.PackageDescription +#elif MIN_VERSION_Cabal(2,2,0) +import Distribution.PackageDescription.Parsec +#else import Distribution.PackageDescription.Parse +#endif + import Distribution.Verbosity +#if MIN_VERSION_Cabal(3,6,0) +import Distribution.Utils.Path ( getSymbolicPath ) +#endif -- | Takes the filepath to a Cabal file, and returns a list of FilePaths to red -- from. @@ -14,8 +27,11 @@ genericPackageDescriptionSrcDirs :: GenericPackageDescription -> [FilePath] genericPackageDescriptionSrcDirs (GenericPackageDescription { condLibrary = cl - , condExecutables = ce }) = do - maybe [] (condTreeSrcDirs libSrcDirs) cl ++ concatMap (condTreeSrcDirs execSrcDirs . snd) ce + , condExecutables = ce + , condTestSuites = ts }) = do + maybe [] (condTreeSrcDirs libSrcDirs) cl + ++ concatMap (condTreeSrcDirs execSrcDirs . snd) ce + ++ concatMap (condTreeSrcDirs testSrcDirs . snd) ts condTreeSrcDirs :: (a -> [FilePath]) -> CondTree v c a -> [FilePath] condTreeSrcDirs f (CondNode { condTreeData = t }) = f t @@ -26,5 +42,12 @@ execSrcDirs :: Executable -> [FilePath] execSrcDirs = buildInfoSrcDirs . buildInfo +testSrcDirs :: TestSuite -> [FilePath] +testSrcDirs = buildInfoSrcDirs . testBuildInfo + buildInfoSrcDirs :: BuildInfo -> [FilePath] +#if MIN_VERSION_Cabal(3,6,0) +buildInfoSrcDirs (BuildInfo { hsSourceDirs = sd }) = map getSymbolicPath sd +#else buildInfoSrcDirs (BuildInfo { hsSourceDirs = sd }) = sd +#endif diff --git a/src/G2/Translation/GHC.hs b/src/G2/Translation/GHC.hs new file mode 100644 --- /dev/null +++ b/src/G2/Translation/GHC.hs @@ -0,0 +1,150 @@ +{-# LANGUAGE CPP #-} + +#if MIN_VERSION_GLASGOW_HASKELL(9,0,2,0) + +module G2.Translation.GHC ( module GHC + , module GHC.Core + , module GHC.Core.Class + , module GHC.Core.Coercion + , module GHC.Core.DataCon + , module GHC.Core.InstEnv + , module GHC.Core.TyCo.Rep + , module GHC.Core.TyCon + , module GHC.Data.FastString + , module GHC.Data.Pair + , module GHC.Driver.Main + , module GHC.Driver.Session + , module GHC.Iface.Tidy + , module GHC.Paths + , module GHC.Types.Avail + , module GHC.Types.Id.Info + , module GHC.Types.Literal + , module GHC.Types.Name + , module GHC.Types.SrcLoc + , module GHC.Types.Unique + , module GHC.Types.Var + , module GHC.Unit.Types +#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0) + , module GHC.Platform.Ways + , module GHC.Types.Tickish + , module GHC.Types.TypeEnv + , module GHC.Unit.Module.Deps + , module GHC.Unit.Module.ModDetails + , module GHC.Unit.Module.ModGuts + + , HscTarget +#else + , module GHC.Driver.Types + , module GHC.Driver.Ways +#endif +#if MIN_VERSION_GLASGOW_HASKELL(9,3,0,0) + , module GHC.Driver.Config.Tidy +#endif + ) where + +import GHC +import GHC.Core ( Alt (..) + , AltCon (..) + , Bind (..) + , CoreAlt + , CoreBind + , CoreExpr + , CoreProgram + , CoreRule (..) + , Expr (..) + +#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0) +#else + , Tickish (..) +#endif + + , bindersOf) +import GHC.Core.Class (classAllSelIds, className, classSCTheta, classTyVars) +import GHC.Core.Coercion +import GHC.Core.DataCon +import GHC.Core.InstEnv +import GHC.Core.TyCo.Rep +import GHC.Core.TyCon +import GHC.Data.FastString +import GHC.Data.Pair +import GHC.Driver.Main +import GHC.Driver.Session +import GHC.Iface.Tidy +import GHC.Paths +import GHC.Types.Avail +import GHC.Types.Id.Info +import GHC.Types.Literal +import GHC.Types.Name hiding (varName) +import GHC.Types.SrcLoc +import GHC.Types.Unique +import GHC.Types.Var +import GHC.Unit.Types + +#if MIN_VERSION_GLASGOW_HASKELL(9,3,0,0) +import GHC.Driver.Config.Tidy +#endif + +#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0) +import GHC.Platform.Ways +import GHC.Types.Tickish +import GHC.Types.TypeEnv +import GHC.Unit.Module.Deps +import GHC.Unit.Module.ModDetails +import GHC.Unit.Module.ModGuts + +type HscTarget = Backend +#else +import GHC.Driver.Types +import GHC.Driver.Ways +#endif + + +#else + +module G2.Translation.GHC ( module Avail + , module Class + , module Coercion + , module CoreSyn + , module DataCon + , module DynFlags + , module FastString + , module GHC + , module GHC.Paths + , module HscMain + , module HscTypes + , module IdInfo + , module InstEnv + , module Literal + , module Name + , module Pair + , module SrcLoc + , module TidyPgm + , module TyCon + , module TyCoRep + , module Unique + , module Var) where + +import Avail +import Class (classAllSelIds, className, classSCTheta, classTyVars) +import Coercion +import CoreSyn +import DataCon +import DynFlags +import FastString +import GHC hiding (AnnKeywordId (..), AnnExpr' (..)) +import GHC.Paths +import HscMain +import HscTypes +import IdInfo +import InstEnv +import Literal +import Name hiding (varName) +import Pair +import SrcLoc +import TidyPgm +import TyCon +import TyCoRep +import Unique +import Var + +#endif diff --git a/src/G2/Translation/Haskell.hs b/src/G2/Translation/Haskell.hs --- a/src/G2/Translation/Haskell.hs +++ b/src/G2/Translation/Haskell.hs @@ -1,4 +1,6 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} -- | Haskell Translation module G2.Translation.Haskell @@ -10,14 +12,15 @@ , hskToG2ViaCgGutsFromFile , mkCgGutsClosure , mkModDetailsClosure + , mkModGutsClosure + + , EnvModSumModGuts (..) + , envModSumModGutsFromFile + , hskToG2ViaEMS + , envModSumModGutsImports + , mergeExtractedG2s - , mkIOString - , prim_list - , mkRawCore - , rawDump , mkExpr - , mkId - , mkIdUnsafe , mkName , mkTyConName , mkData @@ -28,38 +31,21 @@ , readAllExtractedG2s , mergeFileExtractedG2s , findCabal + + , mkIdUnsafe + , mkTyConNameUnsafe + , mkDataUnsafe ) where -import qualified G2.Language.TypeEnv as G2 (AlgDataTy (..), ProgramType) +import qualified G2.Language.TypeEnv as G2 (AlgDataTy (..)) import qualified G2.Language.Syntax as G2 -- import qualified G2.Language.Typing as G2 import qualified G2.Translation.TransTypes as G2 -import Avail -import qualified Class as C -import Coercion -import CoreSyn -import DataCon -import DynFlags -import FastString -import GHC -import GHC.Paths -import HscMain -import HscTypes -import IdInfo -import InstEnv -import Literal -import Name -import Outputable -import Pair -import SrcLoc -import TidyPgm -import TyCon -import TyCoRep -import Unique -import Var as V +import G2.Translation.GHC import Control.Monad +import qualified Control.Monad.State.Lazy as SM import qualified Data.Array as A import qualified Data.ByteString.Char8 as C @@ -86,69 +72,90 @@ -> G2.Type mkG2TyCon n ts k = mkG2TyApp $ G2.TyCon n k:ts - -mkIOString :: (Outputable a) => a -> IO String -mkIOString obj = runGhc (Just libdir) $ do - dflags <- getSessionDynFlags - return (showPpr dflags obj) - -mkRawCore :: FilePath -> IO CoreModule -mkRawCore fp = runGhc (Just libdir) $ do - _ <- setSessionDynFlags =<< getSessionDynFlags - -- compileToCoreModule fp - compileToCoreSimplified fp - -rawDump :: FilePath -> IO () -rawDump fp = do - core <- mkRawCore fp - str <- mkIOString core - putStrLn str - - equivMods :: HM.HashMap T.Text T.Text equivMods = HM.fromList - [ ("GHC.Classes2", "GHC.Classes") + [ ("GHC.BaseMonad", "GHC.Base") + , ("GHC.Classes2", "GHC.Classes") , ("GHC.Types2", "GHC.Types") , ("GHC.Integer2", "GHC.Integer") +#if MIN_VERSION_GLASGOW_HASKELL(9,0,2,0) + , ("GHC.Integer.Type2", "GHC.Num.Integer") +#else , ("GHC.Integer.Type2", "GHC.Integer.Type") +#endif , ("GHC.Prim2", "GHC.Prim") +#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0) + , ("GHC.Tuple2", "GHC.Tuple.Prim") +#else , ("GHC.Tuple2", "GHC.Tuple") +#endif , ("GHC.Magic2", "GHC.Magic") , ("GHC.CString2", "GHC.CString") , ("Data.Map.Base", "Data.Map")] - -loadProj :: Maybe HscTarget -> [FilePath] -> [FilePath] -> [GeneralFlag] -> G2.TranslationConfig -> Ghc SuccessFlag +loadProj :: Maybe HscTarget -> [FilePath] -> [FilePath] -> [GeneralFlag] -> G2.TranslationConfig -> Ghc SuccessFlag loadProj hsc proj src gflags tr_con = do beta_flags <- getSessionDynFlags - let gen_flags = gflags + let gen_flags = if G2.hpc_ticks tr_con then Opt_Hpc:gflags else gflags let init_beta_flags = gopt_unset beta_flags Opt_StaticArgumentTransformation let beta_flags' = foldl' gopt_set init_beta_flags gen_flags - let dflags = beta_flags' { -- Profiling fails to load a profiler friendly version of the base - -- without this special casing for hscTarget, but we can't use HscInterpreted when we have certain unboxed types + let dflags = beta_flags' { +#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0) + backend = case hsc of + Just hsc' -> hsc' + _ -> backend beta_flags' +#elif MIN_VERSION_GLASGOW_HASKELL(9,2,0,0) + backend = if hostIsProfiled + then Interpreter + else case hsc of + Just hsc' -> hsc' + _ -> backend beta_flags' +#elif MIN_VERSION_GLASGOW_HASKELL(9,0,2,0) + hscTarget = if hostIsProfiled + then HscInterpreted + else case hsc of + Just hsc' -> hsc' + _ -> hscTarget beta_flags' + +#else hscTarget = if rtsIsProfiled then HscInterpreted else case hsc of Just hsc' -> hsc' _ -> hscTarget beta_flags' +#endif +#if MIN_VERSION_GLASGOW_HASKELL(9,4,0,0) + -- Profiling gives warnings without this special case + , targetWays_ = if hostIsProfiled then addWay WayProf (targetWays_ beta_flags') else targetWays_ beta_flags' +#endif , ghcLink = LinkInMemory , ghcMode = CompManager - , includePaths = proj ++ includePaths beta_flags' + , importPaths = proj ++ importPaths beta_flags' , simplPhases = if G2.simpl tr_con then simplPhases beta_flags' else 0 , maxSimplIterations = if G2.simpl tr_con then maxSimplIterations beta_flags' else 0 , hpcDir = head proj} + dflags' = setIncludePaths proj dflags - _ <- setSessionDynFlags dflags + _ <- setSessionDynFlags dflags' +#if MIN_VERSION_GLASGOW_HASKELL(9,3,0,0) + targets <- mapM (\s -> guessTarget s Nothing Nothing) src +#else targets <- mapM (flip guessTarget Nothing) src +#endif _ <- setTargets targets load LoadAllTargets - +setIncludePaths :: [FilePath] -> DynFlags -> DynFlags +#if __GLASGOW_HASKELL__ < 806 +setIncludePaths proj dflags = dflags { includePaths = proj ++ includePaths dflags } +#else +setIncludePaths proj dflags = dflags { includePaths = addQuoteInclude (includePaths dflags) proj } +#endif -- Compilation pipeline with CgGuts hskToG2ViaCgGutsFromFile :: Maybe HscTarget @@ -159,23 +166,29 @@ -> G2.TranslationConfig -> IO (G2.NameMap, G2.TypeNameMap, G2.ExtractedG2) hskToG2ViaCgGutsFromFile hsc proj src nm tm tr_con = do - closures <- mkCgGutsModDetailsClosuresFromFile hsc proj src tr_con - return $ hskToG2ViaCgGuts nm tm closures tr_con + ems <- envModSumModGutsFromFile hsc proj src tr_con + hskToG2ViaEMS tr_con ems nm tm +hskToG2ViaEMS :: G2.TranslationConfig + -> EnvModSumModGuts + -> G2.NameMap + -> G2.TypeNameMap + -> IO (G2.NameMap, G2.TypeNameMap, G2.ExtractedG2) +hskToG2ViaEMS tr_con (EnvModSumModGuts env _ modgutss) nm tm = do + closures <- mkCgGutsModDetailsClosures tr_con env modgutss + let (ex_g2, (nm', tm')) = SM.runState (hskToG2ViaCgGuts closures tr_con) (nm, tm) + return (nm', tm', ex_g2) -hskToG2ViaCgGuts :: G2.NameMap - -> G2.TypeNameMap - -> [(G2.CgGutsClosure, G2.ModDetailsClosure)] - -> G2.TranslationConfig - -> (G2.NameMap, G2.TypeNameMap, G2.ExtractedG2) -hskToG2ViaCgGuts nm tm pairs tr_con = do - let (nm2, tm2, exg2s) = foldr (\(c, m) (nm', tm', exs) -> - let mgcc = cgGutsModDetailsClosureToModGutsClosure c m in - let (nm'', tm'', g2) = modGutsClosureToG2 nm' tm' mgcc tr_con in - (nm'', tm'', g2 : exs)) - (nm, tm, []) - pairs in - (nm2, tm2, mergeExtractedG2s exg2s) +hskToG2ViaCgGuts :: [(G2.CgGutsClosure, G2.ModDetailsClosure)] + -> G2.TranslationConfig + -> G2.NamesM G2.ExtractedG2 +hskToG2ViaCgGuts pairs tr_con = do + exg2s <- mapM (\(c, m) -> do + let mgcc = cgGutsModDetailsClosureToModGutsClosure c m + g2 <- modGutsClosureToG2 mgcc tr_con + return g2) + pairs + return $ mergeExtractedG2s exg2s cgGutsModDetailsClosureToModGutsClosure :: G2.CgGutsClosure -> G2.ModDetailsClosure -> G2.ModGutsClosure @@ -193,47 +206,90 @@ } -mkCgGutsModDetailsClosuresFromFile :: Maybe HscTarget - -> [FilePath] - -> [FilePath] - -> G2.TranslationConfig - -> IO [(G2.CgGutsClosure, G2.ModDetailsClosure)] -mkCgGutsModDetailsClosuresFromFile hsc proj src tr_con = do - (env, modgutss) <- runGhc (Just libdir) $ do +data EnvModSumModGuts = EnvModSumModGuts HscEnv [ModSummary] [ModGuts] + +envModSumModGutsFromFile :: Maybe HscTarget + -> [FilePath] + -> [FilePath] + -> G2.TranslationConfig + -> IO EnvModSumModGuts +envModSumModGutsFromFile hsc proj src tr_con = + runGhc (Just libdir) $ do _ <- loadProj hsc proj src [] tr_con env <- getSession mod_graph <- getModuleGraph - parsed_mods <- mapM parseModule mod_graph + + let msums = convertModuleGraph mod_graph + parsed_mods <- mapM parseModule msums typed_mods <- mapM typecheckModule parsed_mods desug_mods <- mapM desugarModule typed_mods - return (env, map coreModule desug_mods) + return . EnvModSumModGuts env msums $ map coreModule desug_mods +envModSumModGutsImports :: EnvModSumModGuts -> [String] +envModSumModGutsImports (EnvModSumModGuts _ ms _) = concatMap (map (\(_, L _ m) -> moduleNameString m) . ms_textual_imps) ms + +-- | Extract information from GHC into a form that G2 can process. +mkCgGutsModDetailsClosures :: G2.TranslationConfig -> HscEnv -> [ModGuts] -> IO [( G2.CgGutsClosure, G2.ModDetailsClosure)] +#if __GLASGOW_HASKELL__ < 806 +mkCgGutsModDetailsClosures tr_con env modgutss = do simplgutss <- mapM (if G2.simpl tr_con then hscSimplify env else return . id) modgutss tidys <- mapM (tidyProgram env) simplgutss - let pairs = map (\((cg, md), mg) -> (mkCgGutsClosure (mg_binds mg) cg, mkModDetailsClosure (mg_deps mg) md)) $ zip tidys simplgutss + let pairs = map (\((cg, md), mg) -> ( mkCgGutsClosure (mg_binds mg) cg md + , mkModDetailsClosure (mg_deps mg) md)) $ zip tidys simplgutss return pairs +#else +mkCgGutsModDetailsClosures tr_con env modgutss = do + simplgutss <- mapM (if G2.simpl tr_con then hscSimplify env [] else return . id) modgutss --- | The core program in the CgGuts does not include local rules after tidying. --- As such, we pass in the CoreProgram from the ModGuts -mkCgGutsClosure :: CoreProgram -> CgGuts -> G2.CgGutsClosure -mkCgGutsClosure bndrs cgguts = +#if MIN_VERSION_GLASGOW_HASKELL(9,3,0,0) + tidy_opts <- initTidyOpts env + tidys <- mapM (tidyProgram tidy_opts) simplgutss +#else + tidys <- mapM (tidyProgram env) simplgutss +#endif + + let pairs = map (\((cg, md), mg) -> ( mkCgGutsClosure (mg_binds mg) cg md + , mkModDetailsClosure (mg_deps mg) md)) $ zip tidys simplgutss + return pairs +#endif + +-- | Extract information from GHC into a form that G2 can process. +mkCgGutsClosure :: CoreProgram -> CgGuts -> ModDetails -> G2.CgGutsClosure +mkCgGutsClosure binds cgguts md = + let + binds_rules = concatMap ruleInfoRules + . map ruleInfo + . map idInfo + . concatMap bindersOf $ binds + in G2.CgGutsClosure { G2.cgcc_mod_name = Just $ moduleNameString $ moduleName $ cg_module cgguts , G2.cgcc_binds = cg_binds cgguts , G2.cgcc_breaks = cg_modBreaks cgguts , G2.cgcc_tycons = cg_tycons cgguts - , G2.cgcc_rules = concatMap ruleInfoRules . map ruleInfo . map idInfo - . concatMap bindersOf $ bndrs } + -- Getting all rules is complicated by GHC's build process. GHC goes through a "tidying" + -- process, which performs various transformation on the Core code. Unfortunately: + -- 1) The core program in the CgGuts does not include rules after tidying. + -- 2) The ModDetails does not include all rules after tidying. + -- 3) Names of functions in rules in the original CoreProgram may have been changed by bindings + -- (in which case it seems like those rules ARE in the ModDetails.) + -- We can't just take the rules from the ModDetails, because some are eliminated during tidying. + -- But we can't just take the rules from the original CoreProgram, because they might have function/variables + -- names that no longer exist. + -- As such, we keep: + -- 1) Rules from the ModDetails + -- 2) Rules from the CoreProgram, IF a rule with the same name is not in ModDetails + , G2.cgcc_rules = nubBy (\r1 r2 -> ru_name r1 == ru_name r2) (md_rules md ++ binds_rules) } mkModDetailsClosure :: Dependencies -> ModDetails -> G2.ModDetailsClosure mkModDetailsClosure deps moddet = G2.ModDetailsClosure - { G2.mdcc_cls_insts = md_insts moddet + { G2.mdcc_cls_insts = getClsInst moddet , G2.mdcc_type_env = md_types moddet , G2.mdcc_exports = exportedNames moddet - , G2.mdcc_deps = map (moduleNameString . fst) $ dep_mods deps + , G2.mdcc_deps = getModuleNames deps } @@ -248,65 +304,54 @@ -> IO (G2.NameMap, G2.TypeNameMap, G2.ExtractedG2) hskToG2ViaModGutsFromFile hsc proj src nm tm tr_con = do closures <- mkModGutsClosuresFromFile hsc proj src tr_con - return $ hskToG2ViaModGuts nm tm closures tr_con + let (ex_g2, (nm', tm')) = SM.runState (hskToG2ViaModGuts closures tr_con) (nm, tm) + return (nm', tm', ex_g2) -hskToG2ViaModGuts :: G2.NameMap - -> G2.TypeNameMap - -> [G2.ModGutsClosure] - -> G2.TranslationConfig - -> (G2.NameMap, G2.TypeNameMap, G2.ExtractedG2) -hskToG2ViaModGuts nm tm modgutss tr_con = - let (nm2, tm2, exg2s) = foldr (\m (nm', tm', cls) -> - let (nm'', tm'', mc) = modGutsClosureToG2 nm' tm' m tr_con in - (nm'', tm'', mc : cls)) - (nm, tm, []) - modgutss in - (nm2, tm2, mergeExtractedG2s exg2s) - - - +hskToG2ViaModGuts :: [G2.ModGutsClosure] + -> G2.TranslationConfig + -> G2.NamesM G2.ExtractedG2 +hskToG2ViaModGuts modgutss tr_con = do + exg2s <- mapM (\m -> modGutsClosureToG2 m tr_con) modgutss + return $ mergeExtractedG2s exg2s -modGutsClosureToG2 :: G2.NameMap - -> G2.TypeNameMap - -> G2.ModGutsClosure - -> G2.TranslationConfig - -> (G2.NameMap, G2.TypeNameMap, G2.ExtractedG2) -modGutsClosureToG2 nm tm mgcc tr_con = - let breaks = G2.mgcc_breaks mgcc in +modGutsClosureToG2 :: G2.ModGutsClosure + -> G2.TranslationConfig + -> G2.NamesM G2.ExtractedG2 +modGutsClosureToG2 mgcc tr_con = do + let breaks = G2.mgcc_breaks mgcc -- Do the binds - let (nm2, binds) = foldr (\b (nm', bs) -> - let (nm'', bs') = mkBinds nm' tm breaks b in - (nm'', bs ++ bs')) - (nm, []) - (G2.mgcc_binds mgcc) in + binds <- foldM (\bs b -> do + bs' <- mkBinds breaks b + return $ bs `HM.union` bs') + HM.empty + (G2.mgcc_binds mgcc) -- Do the tycons - let raw_tycons = G2.mgcc_tycons mgcc ++ typeEnvTyCons (G2.mgcc_type_env mgcc) in - let (nm3, tm2, tycons) = foldr (\tc (nm', tm', tcs) -> - let ((nm'', tm''), mb_t) = mkTyCon nm' tm' tc in - (nm'', tm'', maybeToList mb_t ++ tcs)) - (nm2, tm, []) - raw_tycons in + let raw_tycons = G2.mgcc_tycons mgcc ++ typeEnvTyCons (G2.mgcc_type_env mgcc) + tycons <- foldM (\tcs tc -> do + (n, mb_t) <- mkTyCon tc + return $ maybe tcs (\t -> HM.insert n t tcs) mb_t) + HM.empty + raw_tycons -- Do the class - let classes = map (mkClass tm2) $ G2.mgcc_cls_insts mgcc in + classes <- mapM mkClass $ G2.mgcc_cls_insts mgcc -- Do the rules - let rules = if G2.load_rewrite_rules tr_con - then mapMaybe (mkRewriteRule nm3 tm2 breaks) $ G2.mgcc_rules mgcc - else [] in + rules <- if G2.load_rewrite_rules tr_con + then mapM (mkRewriteRule breaks) $ G2.mgcc_rules mgcc + else return [] -- Do the exports - let exports = G2.mgcc_exports mgcc in - let deps = fmap T.pack $ G2.mgcc_deps mgcc in - (nm3, tm2, - G2.ExtractedG2 - { G2.exg2_mod_names = maybeToList $ fmap T.pack $ G2.mgcc_mod_name mgcc - , G2.exg2_binds = binds - , G2.exg2_tycons = tycons - , G2.exg2_classes = classes - , G2.exg2_exports = exports - , G2.exg2_deps = deps - , G2.exg2_rules = rules }) + let exports = G2.mgcc_exports mgcc + let deps = fmap T.pack $ G2.mgcc_deps mgcc + return (G2.ExtractedG2 + { G2.exg2_mod_names = [fmap T.pack $ G2.mgcc_mod_name mgcc] + , G2.exg2_binds = binds + , G2.exg2_tycons = tycons + , G2.exg2_classes = classes + , G2.exg2_exports = exports + , G2.exg2_deps = deps + , G2.exg2_rules = catMaybes rules }) mkModGutsClosuresFromFile :: Maybe HscTarget @@ -320,37 +365,75 @@ env <- getSession mod_graph <- getModuleGraph - parsed_mods <- mapM parseModule mod_graph + + let msums = convertModuleGraph mod_graph + parsed_mods <- mapM parseModule msums + typed_mods <- mapM typecheckModule parsed_mods desug_mods <- mapM desugarModule typed_mods return (env, map coreModule desug_mods) if G2.simpl tr_con then do - simpls <- mapM (hscSimplify env) modgutss - closures <- mapM (mkModGutsClosure env) simpls - return closures + simpls <- mapM (hscSimplifyC env) modgutss + mapM (mkModGutsClosure env) simpls else do - closures <- mapM (mkModGutsClosure env) modgutss - return closures + mapM (mkModGutsClosure env) modgutss +{-# INLINE convertModuleGraph #-} +convertModuleGraph :: ModuleGraph -> [ModSummary] +#if __GLASGOW_HASKELL__ < 806 +convertModuleGraph = id +#else +convertModuleGraph = mgModSummaries +#endif + +{-# INLINE hscSimplifyC #-} +hscSimplifyC :: HscEnv -> ModGuts -> IO ModGuts +#if __GLASGOW_HASKELL__ < 806 +hscSimplifyC = hscSimplify +#else +hscSimplifyC env = hscSimplify env [] +#endif + + -- This one will need to do the Tidy program stuff mkModGutsClosure :: HscEnv -> ModGuts -> IO G2.ModGutsClosure mkModGutsClosure env modguts = do +#if MIN_VERSION_GLASGOW_HASKELL(9,3,0,0) + tidy_opts <- initTidyOpts env + (cgguts, moddets) <- tidyProgram tidy_opts modguts +#else (cgguts, moddets) <- tidyProgram env modguts +#endif return G2.ModGutsClosure { G2.mgcc_mod_name = Just $ moduleNameString $ moduleName $ cg_module cgguts , G2.mgcc_binds = cg_binds cgguts , G2.mgcc_tycons = cg_tycons cgguts , G2.mgcc_breaks = cg_modBreaks cgguts - , G2.mgcc_cls_insts = md_insts moddets + , G2.mgcc_cls_insts = getClsInst moddets , G2.mgcc_type_env = md_types moddets , G2.mgcc_exports = exportedNames moddets - , G2.mgcc_deps = map (moduleNameString . fst) $ dep_mods $ mg_deps modguts + , G2.mgcc_deps = getModuleNames $ mg_deps modguts , G2.mgcc_rules = mg_rules modguts } +getClsInst :: ModDetails -> [ClsInst] +#if MIN_VERSION_GLASGOW_HASKELL(9,3,0,0) +getClsInst = instEnvElts . md_insts +#else +getClsInst = md_insts +#endif +getModuleNames :: Dependencies -> [String] +#if MIN_VERSION_GLASGOW_HASKELL(9,3,0,0) +getModuleNames = map moduleNameString . dep_sig_mods +#elif MIN_VERSION_GLASGOW_HASKELL(9,0,2,0) +getModuleNames = map (moduleNameString . gwib_mod) . dep_mods +#else +getModuleNames = map (moduleNameString . fst) . dep_mods +#endif + -- Merging, order matters! mergeExtractedG2s :: [G2.ExtractedG2] -> G2.ExtractedG2 mergeExtractedG2s [] = G2.emptyExtractedG2 @@ -358,8 +441,8 @@ let g2' = mergeExtractedG2s g2s in G2.ExtractedG2 { G2.exg2_mod_names = G2.exg2_mod_names g2 ++ G2.exg2_mod_names g2' -- order matters - , G2.exg2_binds = G2.exg2_binds g2 ++ G2.exg2_binds g2' - , G2.exg2_tycons = G2.exg2_tycons g2 ++ G2.exg2_tycons g2' + , G2.exg2_binds = G2.exg2_binds g2 `HM.union` G2.exg2_binds g2' + , G2.exg2_tycons = G2.exg2_tycons g2 `HM.union` G2.exg2_tycons g2' , G2.exg2_classes = G2.exg2_classes g2 ++ G2.exg2_classes g2' , G2.exg2_exports = G2.exg2_exports g2 ++ G2.exg2_exports g2' , G2.exg2_deps = G2.exg2_deps g2 ++ G2.exg2_deps g2' @@ -368,40 +451,49 @@ ---------------- -- Translating the individual components in CoreSyn, etc into G2 Core -mkBinds :: G2.NameMap -> G2.TypeNameMap -> Maybe ModBreaks -> CoreBind -> (G2.NameMap, [(G2.Id, G2.Expr)]) -mkBinds nm tm mb (NonRec var expr) = - let - (i, nm') = mkIdUpdatingNM var nm tm - in - (nm', [(i, mkExpr nm' tm mb expr)]) -mkBinds nm tm mb (Rec ves) = - mapAccumR (\nm' (v, e) -> - let - (i, nm'') = mkIdUpdatingNM v nm' tm - in - (nm'', (i, mkExpr nm'' tm mb e)) - ) nm ves +mkBinds :: Maybe ModBreaks -> CoreBind -> G2.NamesM (HM.HashMap G2.Name G2.Expr) +mkBinds mb (NonRec var expr) = do + i <- mkIdLookup var + e <- mkExpr mb expr + return $ HM.singleton (G2.idName i) e +mkBinds mb (Rec ves) = + return . HM.fromList =<< + mapM (\(v, expr) -> do + i <- mkIdLookup v + e <- mkExpr mb expr + return (G2.idName i, e)) ves -mkExpr :: G2.NameMap -> G2.TypeNameMap -> Maybe ModBreaks -> CoreExpr -> G2.Expr -mkExpr nm tm _ (Var var) = G2.Var (mkIdLookup var nm tm) -mkExpr _ _ _ (Lit lit) = G2.Lit (mkLit lit) -mkExpr nm tm mb (App fxpr axpr) = G2.App (mkExpr nm tm mb fxpr) (mkExpr nm tm mb axpr) -mkExpr nm tm mb (Lam var expr) = G2.Lam (mkLamUse var) (mkId tm var) (mkExpr nm tm mb expr) -mkExpr nm tm mb (Let bnd expr) = G2.Let (mkBind nm tm mb bnd) (mkExpr nm tm mb expr) -mkExpr nm tm mb (Case mxpr var _ alts) = G2.Case (mkExpr nm tm mb mxpr) (mkId tm var) (mkAlts nm tm mb alts) -mkExpr nm tm mb (Cast expr c) = G2.Cast (mkExpr nm tm mb expr) (mkCoercion tm c) -mkExpr _ tm _ (Coercion c) = G2.Coercion (mkCoercion tm c) -mkExpr nm tm mb (Tick t expr) = +mkExpr :: Maybe ModBreaks -> CoreExpr -> G2.NamesM G2.Expr +mkExpr _ (Var var) = return . G2.Var =<< mkIdLookup var +mkExpr _ (Lit lit) = return $ G2.Lit (mkLit lit) +mkExpr mb (App fxpr axpr) = liftM2 G2.App (mkExpr mb fxpr) (mkExpr mb axpr) +mkExpr mb (Lam var expr) = liftM2 (G2.Lam (mkLamUse var)) (valId var) (mkExpr mb expr) +mkExpr mb (Let bnd expr) = liftM2 G2.Let (mkBind mb bnd) (mkExpr mb expr) +mkExpr mb (Case mxpr var t alts) = do + bindee <- mkExpr mb mxpr + binder <- valId var + ty <- mkType t + as <- mkAlts mb alts + return $ G2.Case bindee binder ty as +mkExpr mb (Cast expr c) = liftM2 G2.Cast (mkExpr mb expr) (mkCoercion c) +mkExpr _ (Coercion c) = liftM G2.Coercion (mkCoercion c) +mkExpr mb (Tick t expr) = case createTickish mb t of - Just t' -> G2.Tick t' $ mkExpr nm tm mb expr - Nothing -> mkExpr nm tm mb expr -mkExpr _ tm _ (Type ty) = G2.Type (mkType tm ty) + Just t' -> return . G2.Tick t' =<< mkExpr mb expr + Nothing -> mkExpr mb expr +mkExpr _ (Type ty) = liftM G2.Type (mkType ty) +#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0) +createTickish :: Maybe ModBreaks -> GenTickish i -> Maybe G2.Tickish +#else createTickish :: Maybe ModBreaks -> Tickish i -> Maybe G2.Tickish +#endif createTickish (Just mb) (Breakpoint {breakpointId = bid}) = case mkSpan $ modBreaks_locs mb A.! bid of Just s -> Just $ G2.Breakpoint $ s Nothing -> Nothing +createTickish _ (HpcTick { tickModule = md, tickId = i}) = + Just . G2.HpcTick i . T.pack . moduleNameString $ moduleName md createTickish _ _ = Nothing mkLamUse :: Id -> G2.LamUse @@ -409,30 +501,17 @@ | isTyVar v = G2.TypeL | otherwise = G2.TermL -mkId :: G2.TypeNameMap -> Id -> G2.Id -mkId tm vid = G2.Id ((mkName . V.varName) vid) ((mkType tm . varType) vid) - --- Makes an Id, not respecting UniqueIds -mkIdUnsafe :: Id -> G2.Id -mkIdUnsafe vid = G2.Id ((mkName . V.varName) vid) (mkType HM.empty . varType $ vid) - -mkIdLookup :: Id -> G2.NameMap -> G2.TypeNameMap -> G2.Id -mkIdLookup i nm tm = - let - n = mkNameLookup (V.varName i) nm - t = mkType tm . varType $ i - in - G2.Id n t +valId :: Id -> G2.NamesM G2.Id +valId vid = liftM2 G2.Id (valNameLookup . varName $ vid) (mkType . varType $ vid) -mkIdUpdatingNM :: Id -> G2.NameMap -> G2.TypeNameMap -> (G2.Id, G2.NameMap) -mkIdUpdatingNM vid nm tm = - let - n@(G2.Name n' m _ _) = flip mkNameLookup nm . V.varName $ vid - i = G2.Id n ((mkType tm . varType) vid) +typeId :: Id -> G2.NamesM G2.Id +typeId vid = liftM2 G2.Id (typeNameLookup . varName $ vid) (mkType . varType $ vid) - nm' = HM.insert (n', m) n nm - in - (i, nm') +mkIdLookup :: Id -> G2.NamesM G2.Id +mkIdLookup i = do + n <- valNameLookup (varName i) + t <- mkType . varType $ i + return $ G2.Id n t mkName :: Name -> G2.Name mkName name = G2.Name occ mdl unq sp @@ -445,15 +524,29 @@ sp = mkSpan $ getSrcSpan name -mkNameLookup :: Name -> G2.NameMap -> G2.Name -mkNameLookup name nm = +valNameLookup :: Name -> G2.NamesM G2.Name +valNameLookup n = do + (nm, tm) <- SM.get + (n', nm') <- nameLookup nm n + SM.put (nm', tm) + return n' + +typeNameLookup :: Name -> G2.NamesM G2.Name +typeNameLookup n = do + (nm, tm) <- SM.get + (n', tm') <- nameLookup tm n + SM.put (nm, tm') + return n' + +nameLookup :: HM.HashMap (T.Text, Maybe T.Text) G2.Name -> Name -> G2.NamesM (G2.Name, HM.HashMap (T.Text, Maybe T.Text) G2.Name) +nameLookup nm name = do -- We only lookup in the G2.NameMap if the Module name is not Nothing -- Internally, a module may use multiple variables with the same name and a module Nothing - case mdl of - Nothing -> G2.Name occ mdl unq sp - _ -> case HM.lookup (occ, mdl) nm of - Just (G2.Name n' m i _) -> G2.Name n' m i sp - Nothing -> G2.Name occ mdl unq sp + return $ case mdl of + Nothing -> (G2.Name occ mdl unq sp, nm) + _ -> case HM.lookup (occ, mdl) nm of + Just (G2.Name n' m i _) -> (G2.Name n' m i sp, nm) + Nothing -> let n = G2.Name occ mdl unq sp in (n, HM.insert (occ, mdl) n nm) where occ = T.pack . occNameString . nameOccName $ name unq = getKey . nameUnique $ name @@ -464,7 +557,11 @@ sp = mkSpan $ getSrcSpan name mkSpan :: SrcSpan -> Maybe G2.Span +#if MIN_VERSION_GLASGOW_HASKELL(9,0,2,0) +mkSpan (RealSrcSpan s _) = Just $ mkRealSpan s +#else mkSpan (RealSrcSpan s) = Just $ mkRealSpan s +#endif mkSpan _ = Nothing mkRealSpan :: RealSrcSpan -> G2.Span @@ -489,179 +586,242 @@ Nothing -> Just m mkLit :: Literal -> G2.Lit +#if __GLASGOW_HASKELL__ < 808 mkLit (MachChar chr) = G2.LitChar chr mkLit (MachStr bstr) = G2.LitString (C.unpack bstr) +#else +mkLit (LitChar chr) = G2.LitChar chr +mkLit (LitString bstr) = G2.LitString (C.unpack bstr) +#endif + +#if __GLASGOW_HASKELL__ < 806 mkLit (MachInt i) = G2.LitInt (fromInteger i) mkLit (MachInt64 i) = G2.LitInt (fromInteger i) mkLit (MachWord i) = G2.LitInt (fromInteger i) mkLit (MachWord64 i) = G2.LitInt (fromInteger i) +mkLit (LitInteger i _) = G2.LitInteger (fromInteger i) +#elif __GLASGOW_HASKELL__ <= 810 +mkLit (LitNumber LitNumInteger i _) = G2.LitInteger (fromInteger i) +mkLit (LitNumber LitNumNatural i _) = G2.LitInteger (fromInteger i) +mkLit (LitNumber LitNumInt i _) = G2.LitInt (fromInteger i) +mkLit (LitNumber LitNumInt64 i _) = G2.LitInt (fromInteger i) +mkLit (LitNumber LitNumWord i _) = G2.LitInt (fromInteger i) +mkLit (LitNumber LitNumWord64 i _) = G2.LitInt (fromInteger i) +#elif __GLASGOW_HASKELL__ <= 902 +mkLit (LitNumber LitNumInteger i) = G2.LitInteger (fromInteger i) +mkLit (LitNumber LitNumNatural i) = G2.LitInteger (fromInteger i) +mkLit (LitNumber LitNumInt i) = G2.LitInt (fromInteger i) +mkLit (LitNumber LitNumInt64 i) = G2.LitInt (fromInteger i) +mkLit (LitNumber LitNumWord i) = G2.LitInt (fromInteger i) +mkLit (LitNumber LitNumWord64 i) = G2.LitInt (fromInteger i) +#else +mkLit (LitNumber LitNumInt i) = G2.LitInt (fromInteger i) +mkLit (LitNumber LitNumInt64 i) = G2.LitInt (fromInteger i) +mkLit (LitNumber LitNumWord i) = G2.LitInt (fromInteger i) +mkLit (LitNumber LitNumWord64 i) = G2.LitInt (fromInteger i) +#endif + +#if __GLASGOW_HASKELL__ < 808 mkLit (MachFloat rat) = G2.LitFloat rat mkLit (MachDouble rat) = G2.LitDouble rat -mkLit (LitInteger i _) = G2.LitInteger (fromInteger i) +#else +mkLit (LitFloat rat) = G2.LitFloat rat +mkLit (LitDouble rat) = G2.LitDouble rat +#endif mkLit _ = error "mkLit: unhandled Lit" -- mkLit (MachNullAddr) = error "mkLit: MachNullAddr" -- mkLit (MachLabel _ _ _ ) = error "mkLit: MachLabel" -mkBind :: G2.NameMap -> G2.TypeNameMap -> Maybe ModBreaks -> CoreBind -> [(G2.Id, G2.Expr)] -mkBind nm tm mb (NonRec var expr) = [(mkId tm var, mkExpr nm tm mb expr)] -mkBind nm tm mb (Rec ves) = map (\(v, e) -> (mkId tm v, mkExpr nm tm mb e)) ves +mkBind :: Maybe ModBreaks -> CoreBind -> G2.NamesM [(G2.Id, G2.Expr)] +mkBind mb (NonRec var expr) = do + i <- valId var + e <- mkExpr mb expr + return [(i, e)] +mkBind mb (Rec ves) = mapM (\(v, e) -> do i <- valId v + e' <- mkExpr mb e + return (i, e')) ves -mkAlts :: G2.NameMap -> G2.TypeNameMap -> Maybe ModBreaks -> [CoreAlt] -> [G2.Alt] -mkAlts nm tm mb = map (mkAlt nm tm mb) +mkAlts :: Maybe ModBreaks -> [CoreAlt] -> G2.NamesM [G2.Alt] +mkAlts mb = mapM (mkAlt mb) -mkAlt :: G2.NameMap -> G2.TypeNameMap -> Maybe ModBreaks -> CoreAlt -> G2.Alt -mkAlt nm tm mb (acon, prms, expr) = G2.Alt (mkAltMatch nm tm acon prms) (mkExpr nm tm mb expr) +mkAlt :: Maybe ModBreaks -> CoreAlt -> G2.NamesM G2.Alt +#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0) +mkAlt mb (Alt acon prms expr) = liftM2 G2.Alt (mkAltMatch acon prms) (mkExpr mb expr) +#else +mkAlt mb (acon, prms, expr) = liftM2 G2.Alt (mkAltMatch acon prms) (mkExpr mb expr) +#endif -mkAltMatch :: G2.NameMap -> G2.TypeNameMap -> AltCon -> [Var] -> G2.AltMatch -mkAltMatch nm tm (DataAlt dcon) params = G2.DataAlt (mkData nm tm dcon) (map (mkId tm) params) -mkAltMatch _ _ (LitAlt lit) _ = G2.LitAlt (mkLit lit) -mkAltMatch _ _ (DEFAULT) _ = G2.Default +mkAltMatch :: AltCon -> [Var] -> G2.NamesM G2.AltMatch +mkAltMatch (DataAlt dcon) params = liftM2 G2.DataAlt (mkData dcon) (mapM valId params) +mkAltMatch (LitAlt lit) _ = return $ G2.LitAlt (mkLit lit) +mkAltMatch DEFAULT _ = return G2.Default -mkType :: G2.TypeNameMap -> Type -> G2.Type -mkType tm (TyVarTy v) = G2.TyVar $ mkId tm v -mkType tm (AppTy t1 t2) = G2.TyApp (mkType tm t1) (mkType tm t2) -mkType tm (FunTy t1 t2) = G2.TyFun (mkType tm t1) (mkType tm t2) -mkType tm (ForAllTy b ty) = G2.TyForAll (mkTyBinder tm b) (mkType tm ty) -mkType _ (LitTy _) = G2.TyBottom --- mkType _ (CastTy _ _) = error "mkType: CastTy" -mkType _ (CastTy _ _) = G2.TyUnknown -mkType _ (CoercionTy _) = G2.TyUnknown --- mkType _ (CoercionTy _) = error "mkType: Coercion" -mkType tm (TyConApp tc ts) +mkType :: Type -> G2.NamesM G2.Type +mkType (TyVarTy v) = liftM G2.TyVar $ typeId v +mkType (AppTy t1 t2) = liftM2 G2.TyApp (mkType t1) (mkType t2) +#if __GLASGOW_HASKELL__ < 808 +mkType (FunTy t1 t2) = liftM2 G2.TyFun (mkType t1) (mkType t2) +#elif __GLASGOW_HASKELL__ <= 810 +mkType (FunTy _ t1 t2) = liftM2 G2.TyFun (mkType t1) (mkType t2) +#else +mkType (FunTy _ _ t1 t2) = liftM2 G2.TyFun (mkType t1) (mkType t2) +#endif +mkType (ForAllTy b ty) = liftM2 G2.TyForAll (mkTyBinder b) (mkType ty) +mkType (LitTy _) = return G2.TyBottom +-- mkType (CastTy _ _) = error "mkType: CastTy" +mkType (CastTy _ _) = return G2.TyUnknown +mkType (CoercionTy _) = return G2.TyUnknown +-- mkType (CoercionTy _) = error "mkType: Coercion" +mkType (TyConApp tc ts) +#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0) +#else | isFunTyCon tc , length ts == 2 = case ts of - (t1:t2:[]) -> G2.TyFun (mkType tm t1) (mkType tm t2) + [t1, t2] -> liftM2 G2.TyFun (mkType t1) (mkType t2) _ -> error "mkType: non-arity 2 FunTyCon from GHC" - | G2.Name n _ _ _ <- mkName $ tyConName tc - , n == "TYPE" = G2.TYPE - | otherwise = mkG2TyCon (mkTyConName tm tc) (map (mkType tm) ts) (mkType tm $ tyConKind tc) +#endif + | G2.Name "Type" _ _ _ <- mkName $ tyConName tc = return G2.TYPE + | G2.Name "TYPE" _ _ _ <- mkName $ tyConName tc = return G2.TYPE + | G2.Name "->" _ _ _ <- mkName $ tyConName tc + , [_, _, t1, t2] <- ts = liftM2 G2.TyFun (mkType t1) (mkType t2) + | otherwise = liftM3 mkG2TyCon (mkTyConName tc) (mapM mkType ts) (mkType $ tyConKind tc) -mkTyCon :: G2.NameMap -> G2.TypeNameMap -> TyCon -> ((G2.NameMap, G2.TypeNameMap), Maybe G2.ProgramType) -mkTyCon nm tm t = case dcs of - Just dcs' -> ((nm'', tm''), Just (n, dcs')) - Nothing -> ((nm'', tm''), Nothing) - where - n@(G2.Name n' m _ _) = flip mkNameLookup tm . tyConName $ t - tm' = HM.insert (n', m) n tm +mkTyCon :: TyCon -> G2.NamesM (G2.Name, Maybe G2.AlgDataTy) +mkTyCon t = do + n@(G2.Name n' m _ _) <- typeNameLookup . tyConName $ t - nm' = foldr (uncurry HM.insert) nm - $ map (\n_@(G2.Name n'_ m_ _ _) -> ((n'_, m_), n_)) - $ map (flip mkNameLookup nm . dataConName) $ visibleDataCons (algTyConRhs t) + (nm, tm) <- SM.get + let tm' = HM.insert (n', m) n tm + + dc_names <- mapM (valNameLookup . dataConName) $ visibleDataCons (algTyConRhs t) + let nm' = foldr (uncurry HM.insert) nm + . map (\n_@(G2.Name n'_ m_ _ _) -> ((n'_, m_), n_)) + $ dc_names - bv = map (mkId tm) $ tyConTyVars t + bv <- mapM typeId $ tyConTyVars t - (nm'', tm'', dcs, dcsf) = + dcs <- case isAlgTyCon t of - True -> case algTyConRhs t of - DataTyCon { data_cons = dc } -> - ( nm' - , tm' - , Just $ G2.DataTyCon bv $ map (mkData nm' tm) dc - , Just $ map (mkId tm'' . dataConWorkId) dc) + True -> do + SM.put (nm', tm') + case algTyConRhs t of + DataTyCon { data_cons = dc } -> do + dcs <- mapM mkData dc + return . Just $ G2.DataTyCon bv dcs NewTyCon { data_con = dc - , nt_rhs = rhst} -> - ( nm' - , tm' - , Just $ G2.NewTyCon { G2.bound_ids = bv - , G2.data_con = mkData nm' tm dc - , G2.rep_type = mkType tm rhst} - , Just $ [(mkId tm'' . dataConWorkId) dc]) + , nt_rhs = rhst} -> do + dc' <- mkData dc + t' <- mkType rhst + return . + Just $ G2.NewTyCon { G2.bound_ids = bv + , G2.data_con = dc' + , G2.rep_type = t'} AbstractTyCon {} -> error "Unhandled TyCon AbstractTyCon" -- TupleTyCon {} -> error "Unhandled TyCon TupleTyCon" - TupleTyCon { data_con = dc } -> - ( nm' - , tm' - , Just $ G2.DataTyCon bv $ [mkData nm' tm dc] - , Nothing) + TupleTyCon { data_con = dc } -> do + dc' <- mkData dc + return . Just $ G2.DataTyCon bv $ [dc'] SumTyCon {} -> error "Unhandled TyCon SumTyCon" False -> case isTypeSynonymTyCon t of - True -> - let - (tv, st) = fromJust $ synTyConDefn_maybe t - st' = mkType tm st - tv' = map (mkId tm) tv - in - (nm, tm', Just $ G2.TypeSynonym { G2.bound_ids = tv' - , G2.synonym_of = st'}, Nothing) - False -> (nm, tm, Nothing, Nothing) - -- dcs = if isDataTyCon t then map mkData . data_cons . algTyConRhs $ t else [] + True -> do + SM.put (nm, tm') + let (tv, st) = fromJust $ synTyConDefn_maybe t + st' <- mkType st + tv' <- mapM typeId tv + return . Just $ G2.TypeSynonym { G2.bound_ids = tv' + , G2.synonym_of = st'} + False -> return Nothing -mkTyConName :: G2.TypeNameMap -> TyCon -> G2.Name -mkTyConName tm tc = - let - n@(G2.Name n' m _ l) = mkName $ tyConName tc - in - case HM.lookup (n', m) tm of - Just (G2.Name n'' m' i _) -> G2.Name n'' m' i l - Nothing -> n + case dcs of + Just dcs' -> return (n, Just dcs') + Nothing -> return (n, Nothing) -mkData :: G2.NameMap -> G2.TypeNameMap -> DataCon -> G2.DataCon -mkData nm tm datacon = G2.DataCon name ty - where - name = mkDataName nm datacon - ty = (mkType tm . dataConRepType) datacon +mkTyConName :: TyCon -> G2.NamesM G2.Name +mkTyConName tc = typeNameLookup (tyConName tc) -mkDataName :: G2.NameMap -> DataCon -> G2.Name -mkDataName nm datacon = (flip mkNameLookup nm . dataConName) datacon +mkData :: DataCon -> G2.NamesM G2.DataCon +mkData datacon = do + name <- mkDataName datacon + ty <- (mkType . dataConRepType) datacon + return $ G2.DataCon name ty -mkTyBinder :: G2.TypeNameMap -> TyVarBinder -> G2.TyBinder -mkTyBinder tm (TvBndr v _) = G2.NamedTyBndr (mkId tm v) +mkDataName :: DataCon -> G2.NamesM G2.Name +mkDataName datacon = valNameLookup . dataConName $ datacon -prim_list :: [String] -prim_list = [">=", ">", "==", "/=", "<=", "<", - "&&", "||", "not", - "+", "-", "*", "/", "implies", "negate", "error", "iff" ] +mkTyBinder :: TyVarBinder -> G2.NamesM G2.Id +#if __GLASGOW_HASKELL__ < 808 +mkTyBinder (TvBndr v _) = typeId v +#else +mkTyBinder (Bndr v _) = typeId v +#endif +mkCoercion :: Coercion -> G2.NamesM G2.Coercion +mkCoercion c = do + let (Pair t1 t2) = coercionKind c + t1' <- mkType t1 + t2' <- mkType t2 + return $ t1' G2.:~ t2' -mkCoercion :: G2.TypeNameMap -> Coercion -> G2.Coercion -mkCoercion tm c = - let - k = fmap (mkType tm) $ coercionKind c - in - (pFst k) G2.:~ (pSnd k) +mkClass :: ClsInst -> G2.NamesM (G2.Name, G2.Id, [G2.Id], [(G2.Type, G2.Id)]) +mkClass (ClsInst { is_cls = c, is_dfun = dfun }) = do + class_name <- typeNameLookup . className $ c + i <- valId dfun + tyvars <- mapM typeId $ classTyVars c -mkClass :: G2.TypeNameMap -> ClsInst -> (G2.Name, G2.Id, [G2.Id]) -mkClass tm (ClsInst { is_cls = c, is_dfun = dfun }) = - (flip mkNameLookup tm . C.className $ c, mkId tm dfun, map (mkId tm) $ C.classTyVars c) + sctheta <- mapM mkType $ classSCTheta c + sel_ids <- mapM mkIdLookup $ classAllSelIds c + let sctheta_selids = zip sctheta sel_ids + return ( class_name + , i + , tyvars + , sctheta_selids) -mkRewriteRule :: G2.NameMap -> G2.TypeNameMap -> Maybe ModBreaks -> CoreRule -> Maybe G2.RewriteRule -mkRewriteRule nm tm breaks (Rule { ru_name = n - , ru_fn = fn - , ru_rough = rough - , ru_bndrs = bndrs - , ru_args = args - , ru_rhs = rhs }) = - let - r = G2.RewriteRule { G2.ru_name = T.pack $ unpackFS n - , G2.ru_head = mkNameLookup fn nm - , G2.ru_rough = map (fmap (flip mkNameLookup nm)) rough - , G2.ru_bndrs = map (mkId tm) bndrs - , G2.ru_args = map (mkExpr nm tm breaks) args - , G2.ru_rhs = mkExpr nm tm breaks rhs } - in - Just r -mkRewriteRule _ _ _ _ = Nothing +mkRewriteRule :: Maybe ModBreaks -> CoreRule -> G2.NamesM (Maybe G2.RewriteRule) +mkRewriteRule breaks (Rule { ru_name = n + , ru_origin = mdl + , ru_fn = fn + , ru_rough = rough + , ru_bndrs = bndrs + , ru_args = args + , ru_rhs = rhs }) = do + head_name <- valNameLookup fn + rough' <- mapM (maybe (return Nothing) (\nm -> return . Just =<< valNameLookup nm)) rough + bndrs' <- mapM valId bndrs + args' <- mapM (mkExpr breaks) args + rhs' <- mkExpr breaks rhs + let r = G2.RewriteRule { G2.ru_name = T.pack $ unpackFS n + , G2.ru_module = T.pack . moduleNameString $ moduleName mdl + , G2.ru_head = head_name + , G2.ru_rough = rough' + , G2.ru_bndrs = bndrs' + , G2.ru_args = args' + , G2.ru_rhs = rhs' } + return $ Just r +mkRewriteRule _ _ = return Nothing exportedNames :: ModDetails -> [G2.ExportedName] exportedNames = concatMap availInfoNames . md_exports availInfoNames :: AvailInfo -> [G2.ExportedName] +#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0) +availInfoNames (Avail n) = [greNameToName n] +availInfoNames (AvailTC n ns) = mkName n:map greNameToName ns + +greNameToName :: GreName -> G2.Name +greNameToName (NormalGreName n) = mkName n +greNameToName (FieldGreName fl) = mkName $ flSelector fl +#else availInfoNames (Avail n) = [mkName n] availInfoNames (AvailTC n ns _) = mkName n:map mkName ns +#endif -- | absVarLoc' -- Switches all file paths in Var namesand Ticks to be absolute -absVarLoc :: G2.Program -> IO G2.Program -absVarLoc = - mapM - (mapM (\(i, e) -> do - e' <- absVarLoc' e - return (i, e') - ) - ) - +absVarLoc :: HM.HashMap G2.Name G2.Expr -> IO (HM.HashMap G2.Name G2.Expr) +absVarLoc = mapM absVarLoc' + absVarLoc' :: G2.Expr -> IO G2.Expr absVarLoc' (G2.Var (G2.Id (G2.Name n m i (Just s)) t)) = do return $ G2.Var $ G2.Id (G2.Name n m i (Just $ s)) t @@ -677,10 +837,10 @@ ) b e' <- absVarLoc' e return $ G2.Let b' e' -absVarLoc' (G2.Case e i as) = do +absVarLoc' (G2.Case e i t as) = do e' <- absVarLoc' e as' <- mapM (\(G2.Alt a ae) -> return . G2.Alt a =<< absVarLoc' ae) as - return $ G2.Case e' i as' + return $ G2.Case e' i t as' absVarLoc' (G2.Cast e c) = do e' <- absVarLoc' e return $ G2.Cast e' c @@ -783,6 +943,7 @@ [] -> return $ takeDirectory absTgt dirContainsCabal :: FilePath -> IO Bool +dirContainsCabal "" = return False dirContainsCabal dir = do exists <- doesDirectoryExist dir if exists then do @@ -796,3 +957,23 @@ dir <- guessProj fp files <- listDirectory dir return $ find (\f -> ".cabal" `isSuffixOf` f) files + +------------------------------------------------------------------------------- +-- Unsafe construction +------------------------------------------------------------------------------- + +mkUnsafe :: G2.NamesM a -> a +mkUnsafe nms = SM.evalState nms (HM.empty, HM.empty) + +-- | Makes an Id, not respecting uniques +mkIdUnsafe :: Id -> G2.Id +mkIdUnsafe vid = + mkUnsafe (liftM2 G2.Id (return . mkName . varName $ vid) (mkType . varType $ vid)) + +-- | Makes a TyCon, not respecting uniques +mkTyConNameUnsafe :: TyCon -> G2.Name +mkTyConNameUnsafe tc = mkUnsafe (mkTyConName tc) + +-- | Makes a Data, not respecting uniques +mkDataUnsafe :: DataCon -> G2.DataCon +mkDataUnsafe dc = mkUnsafe (mkData dc) diff --git a/src/G2/Translation/HaskellCheck.hs b/src/G2/Translation/HaskellCheck.hs --- a/src/G2/Translation/HaskellCheck.hs +++ b/src/G2/Translation/HaskellCheck.hs @@ -1,8 +1,7 @@ module G2.Translation.HaskellCheck ( validateStates , runHPC) where -import DynFlags -import GHC hiding (Name) +import GHC hiding (Name, entry) import GHC.Paths import Data.Either @@ -22,28 +21,61 @@ import System.Process +import Control.Monad.IO.Class + validateStates :: [FilePath] -> [FilePath] -> String -> String -> [String] -> [GeneralFlag] -> [ExecRes t] -> IO Bool -validateStates proj src modN entry chAll ghflags in_out = do - return . all id =<< mapM (runCheck proj src modN entry chAll ghflags) in_out +validateStates proj src modN entry chAll gflags in_out = do + return . all id =<< runGhc (Just libdir) (do + loadToCheck proj src modN gflags + mapM (runCheck modN entry chAll) in_out) -- Compile with GHC, and check that the output we got is correct for the input -runCheck :: [FilePath] -> [FilePath] -> String -> String -> [String] -> [GeneralFlag] -> ExecRes t -> IO Bool -runCheck proj src modN entry chAll gflags (ExecRes {final_state = s, conc_args = ars, conc_out = out}) = do - (v, chAllR) <- runGhc (Just libdir) (runCheck' proj src modN entry chAll gflags s ars out) +runCheck :: String -> String -> [String] -> ExecRes t -> Ghc Bool +runCheck modN entry chAll (ExecRes {final_state = s, conc_args = ars, conc_out = out}) = do + (v, chAllR) <- runCheck' modN entry chAll s ars out - v' <- unsafeCoerce v :: IO (Either SomeException Bool) - let outStr = mkCleanExprHaskell s out + v' <- liftIO $ (unsafeCoerce v :: IO (Either SomeException Bool)) + let outStr = T.unpack $ printHaskell s out let v'' = case v' of Left _ -> outStr == "error" Right b -> b && outStr /= "error" - chAllR' <- unsafeCoerce chAllR :: IO [Either SomeException Bool] + chAllR' <- liftIO $ (unsafeCoerce chAllR :: IO [Either SomeException Bool]) let chAllR'' = rights chAllR' return $ v'' && and chAllR'' -runCheck' :: [FilePath] -> [FilePath] -> String -> String -> [String] -> [GeneralFlag] -> State t -> [Expr] -> Expr -> Ghc (HValue, [HValue]) -runCheck' proj src modN entry chAll gflags s ars out = do +runCheck' :: String -> String -> [String] -> State t -> [Expr] -> Expr -> Ghc (HValue, [HValue]) +runCheck' modN entry chAll s ars out = do + let Left (v, _) = findFunc (T.pack entry) (Just $ T.pack modN) (expr_env s) + let e = mkApp $ Var v:ars + let pg = updatePrettyGuide (exprNames e) + . updatePrettyGuide (exprNames out) + $ mkPrettyGuide $ varIds v + let arsStr = T.unpack $ printHaskellPG pg s e + let outStr = T.unpack $ printHaskellPG pg s out + + let arsType = T.unpack $ mkTypeHaskell (typeOf e) + outType = T.unpack $ mkTypeHaskell (typeOf out) + + let chck = case outStr == "error" of + False -> "try (evaluate (" ++ arsStr ++ " == " ++ "(" + ++ outStr ++ " :: " ++ outType ++ ")" ++ ")) :: IO (Either SomeException Bool)" + True -> "try (evaluate ( (" ++ arsStr ++ " :: " ++ arsType ++ + ") == " ++ arsStr ++ ")) :: IO (Either SomeException Bool)" + + v' <- compileExpr chck + + let chArgs = ars ++ [out] + let chAllStr = map (\f -> T.unpack $ printHaskellPG pg s $ mkApp ((simpVar $ T.pack f):chArgs)) chAll + let chAllStr' = map (\str -> "try (evaluate (" ++ str ++ ")) :: IO (Either SomeException Bool)") chAllStr + + chAllR <- mapM compileExpr chAllStr' + + return $ (v', chAllR) + +loadToCheck :: [FilePath] -> [FilePath] -> String -> [GeneralFlag] -> Ghc () +loadToCheck proj src modN gflags = do _ <- loadProj Nothing proj src gflags simplTranslationConfig let prN = mkModuleName "Prelude" @@ -52,28 +84,16 @@ let exN = mkModuleName "Control.Exception" let exImD = simpleImportDecl exN - let mdN = mkModuleName modN - let imD = simpleImportDecl mdN - - setContext [IIDecl prImD, IIDecl exImD, IIDecl imD] - - let Left (v, _) = findFunc (T.pack entry) (Just $ T.pack modN) (expr_env s) - let e = mkApp $ Var v:ars - let arsStr = mkCleanExprHaskell s e - let outStr = mkCleanExprHaskell s out - let chck = case outStr == "error" of - False -> "try (evaluate (" ++ arsStr ++ " == " ++ outStr ++ ")) :: IO (Either SomeException Bool)" - True -> "try (evaluate (" ++ arsStr ++ " == " ++ arsStr ++ ")) :: IO (Either SomeException Bool)" - - v' <- compileExpr chck + let coerceN = mkModuleName "Data.Coerce" + let coerceImD = simpleImportDecl coerceN - let chArgs = ars ++ [out] - let chAllStr = map (\f -> mkCleanExprHaskell s $ mkApp ((simpVar $ T.pack f):chArgs)) chAll - let chAllStr' = map (\str -> "try (evaluate (" ++ str ++ ")) :: IO (Either SomeException Bool)") chAllStr + let charN = mkModuleName "Data.Char" + let charD = simpleImportDecl charN - chAllR <- mapM compileExpr chAllStr' + let mdN = mkModuleName modN + let imD = simpleImportDecl mdN - return $ (v', chAllR) + setContext [IIDecl prImD, IIDecl exImD, IIDecl coerceImD, IIDecl imD, IIDecl charD] simpVar :: T.Text -> Expr simpVar s = Var (Id (Name s Nothing 0 Nothing) TyBottom) @@ -108,7 +128,7 @@ -- putStrLn mainFunc toCall :: String -> State t -> [Expr] -> Expr -> String -toCall entry s ars _ = mkCleanExprHaskell s $ mkApp ((simpVar $ T.pack entry):ars) +toCall entry s ars _ = T.unpack . printHaskell s $ mkApp ((simpVar $ T.pack entry):ars) removeModule :: String -> String -> String removeModule modN s = diff --git a/src/G2/Translation/InjectSpecials.hs b/src/G2/Translation/InjectSpecials.hs --- a/src/G2/Translation/InjectSpecials.hs +++ b/src/G2/Translation/InjectSpecials.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP, OverloadedStrings #-} module G2.Translation.InjectSpecials ( specialTypes @@ -14,8 +14,8 @@ _MAX_TUPLE :: Int _MAX_TUPLE = 62 -specialTypes :: [ProgramType] -specialTypes = map (uncurry specialTypes') specials +specialTypes :: HM.HashMap Name AlgDataTy +specialTypes = HM.fromList $ map (uncurry specialTypes') specials ++ mkPrimTuples _MAX_TUPLE specialTypes' :: (T.Text, Maybe T.Text, [Name]) -> [(T.Text, Maybe T.Text, [Type])] -> (Name, AlgDataTy) specialTypes' (n, m, ns) dcn = @@ -31,22 +31,25 @@ tv = map (TyVar . flip Id TYPE) ns t = foldr (TyFun) (mkFullAppedTyCon tn tv TYPE) ts - t' = foldr (\n' -> TyForAll (NamedTyBndr (Id n' TYPE))) t ns + t' = foldr (\n' -> TyForAll (Id n' TYPE)) t ns in DataCon (Name n m 0 Nothing) t' specialTypeNames :: HM.HashMap (T.Text, Maybe T.Text) Name -specialTypeNames = HM.fromList $ map (\(n, m, _) -> ((n, m), Name n m 0 Nothing)) specialTypeNames' +specialTypeNames = -- HM.fromList $ map (\(n, m, _) -> ((n, m), Name n m 0 Nothing)) specialTypeNames' + HM.fromList . map (\nm@(Name n m _ _) -> ((n, m), nm)) $ HM.keys specialTypes specialConstructors :: HM.HashMap (T.Text, Maybe T.Text) Name specialConstructors = - HM.fromList $ map (\nm@(n, m) -> (nm, Name n m 0 Nothing)) specialConstructors' + -- GHC 9.4 on use different constructors than our base for Integers, so we add a special mapping + -- for those constructor (via `integerConstructor` to adjust Names accordingly) + HM.fromList $ integerConstructor:map (\(DataCon nm@(Name n m _ _) _)-> ((n, m), nm)) specialConstructors' -specialTypeNames' :: [(T.Text, Maybe T.Text, [Name])] -specialTypeNames' = map fst specials +integerConstructor :: ((T.Text, Maybe T.Text), Name) +integerConstructor = (("IS", Just "GHC.Num.Integer"), Name "Z#" (Just "GHC.Num.Integer") 0 Nothing) -specialConstructors' :: [(T.Text, Maybe T.Text)] -specialConstructors' = map (\(n, m, _) -> (n, m)) $ concatMap snd specials +specialConstructors' :: [DataCon] +specialConstructors' = concatMap data_cons $ HM.elems specialTypes -- map (\(n, m, _) -> (n, m)) $ concatMap snd specials aName :: Name aName = Name "a" Nothing 0 Nothing @@ -54,33 +57,44 @@ aTyVar :: Type aTyVar = TyVar (Id aName TYPE) +listTypeStr :: T.Text +#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0) +listTypeStr = "List" +#else +listTypeStr = "[]" +#endif + listName :: Name -listName = Name "[]" (Just "GHC.Types") 0 Nothing +listName = Name listTypeStr (Just "GHC.Types") 0 Nothing specials :: [((T.Text, Maybe T.Text, [Name]), [(T.Text, Maybe T.Text, [Type])])] -specials = [ (( "[]" +specials = + [ (( listTypeStr , Just "GHC.Types", [aName]) , [ ("[]", Just "GHC.Types", []) , (":", Just "GHC.Types", [aTyVar, mkFullAppedTyCon listName [aTyVar] TYPE])] ) - -- , (("Int", Just "GHC.Types"), [("I#", Just "GHC.Types", [TyLitInt])]) -- , (("Float", Just "GHC.Types"), [("F#", Just "GHC.Types", [TyLitFloat])]) -- , (("Double", Just "GHC.Types"), [("D#", Just "GHC.Types", [TyLitDouble])]) -- , (("Char", Just "GHC.Types"), [("C#", Just "GHC.Types", [TyLitChar])]) -- , (("String", Just "GHC.Types"), []) - , (("Bool", Just "GHC.Types", []), [ ("True", Just "GHC.Types", []) - , ("False", Just "GHC.Types", [])]) + , (("Bool", Just "GHC.Types", []), [ ("False", Just "GHC.Types", []) + , ("True", Just "GHC.Types", [])]) -- , (("Ordering", Just "GHC.Types"), [ ("EQ", Just "GHC.Types", []) -- , ("LT", Just "GHC.Types", []) -- , ("GT", Just "GHC.Types", [])]) ] ++ +#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0) + mkTuples "(" ")" (Just "GHC.Tuple.Prim") _MAX_TUPLE +#else mkTuples "(" ")" (Just "GHC.Tuple") _MAX_TUPLE - ++ - mkTuples "(#" "#)" (Just "GHC.Prim") _MAX_TUPLE +#endif + -- ++ + -- mkTuples "(#" "#)" (Just "GHC.Prim") _MAX_TUPLE mkTuples :: T.Text -> T.Text -> Maybe T.Text -> Int -> [((T.Text, Maybe T.Text, [Name]), [(T.Text, Maybe T.Text, [Type])])] @@ -94,3 +108,34 @@ in -- ((s, m, []), [(s, m, [])]) : mkTuples (n - 1) ((s, m, ns), [(s, m, tv)]) : mkTuples ls rs m (n - 1) + +mkPrimTuples :: Int -> [(Name, AlgDataTy)] +mkPrimTuples k = + let + dcn = mkPrimTuples' k + in + map (\(n, m, ns, dc) -> + let + tn = Name n m 0 Nothing + in + (tn, DataTyCon {bound_ids = map (flip Id TYPE) ns, data_cons = [dc]})) dcn + +mkPrimTuples' :: Int -> [(T.Text, Maybe T.Text, [Name], DataCon)] +mkPrimTuples' n | n < 0 = [] + | otherwise = + let + s = "(#" `T.append` T.pack (replicate n ',') `T.append` "#)" + m = Just "GHC.Prim" + tn = Name s m 0 Nothing + + ns = if n == 0 then [] else map (\i -> Name "a" m i Nothing) [0..n] + rt_ns = if n == 0 then [] else map (\i -> Name "rt_" m i Nothing) [0..n] + tv = map (TyVar . flip Id TYPE) ns + + t = foldr (TyFun) (mkFullAppedTyCon tn tv TYPE) tv + t' = foldr (\n' -> TyForAll (Id n' TYPE)) t ns + t'' = foldr (\n' -> TyForAll (Id n' TYPE)) t' rt_ns + dc = DataCon (Name s m 0 Nothing) t'' + in + -- ((s, m, []), [(s, m, [])]) : mkTuples (n - 1) + (s, m, rt_ns ++ ns, dc) : mkPrimTuples' (n - 1) diff --git a/src/G2/Translation/Interface.hs b/src/G2/Translation/Interface.hs --- a/src/G2/Translation/Interface.hs +++ b/src/G2/Translation/Interface.hs @@ -1,138 +1,133 @@ -module G2.Translation.Interface ( translateLoaded - , translateLoadedD ) where +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} -import DynFlags +module G2.Translation.Interface ( translateBase + , translateLoaded + , specialInject ) where +import Control.Monad.Extra +import qualified Data.HashMap.Lazy as HM import Data.List import Data.Maybe import qualified Data.Text as T +import System.Directory import G2.Config -import G2.Language +import G2.Language as G2 +import G2.Translation.GHC import G2.Translation.Haskell import G2.Translation.InjectSpecials import G2.Translation.PrimInject import G2.Translation.TransTypes - translateBase :: TranslationConfig -> Config + -> [FilePath] -> Maybe HscTarget -> IO (ExtractedG2, NameMap, TypeNameMap) -translateBase tr_con config hsc = do +translateBase tr_con config extra hsc = do -- For base we have the advantage of knowing apriori the structure -- So we can list the (proj, file) pairings let base_inc = baseInclude config - let bases = base config - - translateLibPairs specialConstructors specialTypeNames tr_con config emptyExtractedG2 hsc base_inc bases + let bases = nub $ base config ++ extra + (base_exg2, b_nm, b_tnm) <- translateLibPairs specialConstructors specialTypeNames tr_con emptyExtractedG2 hsc base_inc bases -translateLibs :: NameMap - -> TypeNameMap - -> TranslationConfig - -> Config - -> Maybe HscTarget - -> [FilePath] - -> IO (ExtractedG2, NameMap, TypeNameMap) -translateLibs nm tm tr_con config hsc fs = do - -- If we are not given anything, then we have to guess the project - let inc = map (dropWhileEnd (/= '/')) fs - translateLibPairs nm tm tr_con config emptyExtractedG2 hsc inc fs + let base_prog = exg2_binds base_exg2 + base_tys = exg2_tycons base_exg2 + let base_tys' = base_tys `HM.union` specialTypes + let base_prog' = addPrimsToBase base_tys' base_prog + return (base_exg2 { exg2_binds = base_prog', exg2_tycons = base_tys' }, b_nm, b_tnm) translateLibPairs :: NameMap -> TypeNameMap -> TranslationConfig - -> Config -> ExtractedG2 -> Maybe HscTarget -> [IncludePath] -> [FilePath] -> IO (ExtractedG2, NameMap, TypeNameMap) -translateLibPairs nm tnm _ _ exg2 _ _ [] = return (exg2, nm, tnm) -translateLibPairs nm tnm tr_con config exg2 hsc inc_paths (f: fs) = do +translateLibPairs nm tnm _ exg2 _ _ [] = return (exg2, nm, tnm) +translateLibPairs nm tnm tr_con exg2 hsc inc_paths (f: fs) = do (new_nm, new_tnm, exg2') <- hskToG2ViaCgGutsFromFile hsc inc_paths [f] nm tnm tr_con - translateLibPairs new_nm new_tnm tr_con config (mergeExtractedG2s [exg2, exg2']) hsc inc_paths fs + translateLibPairs new_nm new_tnm tr_con (mergeExtractedG2s [exg2, exg2']) hsc inc_paths fs +#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0) +selectBackend :: TranslationConfig -> Maybe Backend +selectBackend tr | interpreter tr = Just interpreterBackend +selectBackend _ = Just noBackend +#elif MIN_VERSION_GLASGOW_HASKELL(9,2,0,0) +selectBackend :: TranslationConfig -> Maybe Backend +selectBackend tr | interpreter tr = Just Interpreter +selectBackend _ = Just NoBackend +#else +selectBackend :: TranslationConfig -> Maybe HscTarget +selectBackend tr | interpreter tr = Just HscInterpreted +selectBackend _ = Just HscNothing +#endif + translateLoaded :: [FilePath] -> [FilePath] - -> [FilePath] -> TranslationConfig -> Config -> IO (Maybe T.Text, ExtractedG2) -translateLoaded proj src libs tr_con config = do - (base_exg2, b_nm, b_tnm) <- translateBase tr_con config Nothing - let base_prog = [exg2_binds base_exg2] - base_tys = exg2_tycons base_exg2 - b_exp = exg2_exports base_exg2 - - - (lib_transs, lib_nm, lib_tnm) <- translateLibs b_nm b_tnm tr_con config (Just HscInterpreted) libs - let lib_exp = exg2_exports lib_transs - - let base_tys' = base_tys ++ specialTypes - let base_prog' = addPrimsToBase base_tys' base_prog - let base_trans' = base_exg2 { exg2_binds = concat base_prog', exg2_tycons = base_tys' } - - let merged_lib = mergeExtractedG2s ([base_trans', lib_transs]) - - -- Now the stuff with the actual target +translateLoaded proj src tr_con config = do + let tr_con' = tr_con { hpc_ticks = hpc config || search_strat config == Subpath } + -- Stuff with the actual target let def_proj = extraDefaultInclude config - def_src = extraDefaultMods config - (_, _, exg2) <- hskToG2ViaCgGutsFromFile (Just HscInterpreted) (def_proj ++ proj) (def_src ++ src) lib_nm lib_tnm tr_con - let mb_modname = listToMaybe . drop (length def_src) $ exg2_mod_names exg2 - let h_exp = exg2_exports exg2 + tar_ems <- envModSumModGutsFromFile (selectBackend tr_con') (def_proj ++ proj) src tr_con' + let imports = envModSumModGutsImports tar_ems + extra_imp <- return . catMaybes =<< mapM (findImports (baseInclude config)) imports - let merged_exg2 = mergeExtractedG2s [exg2, merged_lib] - merged_prog = [exg2_binds merged_exg2] - merged_tys = exg2_tycons merged_exg2 - merged_cls = exg2_classes merged_exg2 + -- Stuff with the base library + (base_exg2, b_nm, b_tnm) <- translateBase tr_con' config extra_imp Nothing - -- final injection phase - let (near_final_prog, final_tys) = primInject $ dataInject merged_prog merged_tys + -- Now the stuff with the actual target + (f_nm, f_tm, exg2) <- hskToG2ViaEMS tr_con' tar_ems b_nm b_tnm + let mb_modname = head $ exg2_mod_names exg2 + let exg2' = adjustMkSymbolicPrim f_nm exg2 - let final_merged_cls = primInject merged_cls + let merged_exg2 = mergeExtractedG2s [exg2', base_exg2] + let injected_exg2@ExtractedG2 { exg2_binds = near_final_prog } = specialInject merged_exg2 final_prog <- absVarLoc near_final_prog - let final_exg2 = merged_exg2 { exg2_binds = concat final_prog - , exg2_tycons = final_tys - , exg2_classes = final_merged_cls - , exg2_exports = b_exp ++ lib_exp ++ h_exp} + let final_exg2 = injected_exg2 { exg2_binds = final_prog } return (mb_modname, final_exg2) -translateLoadedD :: [FilePath] - -> [FilePath] - -> [FilePath] - -> TranslationConfig - -> IO (Maybe T.Text, Program, [ProgramType], [(Name, Id, [Id])], [Name]) -translateLoadedD proj src libs tr_con = do - -- Read the extracted libs and merge them - -- Recall that each of these files comes with NameMap and TypeNameMap - (nm, tnm, libs_g2) <- mapM readFileExtractedG2 libs >>= return . mergeFileExtractedG2s - - -- Now do the target file - (nm2, tnm2, tgt_g2) <- hskToG2ViaCgGutsFromFile (Just HscInterpreted) proj src nm tnm tr_con - - -- Combine the library g2 and extracted g2s - -- Also do absVarLoc! - let almost_g2 = mergeExtractedG2s [libs_g2, tgt_g2] - let almost_prog = [exg2_binds almost_g2] - - -- Inject the primitive stuff - let final_classes = primInject $ exg2_classes almost_g2 - let (pre_prog, final_tycons) = primInject $ dataInject almost_prog $ exg2_tycons almost_g2 - - final_prog <- absVarLoc pre_prog - - let name = listToMaybe $ exg2_mod_names tgt_g2 - let exports = exg2_exports almost_g2 +adjustMkSymbolicPrim :: NameMap -> ExtractedG2 -> ExtractedG2 +adjustMkSymbolicPrim nm exg2@(ExtractedG2 { exg2_binds = binds}) = + let + a = Id (Name "a" Nothing 0 Nothing) TYPE + m_sym_n = HM.lookup ("symgen", Just "G2.Symbolic") nm + symgen_e = G2.Lam TypeL a (SymGen SLog $ TyVar a) + in + case m_sym_n of + Just sym_n -> exg2 { exg2_binds = HM.insert sym_n symgen_e binds } + Nothing -> exg2 - return (name, - final_prog, - final_tycons, - final_classes, - exports) +specialInject :: ExtractedG2 -> ExtractedG2 +specialInject exg2 = + let + prog = exg2_binds exg2 + tys = exg2_tycons exg2 + rules = exg2_rules exg2 + cls = exg2_classes exg2 + + (prog', tys', rules') = primInject $ dataInject (prog, tys, rules) tys + cls' = primInject cls + in + exg2 { exg2_binds = prog' + , exg2_tycons = tys' + , exg2_rules = rules' + , exg2_classes = cls' } +findImports :: [FilePath] -> FilePath -> IO (Maybe FilePath) +findImports roots fp = do + let fp' = map (\c -> if c == '.' then '/' else c) fp + mr <- findM (\r -> doesFileExist $ r ++ fp' ++ ".hs") roots + case mr of + Just r -> return . Just $ r ++ fp' ++ ".hs" + Nothing -> return Nothing diff --git a/src/G2/Translation/PrimInject.hs b/src/G2/Translation/PrimInject.hs --- a/src/G2/Translation/PrimInject.hs +++ b/src/G2/Translation/PrimInject.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE CPP, FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -- | Primitive inejction into the environment @@ -16,6 +16,7 @@ import G2.Language.Typing import G2.Language.TypeEnv +import qualified Data.HashMap.Lazy as HM import Data.List import qualified Data.Text as T @@ -31,12 +32,12 @@ primInjectT (TyCon (Name "Char#" _ _ _) _) = TyLitChar primInjectT t = t -dataInject :: Program -> [ProgramType] -> (Program, [ProgramType]) +dataInject :: (ASTContainer t Expr) => t -> HM.HashMap Name AlgDataTy -> t dataInject prog progTy = let - dcNames = concatMap (\(_, dc) -> map conName (dataCon dc)) $ progTy + dcNames = concatMap (map conName . dataCon) $ progTy in - (modifyASTs (dataInject' dcNames) prog, progTy) + modifyASTs (dataInject' dcNames) prog -- TODO: Polymorphic types? dataInject' :: [(Name, [Type])] -> Expr -> Expr @@ -49,74 +50,130 @@ conName :: DataCon -> (Name, [Type]) conName (DataCon n t) = (n, anonArgumentTypes $ t) -primDefs :: [ProgramType] -> [(T.Text, Expr)] -primDefs pt = case boolName pt of - Just n -> primDefs' n - Nothing -> error "Bool type not found" +primDefs :: HM.HashMap Name AlgDataTy -> [(T.Text, Expr)] +primDefs pt = case (boolName pt, charName pt, listName pt) of + (Just b, Just c, Just l) -> primDefs' b c l + _ -> error "primDefs: Required types not found" -primDefs' :: Name -> [(T.Text, Expr)] -primDefs' b = [ ("==#", Prim Eq $ tyIntIntBool b) - , ("/=#", Prim Neq $ tyIntIntBool b) +primDefs' :: Name -> Name -> Name -> [(T.Text, Expr)] +primDefs' b c l = + [ ("$==#", Prim Eq $ tyIntIntBool b) + , ("$/=#", Prim Neq $ tyIntIntBool b) , ("+#", Prim Plus tyIntIntInt) , ("*#", Prim Mult tyIntIntInt) , ("-#", Prim Minus tyIntIntInt) , ("negateInt#", Prim Negate tyIntInt) - , ("<=#", Prim Le $ tyIntIntBool b) - , ("<#", Prim Lt $ tyIntIntBool b) - , (">#", Prim Gt $ tyIntIntBool b) - , (">=#", Prim Ge $ tyIntIntBool b) + , ("$<=#", Prim Le $ tyIntIntBool b) + , ("$<#", Prim Lt $ tyIntIntBool b) + , ("$>#", Prim Gt $ tyIntIntBool b) + , ("$>=#", Prim Ge $ tyIntIntBool b) , ("divInt#", Prim Quot tyIntIntInt) , ("modInt#", Prim Mod tyIntIntInt) , ("quotInt#", Prim Quot tyIntIntInt) - , ("remInt#", Prim Mod tyIntIntInt) + , ("remInt#", Prim Rem tyIntIntInt) - , ("==##", Prim Eq $ tyDoubleDoubleBool b) - , ("/=##", Prim Neq $ tyDoubleDoubleBool b) + , ("$==##", Prim Eq $ tyDoubleDoubleBool b) + , ("$/=##", Prim Neq $ tyDoubleDoubleBool b) , ("+##", Prim Plus tyDoubleDoubleDouble) , ("*##", Prim Mult tyDoubleDoubleDouble) , ("-##", Prim Minus tyDoubleDoubleDouble) , ("negateDouble#", Prim Negate tyDoubleDouble) , ("sqrtDouble#", Prim SqRt tyDoubleDoubleDouble) - , ("<=##", Prim Le $ tyDoubleDoubleBool b) - , ("<##", Prim Lt $ tyDoubleDoubleBool b) - , (">##", Prim Gt $ tyDoubleDoubleBool b) - , (">=##", Prim Ge $ tyDoubleDoubleBool b) + , ("/##", Prim Div tyDoubleDoubleDouble) + , ("$<=##", Prim Le $ tyDoubleDoubleBool b) + , ("$<##", Prim Lt $ tyDoubleDoubleBool b) + , ("$>##", Prim Gt $ tyDoubleDoubleBool b) + , ("$>=##", Prim Ge $ tyDoubleDoubleBool b) , ("plusFloat#", Prim Plus tyFloatFloatFloat) , ("timesFloat#", Prim Mult tyFloatFloatFloat) , ("minusFloat#", Prim Minus tyFloatFloatFloat) , ("negateFloat#", Prim Negate tyFloatFloat) , ("sqrtFloat#", Prim SqRt tyFloatFloatFloat) - , ("/##", Prim Div tyFloatFloatFloat) , ("divideFloat#", Prim Div tyFloatFloatFloat) - , ("eqFloat#", Prim Eq $ tyFloatFloatBool b) - , ("neqFloat#", Prim Neq $ tyFloatFloatBool b) - , ("leFloat#", Prim Le $ tyFloatFloatBool b) - , ("ltFloat#", Prim Lt $ tyFloatFloatBool b) - , ("gtFloat#", Prim Gt $ tyFloatFloatBool b) - , ("geFloat#", Prim Ge $ tyFloatFloatBool b) + , ("smtEqFloat#", Prim Eq $ tyFloatFloatBool b) + , ("smtNeFloat#", Prim Neq $ tyFloatFloatBool b) + , ("smtLeFloat#", Prim Le $ tyFloatFloatBool b) + , ("smtLtFloat#", Prim Lt $ tyFloatFloatBool b) + , ("smtGtFloat#", Prim Gt $ tyFloatFloatBool b) + , ("smtGeFloat#", Prim Ge $ tyFloatFloatBool b) , ("quotInteger#", Prim Quot tyIntIntInt) + , ("remInteger#", Prim Rem tyIntIntInt) - , ("eqChar#", Prim Eq $ tyCharCharBool b ) - , ("neChar#", Prim Neq $ tyCharCharBool b ) + , ("chr#", Prim Chr $ tyIntCharBool b ) + , ("ord#", Prim OrdChar $ tyCharIntBool b ) + , ("smtEqChar#", Prim Eq $ tyCharCharBool b ) + , ("smtNeChar#", Prim Neq $ tyCharCharBool b ) + , ("smtEqChar#", Prim Eq $ tyCharCharBool b ) + , ("gtChar#", Prim Gt $ tyCharCharBool b ) + , ("geChar#", Prim Ge $ tyCharCharBool b ) + , ("ltChar#", Prim Lt $ tyCharCharBool b ) + , ("leChar#", Prim Le $ tyCharCharBool b ) + , ("wgencat#", Prim WGenCat $ tyIntInt ) , ("float2Int#", Prim ToInt (TyFun TyLitFloat TyLitInt)) , ("int2Float#", Prim IntToFloat (TyFun TyLitInt TyLitFloat)) , ("fromIntToFloat", Prim IntToFloat (TyFun TyLitInt TyLitFloat)) , ("double2Int#", Prim ToInt (TyFun TyLitDouble TyLitInt)) , ("int2Double#", Prim IntToDouble (TyFun TyLitInt TyLitDouble)) + , ("rationalToDouble#", Prim RationalToDouble (TyFun TyLitInt $ TyFun TyLitInt TyLitDouble)) , ("fromIntToDouble", Prim IntToDouble (TyFun TyLitInt TyLitDouble)) + -- TODO: G2 doesn't currently draw a distinction between Integers and Words + , ("integerToWord#", Lam TermL (x TyLitInt) (Var (x TyLitInt))) + , ("plusWord#", Prim Plus tyIntIntInt) + , ("minusWord#", Prim Minus tyIntIntInt) + , ("timesWord#", Prim Mult tyIntIntInt) + , ("eqWord#", Prim Eq $ tyIntIntBool b) + , ("neWord#", Prim Neq $ tyIntIntBool b) + , ("gtWord#", Prim Gt $ tyIntIntBool b) + , ("geWord#", Prim Ge $ tyIntIntBool b) + , ("ltWord#", Prim Lt $ tyIntIntBool b) + , ("leWord#", Prim Le $ tyIntIntBool b) + + , ("dataToTag##", Prim DataToTag (TyForAll a (TyFun (TyVar a) TyLitInt))) + , ("tagToEnum#", + Lam TypeL a + . Lam TermL (y tyvarA) + $ Case (Var (y tyvarA)) (binder tyvarA) tyvarA + [ Alt Default + $ App + (App + (Prim TagToEnum (TyForAll a (TyFun TyLitInt tyvarA))) + (Var a)) + (Var $ y tyvarA) + + ]) + + , ("intToString#", Prim IntToString (TyFun TyLitInt (TyApp (TyCon l (TyFun TYPE TYPE)) (TyCon c TYPE)))) + , ("absentErr", Prim Error TyBottom) , ("error", Prim Error TyBottom) , ("errorWithoutStackTrace", Prim Error TyBottom) , ("divZeroError", Prim Error TyBottom) + , ("overflowError", Prim Error TyBottom) , ("patError", Prim Error TyBottom) , ("succError", Prim Error TyBottom) , ("toEnumError", Prim Error TyBottom) - , ("undefined", Prim Error TyBottom)] + , ("ratioZeroDenominatorError", Prim Error TyBottom) + , ("undefined", Prim Error TyBottom) ] +a :: Id +a = Id (Name "a" Nothing 0 Nothing) TYPE + +tyvarA :: Type +tyvarA = TyVar a + +x :: Type -> Id +x = Id (Name "x" Nothing 0 Nothing) + +y :: Type -> Id +y = Id (Name "y" Nothing 0 Nothing) + +binder :: Type -> Id +binder = Id (Name "b" Nothing 0 Nothing) + tyIntInt :: Type tyIntInt = TyFun TyLitInt TyLitInt @@ -144,27 +201,42 @@ tyFloatFloatFloat :: Type tyFloatFloatFloat = TyFun TyLitFloat $ TyFun TyLitFloat TyLitFloat +tyIntCharBool :: Name -> Type +tyIntCharBool n = TyFun TyLitInt $ TyFun TyLitChar (TyCon n TYPE) + +tyCharIntBool :: Name -> Type +tyCharIntBool n = TyFun TyLitChar $ TyFun TyLitInt (TyCon n TYPE) + tyCharCharBool :: Name -> Type tyCharCharBool n = TyFun TyLitChar $ TyFun TyLitChar (TyCon n TYPE) -boolName :: [ProgramType] -> Maybe Name -boolName = find ((==) "Bool" . nameOcc) . map fst +boolName :: HM.HashMap Name AlgDataTy -> Maybe Name +boolName = find ((==) "Bool" . nameOcc) . HM.keys -replaceFromPD :: [ProgramType] -> Id -> Expr -> (Id, Expr) -replaceFromPD pt i@(Id n _) e = +charName :: HM.HashMap Name AlgDataTy -> Maybe Name +charName = find ((==) "Char" . nameOcc) . HM.keys + +listName :: HM.HashMap Name AlgDataTy -> Maybe Name +#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0) +listName = find ((==) "List" . nameOcc) . HM.keys +#else +listName = find ((==) "[]" . nameOcc) . HM.keys +#endif + +replaceFromPD :: HM.HashMap Name AlgDataTy -> Name -> Expr -> Expr +replaceFromPD pt n e = let e' = fmap snd $ find ((==) (nameOcc n) . fst) (primDefs pt) in - (i, maybe e id e') - + maybe e id e' -addPrimsToBase :: [ProgramType] -> Program -> Program -addPrimsToBase pt prims = map (map (uncurry (replaceFromPD pt))) prims +addPrimsToBase :: HM.HashMap Name AlgDataTy -> HM.HashMap Name Expr -> HM.HashMap Name Expr +addPrimsToBase pt prims = HM.mapWithKey (replaceFromPD pt) prims -mergeProgs :: Program -> Program -> Program -mergeProgs prog prims = prog ++ prims +mergeProgs :: HM.HashMap Name Expr -> HM.HashMap Name Expr -> HM.HashMap Name Expr +mergeProgs prog prims = prog `HM.union` prims -- The prog is used to change the names of types in the prog' and primTys -mergeProgTys :: [ProgramType] -> [ProgramType] -> [ProgramType] +mergeProgTys :: [(Name, AlgDataTy)] -> [(Name, AlgDataTy)] -> [(Name, AlgDataTy)] mergeProgTys progTys primTys = progTys ++ primTys diff --git a/src/G2/Translation/TransTypes.hs b/src/G2/Translation/TransTypes.hs --- a/src/G2/Translation/TransTypes.hs +++ b/src/G2/Translation/TransTypes.hs @@ -1,11 +1,10 @@ module G2.Translation.TransTypes where -import CoreSyn --- import GHC -import HscTypes -import InstEnv -import TyCon +import Control.Monad.Identity +import qualified Control.Monad.State.Lazy as SM +import G2.Translation.GHC + import qualified Data.HashMap.Lazy as HM import qualified Data.Text as T @@ -16,16 +15,22 @@ type TypeNameMap = HM.HashMap (T.Text, Maybe T.Text) G2.Name +type Names = (NameMap, TypeNameMap) +type NamesT m a = SM.StateT Names m a +type NamesM a = NamesT Identity a + type ExportedName = G2.Name data TranslationConfig = TranslationConfig { simpl :: Bool + , interpreter :: Bool , load_rewrite_rules :: Bool + , hpc_ticks :: Bool } simplTranslationConfig :: TranslationConfig -simplTranslationConfig = TranslationConfig { simpl = True, load_rewrite_rules = False } +simplTranslationConfig = TranslationConfig { simpl = True, interpreter = False, load_rewrite_rules = False, hpc_ticks = False } data ModGutsClosure = ModGutsClosure { mgcc_mod_name :: Maybe String @@ -91,10 +96,10 @@ data ExtractedG2 = ExtractedG2 - { exg2_mod_names :: [T.Text] - , exg2_binds :: [(G2.Id, G2.Expr)] - , exg2_tycons :: [G2.ProgramType] - , exg2_classes :: [(G2.Name, G2.Id, [G2.Id])] + { exg2_mod_names :: [Maybe T.Text] + , exg2_binds :: HM.HashMap G2.Name G2.Expr + , exg2_tycons :: HM.HashMap G2.Name G2.AlgDataTy + , exg2_classes :: [(G2.Name, G2.Id, [G2.Id], [(G2.Type, G2.Id)])] , exg2_exports :: [ExportedName] , exg2_deps :: [T.Text] , exg2_rules :: ![G2.RewriteRule] @@ -104,8 +109,8 @@ emptyExtractedG2 = ExtractedG2 { exg2_mod_names = [] - , exg2_binds = [] - , exg2_tycons = [] + , exg2_binds = HM.empty + , exg2_tycons = HM.empty , exg2_classes = [] , exg2_exports = [] , exg2_deps = [] diff --git a/tests/DefuncTest.hs b/tests/DefuncTest.hs --- a/tests/DefuncTest.hs +++ b/tests/DefuncTest.hs @@ -33,51 +33,5 @@ -- Defunc2 -add1D2 :: Expr -add1D2 = Var (Id (Name "add1" (Just "Defunc2") 0 Nothing) tyIntS) - -sub1D2 :: Expr -sub1D2 = Var (Id (Name "sub1" (Just "Defunc2") 0 Nothing) tyIntS) - -squareD2 :: Expr -squareD2 = Var (Id (Name "square" (Just "Defunc2") 0 Nothing) tyIntS) - -iListI :: Expr -iListI = Data $ DataCon (Name "I" (Just "Defunc2") 0 Nothing) (TyCon (Name "IList" (Just "Defunc2") 0 Nothing) TYPE) - -iListNil :: Expr -iListNil = Data $ DataCon (Name "INil" (Just "Defunc2") 0 Nothing) (TyCon (Name "IList" (Just "Defunc2") 0 Nothing) TYPE) - -fListF :: Expr -fListF = Data $ DataCon (Name "F" (Just "Defunc2") 0 Nothing) (TyCon (Name "FList" (Just "Defunc2") 0 Nothing) TYPE) - -fListNil :: Expr -fListNil = Data $ DataCon (Name "FNil" (Just "Defunc2") 0 Nothing) (TyCon (Name "FList" (Just "Defunc2") 0 Nothing) TYPE) - -add1Def :: Integer -> Integer -add1Def x = x + 1 - -sub1Def :: Integer -> Integer -sub1Def x = x - 1 - -squareDef :: Integer -> Integer -squareDef x = x * x - -defunc2Check :: [Expr] -> Bool -defunc2Check [flist, llist, llist'] = defunc2Check' flist llist llist' -defunc2Check _ = False - -defunc2Check' :: Expr -> Expr -> Expr -> Bool -defunc2Check' (App (App _ f) fs) - (App (App _ (Lit (LitInt i))) is) - (App (App _ (Lit (LitInt i'))) is') = defunc2Check'' f i i' && defunc2Check' fs is is' -defunc2Check' _ _ _ = True - -defunc2Check'' :: Expr -> Integer -> Integer -> Bool -defunc2Check'' (Var (Id (Name "add1" _ _ _) _)) i i' = add1Def i == i' -defunc2Check'' (Var (Id (Name "sub1" _ _ _) _)) i i' = sub1Def i == i' -defunc2Check'' (Var (Id (Name "square" _ _ _) _)) i i' = squareDef i == i' -defunc2Check'' _ _ _ = False - tyIntS :: Type tyIntS = TyCon (Name "Int" Nothing 0 Nothing) TYPE diff --git a/tests/Expr.hs b/tests/Expr.hs --- a/tests/Expr.hs +++ b/tests/Expr.hs @@ -8,11 +8,8 @@ import Test.Tasty import Test.Tasty.HUnit -exprTests :: IO TestTree -exprTests = return exprTests' - -exprTests' :: TestTree -exprTests' = +exprTests :: TestTree +exprTests = testGroup "Expr" [ testCase "Eta Expand To" $ assertBool "Eta Expand To failed" etaExpandTo1 , testCase "Eta Expand To" $ assertBool "Eta Expand To failed" etaExpandTo2 diff --git a/tests/GetNthTest.hs b/tests/GetNthTest.hs --- a/tests/GetNthTest.hs +++ b/tests/GetNthTest.hs @@ -8,13 +8,6 @@ data CList a = Cons a (CList a) | Nil -data Peano = Succ Peano | Zero - -getNth :: CList Integer -> Integer -> Integer -getNth (Cons x _) 0 = x -getNth (Cons _ xs) n = getNth xs (n - 1) -getNth _ _ = -1 - getNthErr :: CList a -> Integer -> Maybe a getNthErr (Cons x _) 0 = Just x getNthErr (Cons _ xs) n = getNthErr xs (n - 1) @@ -40,62 +33,6 @@ Cons e (toCListGenType y) toCListGenType _ = Nil -cListLength :: CList a -> Integer -cListLength (Cons _ xs) = 1 + cListLength xs -cListLength Nil = 0 - -getNthTest :: [Expr] -> Bool -getNthTest [cl, i, a] = getIntB i $ \i' -> getIntB a $ \a' -> getNth (toCList cl) i' == a' -getNthTest _ = False - -getNthErrTest :: [Expr] -> Bool -getNthErrTest [cl, i, Prim Error _] = getIntB i $ \i' -> getNthErr (toCListType cl) i' == Nothing -getNthErrTest [cl, i, a] = getIntB i $ \i' -> getIntB a $ \a' -> getNthErr (toCListType cl) i' == Just a' -getNthErrTest _ = False - -getNthErrGenTest :: [Expr] -> Bool -getNthErrGenTest [cl, i, Prim Error _] = getIntB i $ \i' -> getNthErr (toCListGenType cl) i' == Nothing -getNthErrGenTest [cl, i, e] = - case getInt i Nothing $ \i' -> getNthErr (toCListGenType cl) i' of - Just e' -> e' `eqIgT` e - Nothing -> False -getNthErrGenTest _ = False - -getNthErrGenTest' :: [Expr] -> Bool -getNthErrGenTest' [cl, i, Prim Error _] = getIntB i $ \i' -> getNthErr (toCListGenType cl) i' == Nothing -getNthErrGenTest' [cl, i, e] = - case getInt i Nothing $ \i' -> getNthErr (toCListGenType cl) i' of - Just e' -> e' `eqIgT` e - Nothing -> False -getNthErrGenTest' _ = False - -getNthErrGenTest2 :: [Expr] -> Bool -getNthErrGenTest2 [cl, i, Prim Error _] = getIntB i $ \i' -> getNthErr (toCListGenType cl) i' == Nothing -getNthErrGenTest2 [cl, i, e] = - case getInt i Nothing $ \i' -> getNthErr (toCListGenType cl) i' of - Just e' -> e' `eqIgT` e - Nothing -> False -getNthErrGenTest2 _ = False - -getNthErrGenTest2' :: [Expr] -> Bool -getNthErrGenTest2' [cl, i, Prim Error _] = getIntB i $ \i' -> getNthErr (toCListGenType cl) i' == Nothing -getNthErrGenTest2' [cl, i, e] = - case getInt i Nothing $ \i' -> getNthErr (toCListGenType cl) i' of - Just e' -> e' `eqIgT` e - Nothing -> False -getNthErrGenTest2' _ = False - -elimType :: (ASTContainer m Expr) => m -> m -elimType = modifyASTs elimType' - -elimType' :: Expr -> Expr -elimType' (App e (Type _)) = e -elimType' e = e - getNthErrors :: [Expr] -> Bool getNthErrors [cl, App _ (Lit (LitInt i)), Prim Error _] = getNthErr (toCListGen cl) i == Nothing getNthErrors _ = False - -cfmapTest :: [Expr] -> Bool -cfmapTest [_, e, e'] = cListLength (toCListGenType e) == cListLength (toCListGenType e') || isError e' -cfmapTest _ = False diff --git a/tests/InputOutputTest.hs b/tests/InputOutputTest.hs --- a/tests/InputOutputTest.hs +++ b/tests/InputOutputTest.hs @@ -1,103 +1,106 @@ {-# LANGUAGE OverloadedStrings #-} module InputOutputTest ( checkInputOutput - , checkInputOutputLH ) where + , checkInputOutputs + , checkInputOutputsTemplate + , checkInputOutputsNonRedTemp ) where import Test.Tasty import Test.Tasty.HUnit import Control.Exception +import Data.IORef +import qualified Data.Map.Lazy as M +import Data.Maybe import qualified Data.Text as T import System.FilePath +import System.IO.Unsafe import G2.Config import G2.Initialization.MkCurrExpr import G2.Interface import G2.Language -import G2.Liquid.Interface import G2.Translation import Reqs import TestUtils -checkInputOutput :: FilePath -> String -> String -> Int -> Int -> [Reqs String] -> IO TestTree -checkInputOutput src md entry stps i req = checkInputOutputWithConfig [src] md entry i req (mkConfigTest {steps = stps}) +checkInputOutput :: FilePath -> String -> Int -> [Reqs String] -> TestTree +checkInputOutput src entry stps req = do + checkInputOutput' mkConfigTestIO src [(entry, stps, req)] -checkInputOutputWithConfig :: [FilePath] -> String -> String -> Int -> [Reqs String] -> Config -> IO TestTree -checkInputOutputWithConfig src md entry i req config = do - r <- doTimeout (timeLimit config) $ checkInputOutput' src md entry i req config +checkInputOutputs :: FilePath -> [(String, Int, [Reqs String])] -> TestTree +checkInputOutputs src tests = do + checkInputOutput' mkConfigTestIO src tests - let (b, e) = case r of - Nothing -> (False, "\nTimeout") - Just (Left e') -> (False, "\n" ++ show e') - Just (Right (b', _)) -> (b', "") +checkInputOutputsTemplate :: FilePath -> [(String, Int, [Reqs String])] -> TestTree +checkInputOutputsTemplate src tests = do + checkInputOutput' + (do config <- mkConfigTestIO; return (config { higherOrderSolver = SymbolicFunc })) + src + tests - return . testCase (show src) $ assertBool ("Input/Output for file " ++ show src ++ " failed on function " ++ entry ++ "." ++ e) b +checkInputOutputsNonRedTemp :: FilePath -> [(String, Int, [Reqs String])] -> TestTree +checkInputOutputsNonRedTemp src tests = do + checkInputOutput' + (do config <- mkConfigTestIO; return (config { higherOrderSolver = SymbolicFuncTemplate })) + src + tests -checkInputOutput' :: [FilePath] - -> String - -> String - -> Int - -> [Reqs String] - -> Config - -> IO (Either SomeException (Bool, [ExecRes ()])) -checkInputOutput' src md entry i req config = try (checkInputOutput'' src md entry i req config) +checkInputOutput' :: IO Config + -> FilePath + -> [(String, Int, [Reqs String])] + -> TestTree +checkInputOutput' io_config src tests = do + let proj = takeDirectory src + + withResource + (do + config <- io_config + translateLoaded [proj] [src] simplTranslationConfig config + ) + (\_ -> return ()) + $ \loadedExG2 -> + testGroup + src + $ map (\test@(entry, _, _) -> do + testCase (src ++ " " ++ entry) ( do + (mb_modname, exg2) <- loadedExG2 + config <- io_config + r <- doTimeout (timeLimit config) + (try (checkInputOutput'' [src] exg2 mb_modname config test) + :: IO (Either SomeException (Bool, [ExecRes ()]))) + let (b, e) = case r of + Nothing -> (False, "\nTimeout") + Just (Left e') -> (False, "\n" ++ show e') + Just (Right (b', _)) -> (b', "") -checkInputOutput'' :: [FilePath] - -> String - -> String - -> Int - -> [Reqs String] + assertBool ("Input/Output for file " ++ show src ++ " failed on function " ++ entry ++ "." ++ e) b + ) + ) tests + +checkInputOutput'' :: [FilePath] + -> ExtractedG2 + -> Maybe T.Text -> Config + -> (String, Int, [Reqs String]) -> IO (Bool, [ExecRes ()]) -checkInputOutput'' src md entry i req config = do - let proj = map takeDirectory src - (mb_modname, exg2) <- translateLoaded proj src [] simplTranslationConfig config - - let (init_state, _, bindings) = initState exg2 False (T.pack entry) mb_modname (mkCurrExpr Nothing Nothing) config - putStrLn "test" +checkInputOutput'' src exg2 mb_modname config (entry, stps, req) = do + let config' = config { steps = stps } + (init_state, bindings) = initStateWithCall exg2 False (T.pack entry) mb_modname (mkCurrExpr Nothing Nothing) mkArgTys config' - (r, _) <- runG2WithConfig init_state config bindings + (r, _) <- runG2WithConfig mb_modname init_state config' bindings let chAll = checkExprAll req - mr <- validateStates proj src md entry chAll [] r - let io = map (\(ExecRes { conc_args = i', conc_out = o}) -> i' ++ [o]) r + let proj = map takeDirectory src + mr <- validateStates proj src (T.unpack $ fromJust mb_modname) entry chAll [] r + let io = map (\(ExecRes { conc_args = i, conc_out = o}) -> i ++ [o]) r - let chEx = checkExprInOutCount io i req + let chEx = checkExprInOutCount io req return $ (mr && chEx, r) ------------ -checkInputOutputLH :: [FilePath] -> [FilePath] -> String -> String -> Int -> Int -> [Reqs String] -> IO TestTree -checkInputOutputLH proj src md entry stps i req = checkInputOutputLHWithConfig proj src md entry i req (mkConfigTest {steps = stps}) - -checkInputOutputLHWithConfig :: [FilePath] -> [FilePath] -> String -> String -> Int -> [Reqs String] -> Config -> IO TestTree -checkInputOutputLHWithConfig proj src md entry i req config = do - r <- doTimeout (timeLimit config) $ checkInputOutputLH' proj src md entry i req config - - let b = case r of - Just (Right b') -> b' - _ -> False - - return . testCase (show src) $ assertBool ("Input/Output for file " ++ show src ++ " failed on function " ++ entry ++ ".") b - -checkInputOutputLH' :: [FilePath] -> [FilePath] -> String -> String -> Int -> [Reqs String] -> Config -> IO (Either SomeException Bool) -checkInputOutputLH' proj src md entry i req config = try (checkInputOutputLH'' proj src md entry i req config) - -checkInputOutputLH'' :: [FilePath] -> [FilePath] -> String -> String -> Int -> [Reqs String] -> Config -> IO Bool -checkInputOutputLH'' proj src md entry i req config = do - ((r, _), _) <- findCounterExamples proj src (T.pack entry) [] [] config - - let chAll = checkExprAll req - - mr <- validateStates proj src md entry chAll [] r - let io = map (\(ExecRes { conc_args = i', conc_out = o}) -> i' ++ [o]) r - - let chEx = checkExprInOutCount io i req - return $ mr && chEx - ------------- - -- | Checks conditions on given expressions checkExprAll :: [Reqs String] -> [String] checkExprAll reqList = [f | RForAll f <- reqList] @@ -105,13 +108,11 @@ checkExprExists :: [Reqs String] -> [String] checkExprExists reqList = [f | RExists f <- reqList] -checkExprInOutCount :: [[Expr]] -> Int -> [Reqs c] -> Bool -checkExprInOutCount exprs i reqList = +checkExprInOutCount :: [[Expr]] -> [Reqs c] -> Bool +checkExprInOutCount exprs reqList = let checkAtLeast = and . map ((>=) (length exprs)) $ [x | AtLeast x <- reqList] checkAtMost = and . map ((<=) (length exprs)) $ [x | AtMost x <- reqList] checkExactly = and . map ((==) (length exprs)) $ [x | Exactly x <- reqList] - - checkArgCount = and . map ((==) i . length) $ exprs in - checkAtLeast && checkAtMost && checkExactly && checkArgCount + checkAtLeast && checkAtMost && checkExactly diff --git a/tests/Reqs.hs b/tests/Reqs.hs --- a/tests/Reqs.hs +++ b/tests/Reqs.hs @@ -1,6 +1,6 @@ module Reqs ( Reqs (..) - , checkExprGen - , checkAbsLHExprGen ) where + , TestErrors (..) + , checkExprGen ) where import G2.Language @@ -17,52 +17,34 @@ | AtMost Int | Exactly Int -data TestErrors = BadArgCount +data TestErrors = BadArgCount [Int] | TooMany | TooFew | NotExactly | ArgsForAllFailed - | ArgsExistFailed deriving (Show) + | ArgsExistFailed + | Time deriving (Show) -- | Checks conditions on given expressions -checkExprGen :: [[Expr]] -> Int -> [Reqs ([Expr] -> Bool)] -> Bool -checkExprGen exprs i reqList = - let - argChecksAll = and . map (\f -> all (givenLengthCheck i f) exprs) $ [f | RForAll f <- reqList] - argChecksEx = and . map (\f -> any (givenLengthCheck i f) exprs) $ [f | RExists f <- reqList] - checkL = null $ checkLengths exprs i reqList - in - argChecksAll && argChecksEx && checkL - -givenLengthCheck :: Int -> ([Expr] -> Bool) -> [Expr] -> Bool -givenLengthCheck i f e = if length e == i then f e else False - -checkAbsLHExprGen :: [(State [FuncCall], [Expr], Expr)] -> Int -> [Reqs ([Expr] -> Expr -> [FuncCall] -> Bool)] -> [TestErrors] -checkAbsLHExprGen exprs i reqList = +checkExprGen :: [[Expr]] -> [Reqs ([Expr] -> Bool)] -> [TestErrors] +checkExprGen exprs reqList = let - argChecksAll = - if and . map (\f -> all (\(s, es, e) -> lhGivenLengthCheck i f es e (track s)) exprs) $ [f | RForAll f <- reqList] - then [] - else [ArgsForAllFailed] - argChecksEx = - if and . map (\f -> any (\(s, es, e) -> lhGivenLengthCheck i f es e (track s)) exprs) $ [f | RExists f <- reqList] - then [] - else [ArgsExistFailed] - checkL = checkLengths (map (\(_, e, _) -> e) exprs) i reqList + argChecksAll = if and . map (\f -> all f exprs) $ [f | RForAll f <- reqList] + then [] + else [ArgsForAllFailed] + argChecksEx = if and . map (\f -> any f exprs) $ [f | RExists f <- reqList] + then [] + else [ArgsExistFailed] + checkL = checkLengths exprs reqList in argChecksAll ++ argChecksEx ++ checkL -lhGivenLengthCheck :: Int -> ([Expr] -> Expr -> [FuncCall] -> Bool) -> [Expr] -> Expr -> [FuncCall] -> Bool -lhGivenLengthCheck i f es e fc = if length es == i then f es e fc else False - -checkLengths :: [[Expr]] -> Int -> [Reqs c] -> [TestErrors] -checkLengths exprs i reqList = +checkLengths :: [[Expr]] -> [Reqs c] -> [TestErrors] +checkLengths exprs reqList = let checkAtLeast = if and . map ((>=) (length exprs)) $ [x | AtLeast x <- reqList] then [] else [TooFew] checkAtMost = if and . map ((<=) (length exprs)) $ [x | AtMost x <- reqList] then [] else [TooMany] checkExactly = if and . map ((==) (length exprs)) $ [x | Exactly x <- reqList] then [] else [NotExactly] - - checkArgCount = if and . map ((==) i . length) $ exprs then [] else [BadArgCount] in - checkAtLeast ++ checkAtMost ++ checkExactly ++ checkArgCount + checkAtLeast ++ checkAtMost ++ checkExactly diff --git a/tests/RewriteVerify/RewriteVerifyTest.hs b/tests/RewriteVerify/RewriteVerifyTest.hs new file mode 100644 --- /dev/null +++ b/tests/RewriteVerify/RewriteVerifyTest.hs @@ -0,0 +1,227 @@ +{-# LANGUAGE FlexibleContexts #-} + +module RewriteVerify.RewriteVerifyTest ( rewriteTests ) where + +import qualified Data.Map as M +import Data.Maybe +import qualified Data.Text as T + +import G2.Config +import G2.Interface +import G2.Language +import G2.Translation + +import G2.Equiv.Config +import G2.Equiv.Verifier +import G2.Equiv.Summary + +import Data.List + +import qualified G2.Solver as S + +import Test.Tasty +import Test.Tasty.HUnit + +findRule :: [RewriteRule] -> String -> RewriteRule +findRule rule_list rule_name = + let tentry = T.pack rule_name + rule = find (\r -> tentry == ru_name r) rule_list + in case rule of + Just r -> r + Nothing -> error $ "not found " ++ show rule_name + +acceptRule :: (ASTContainer t Type, ASTContainer t Expr) => Config -> State t -> Bindings -> RewriteRule -> IO Bool +acceptRule config init_state bindings rule = do + res <- checkRule config nebulaConfig init_state bindings [] rule + return (case res of + S.SAT _ -> error "Satisfiable" + S.UNSAT _ -> True + _ -> error "Failed to Produce a Result") + +rejectRule :: (ASTContainer t Type, ASTContainer t Expr) => Config -> State t -> Bindings -> RewriteRule -> IO Bool +rejectRule config init_state bindings rule = do + res <- checkRule config nebulaConfig init_state bindings [] rule + return (case res of + S.SAT _ -> True + S.UNSAT _ -> error "Unsatisfiable" + _ -> error "Failed to Produce a Result") + +nebulaConfig :: NebulaConfig +nebulaConfig = NC { limit = 20 + , num_lemmas = 2 + , print_summary = SM False False False + , use_labeled_errors = UseLabeledErrors + , log_states = NoLog + , log_rule = Nothing + , symbolic_unmapped = False + , sync = False} + +good_names :: [String] +good_names = [ "addOneCommutative" + , "doubleNegative" + , "maybeForceZero" + , "maxWithSelf" + , "addOneJust" + , "justJust" ] + +good_src :: String +good_src = "tests/RewriteVerify/Correct/SimpleCorrect.hs" + +bad_names :: [String] +bad_names = [ "badMaybeForce" + , "badNegation" + , "badMax" + , "badMaxLeft" + , "badJust" + , "badTuple" + , "badFF" ] + +bad_src :: String +bad_src = "tests/RewriteVerify/Incorrect/SimpleIncorrect.hs" + +coinduction_good_names :: [String] +coinduction_good_names = [ --"forceIdempotent" + "dropNoRecursion" + , "mapTake" + , "takeIdempotent" + --, "doubleReverse" + , "doubleMap" + , "mapIterate" ] + +coinduction_good_src :: String +coinduction_good_src = "tests/RewriteVerify/Correct/CoinductionCorrect.hs" + +coinduction_bad_names :: [String] +coinduction_bad_names = [ "forceDoesNothing" + , "badDropSum" + , "doubleTake" + , "badDoubleReverse" ] + +coinduction_bad_src :: String +coinduction_bad_src = "tests/RewriteVerify/Incorrect/CoinductionIncorrect.hs" + +higher_good_names :: [String] +higher_good_names = [ "doubleMap" + , "mapIterate" + , "mapTake" + , "mapFilter" ] + +higher_good_src :: String +higher_good_src = "tests/RewriteVerify/Correct/HigherOrderCorrect.hs" + +higher_bad_names :: [String] +higher_bad_names = [ "direct" + , "symFuncInfExpr" + , "symFuncPoly" + , "symFuncNat" ] + +higher_bad_src :: String +higher_bad_src = "tests/RewriteVerify/Incorrect/HigherOrderIncorrect.hs" + +tree_good_names :: [String] +tree_good_names = [ -- "doubleTree" + -- "doubleTreeOriginal" + "doubleMapTree" ] + +tree_good_src :: String +tree_good_src = "tests/RewriteVerify/Correct/TreeCorrect.hs" + +tree_bad_names :: [String] +tree_bad_names = [ "badSize" + , "treeMapBackward" ] + +tree_bad_src :: String +tree_bad_src = "tests/RewriteVerify/Incorrect/TreeIncorrect.hs" + +multi_lemma_good_names :: [String] +multi_lemma_good_names = [ "p55Z" + , "p55nil" + , "p55Znil" + , "p80Z" + , "p80nil" + , "p80Znil" ] + +multi_lemma_good_src :: String +multi_lemma_good_src = "tests/RewriteVerify/Correct/Zeno.hs" + +empty_config :: IO Config +empty_config = getConfigDirect + +rvTest :: (Config -> State () -> Bindings -> RewriteRule -> IO Bool) -> + String -> [String] -> TestTree +rvTest check src rule_names = + withResource + (do + proj <- guessProj src + config <- empty_config + initialStateNoStartFunc [proj] [src] + (simplTranslationConfig {simpl = True, load_rewrite_rules = True}) + config + ) + (\_ -> return ()) + (\isb -> testGroup ("Rules " ++ src) + $ map (\rule_name -> testCase ("Rule " ++ rule_name) $ do + (init_state, bindings) <- isb + config <- empty_config + let rule = findRule (rewrite_rules bindings) rule_name + r <- doTimeout 180 $ check config init_state bindings rule + case r of + Nothing -> error "TIMEOUT" + Just r' | r' -> return () + | otherwise -> error "test failed") rule_names) + +rewriteVerifyTestsGood :: TestTree +rewriteVerifyTestsGood = + rvTest acceptRule good_src good_names + +rewriteVerifyTestsBad :: TestTree +rewriteVerifyTestsBad = + rvTest rejectRule bad_src bad_names + +coinductionTestsGood :: TestTree +coinductionTestsGood = + rvTest acceptRule coinduction_good_src coinduction_good_names + +coinductionTestsBad :: TestTree +coinductionTestsBad = + rvTest rejectRule coinduction_bad_src coinduction_bad_names + +higherOrderTestsGood :: TestTree +higherOrderTestsGood = + rvTest acceptRule higher_good_src higher_good_names + +higherOrderTestsBad :: TestTree +higherOrderTestsBad = + rvTest rejectRule higher_bad_src higher_bad_names + +treeTestsGood :: TestTree +treeTestsGood = + rvTest acceptRule tree_good_src tree_good_names + +treeTestsBad :: TestTree +treeTestsBad = + rvTest rejectRule tree_bad_src tree_bad_names + +typeSymsTestsGood :: TestTree +typeSymsTestsGood = + rvTest acceptRule "tests/RewriteVerify/Correct/TypeSyms.hs" ["parBuffer"] + +multiLemmaTestsGood :: TestTree +multiLemmaTestsGood = + rvTest acceptRule multi_lemma_good_src multi_lemma_good_names + +rewriteTests :: TestTree +rewriteTests = testGroup "Rewrite Tests" + [ rewriteVerifyTestsGood + , rewriteVerifyTestsBad + , coinductionTestsGood + , coinductionTestsBad + , higherOrderTestsGood + , higherOrderTestsBad + , treeTestsGood + , treeTestsBad + , typeSymsTestsGood + , multiLemmaTestsGood + ] + + diff --git a/tests/Simplifications.hs b/tests/Simplifications.hs new file mode 100644 --- /dev/null +++ b/tests/Simplifications.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Simplifications (simplificationTests) where + +import G2.Language.Simplification +import G2.Language.Syntax + +import Test.Tasty +import Test.Tasty.HUnit + +simplificationTests :: TestTree +simplificationTests = + testGroup "Simplifications" [ + testCase "AppLamSimplification" (assertBool "Substituting two variables" simplifyAppLambdasTest1) + , testCase "AppLamSimplification" (assertBool "Substituting two variables" simplifyAppLambdasTest2) + , testCase "AppLamSimplification" (assertBool "Substituting a tyvar" simplifyTyVar1) + ] + + +simplifyAppLambdasTest1 :: Bool +simplifyAppLambdasTest1 = + let + le = Lam TermL id1 + . Lam TermL id2 + $ App (Var id1) (Var id2) + e = App (App le (Var id3)) (Var id4) + in + simplifyAppLambdas e == App (Var id3) (Var id4) + + +simplifyAppLambdasTest2 :: Bool +simplifyAppLambdasTest2 = + let + le = Lam TermL id1 + $ (App (Lam TermL id2 (Var id2)) (Var id1)) + e = App le (Var id3) + in + simplifyAppLambdas e == Var id3 + +simplifyTyVar1 :: Bool +simplifyTyVar1 = + let + tyvar_id1 = Id (Name "tv_1" Nothing 0 Nothing) TYPE + tyvar_id2 = Id (Name "tv_2" Nothing 0 Nothing) TYPE + + v_n = Name "v" Nothing 0 Nothing + v_id1 = Id v_n (TyVar tyvar_id1) + v_id2 = Id v_n (TyVar tyvar_id2) + + le = Lam TypeL tyvar_id1 (Var v_id1) + e = App le (Var tyvar_id2) + in + simplifyAppLambdas e == Var v_id2 + + +id1 :: Id +id1 = Id (Name "a" Nothing 0 Nothing) TyUnknown + +id2 :: Id +id2 = Id (Name "b" Nothing 0 Nothing) TyUnknown + +id3 :: Id +id3 = Id (Name "c" Nothing 0 Nothing) TyUnknown + +id4 :: Id +id4 = Id (Name "d" Nothing 0 Nothing) TyUnknown diff --git a/tests/Test.hs b/tests/Test.hs --- a/tests/Test.hs +++ b/tests/Test.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} @@ -5,7 +6,7 @@ module Main where import Test.Tasty -import Test.Tasty.HUnit +import Test.Tasty.HUnit ( testCase, assertBool, assertFailure ) import Test.Tasty.Options import Test.Tasty.Runners @@ -13,7 +14,6 @@ import G2.Interface import G2.Language as G2 -import G2.Liquid.Interface import Control.Exception import Data.Maybe @@ -30,12 +30,20 @@ import DefuncTest import CaseTest import Expr +import Simplifications import Typing +import UnionFindTests +import UFMapTests +import RewriteVerify.RewriteVerifyTest +import G2.Translation + import InputOutputTest import Reqs import TestUtils +import qualified Data.Map.Lazy as M + -- Run with no arguments for default test cases. -- All default test cases should pass. -- Run with flag '--test-options="todo yes"' to run test cases corresponding to to-be-fixed bugs. @@ -49,432 +57,417 @@ [ Option (Proxy :: Proxy ToDo) ] (\_ _ -> Just (\_ -> return (\_ -> return False))) ]) - =<< if todo then todoTests else tests + (if todo then todoTests else tests) -tests :: IO TestTree -tests = return . testGroup "Tests" - =<< sequence [ - sampleTests - , liquidTests +tests :: TestTree +tests = testGroup "Tests" + [ sampleTests , testFileTests + , extensionTests , baseTests , primTests + , ioTests , exprTests , typingTests + , simplificationTests + , ufMapQuickcheck + , unionFindQuickcheck + , rewriteTests ] timeout :: Timeout timeout = mkTimeout 1 -- Test based on examples that are also good for demos -sampleTests :: IO TestTree -sampleTests = - return . testGroup "Samples" - =<< sequence [ - checkExpr "tests/Samples/Peano.hs" 900 Nothing (Just "equalsFour") "add" 3 [RForAll $ not . peano_4_out, AtLeast 10] - , checkExpr "tests/Samples/Peano.hs" 900 (Just "fstIsEvenAddToFour") (Just "fstIsTwo") "add" 3 [RExists peano_0_4, RExists peano_4_0, Exactly 2] - , checkExpr "tests/Samples/Peano.hs" 1200 (Just "multiplyToFour") (Just "equalsFour") "add" 3 [RExists peano_1_4_5, RExists peano_4_1_5, Exactly 2] - , checkExpr "tests/Samples/Peano.hs" 750 (Just "eqEachOtherAndAddTo4") Nothing "add" 3 [RForAll peano_2_2, Exactly 1] - , checkExpr "tests/Samples/Peano.hs" 600 (Just "equalsFour") Nothing "add" 3 [RExists peano_0_4, RExists peano_1_3, RExists peano_2_2, RExists peano_3_1, RExists peano_4_0, Exactly 5] - , checkExpr "tests/Samples/Peano.hs" 750 (Just "equalsFour") Nothing "multiply" 3 [RExists peano_1_4, RExists peano_2_2, RExists peano_4_1, Exactly 3] - - , checkExpr "tests/Samples/HigherOrderMath.hs" 800 (Just "isTrue0") Nothing "notNegativeAt0NegativeAt1" 2 [RExists negativeSquareRes, AtLeast 1] - , checkExpr "tests/Samples/HigherOrderMath.hs" 600 (Just "isTrue1") Nothing "fixed" 3 [RExists abs2NonNeg, RExists squareRes, RExists fourthPowerRes, RForAll allabs2NonNeg, AtLeast 4] - , checkExpr "tests/Samples/HigherOrderMath.hs" 600 Nothing Nothing "fixed" 3 [RExists abs2NonNeg, RExists squareRes, RExists fourthPowerRes, AtLeast 4] - , checkExpr "tests/Samples/HigherOrderMath.hs" 600 (Just "isTrue2") Nothing "sameFloatArgLarger" 3 [RExists addRes, RExists subRes, AtLeast 2] - , checkExpr "tests/Samples/HigherOrderMath.hs" 600 Nothing Nothing "functionSatisfies" 4 [RExists functionSatisfiesRes, AtLeast 1] - , checkExpr "tests/Samples/HigherOrderMath.hs" 1000 Nothing Nothing "approxSqrt" 3 [AtLeast 2] - -- The below test fails because Z3 returns unknown. - -- , checkExpr "tests/Samples/HigherOrderMath.hs" 1200 (Just "isTrue2") Nothing "sameFloatArgLarger" 2 [RExists approxSqrtRes, RExists pythagoreanRes, AtLeast 2] - - , checkExpr "tests/Samples/McCarthy91.hs" 1000 (Just "lessThan91") Nothing "mccarthy" 2 [RForAll (\[App _ (Lit (LitInt x)), _] -> x <= 100), AtLeast 1] - , checkExpr "tests/Samples/McCarthy91.hs" 400 (Just "greaterThan10Less") Nothing "mccarthy" 2 [RForAll (\[App _ (Lit (LitInt x)), _] -> x > 100), AtLeast 1] - , checkExpr "tests/Samples/McCarthy91.hs" 1000 (Just "lessThanNot91") Nothing "mccarthy" 2 [Exactly 0] - , checkExpr "tests/Samples/McCarthy91.hs" 1000 (Just "greaterThanNot10Less") Nothing "mccarthy" 2 [Exactly 0] - - , checkExpr "tests/Samples/GetNth.hs" 600 Nothing Nothing "getNth" 3 [AtLeast 10, RForAll getNthTest] - , checkExpr "tests/Samples/GetNthPoly.hs" 600 Nothing Nothing "getNthInt" 3 [AtLeast 10, RForAll getNthErrTest] - , checkExpr "tests/Samples/GetNthPoly.hs" 600 Nothing Nothing "getNthX" 3 [AtLeast 10, RForAll getNthErrGenTest] - , checkExpr "tests/Samples/GetNthPoly.hs" 600 Nothing Nothing "getNthPeano" 3 [AtLeast 10, RForAll getNthErrGenTest] -- 533 - , checkExpr "tests/Samples/GetNthPoly.hs" 600 Nothing Nothing "getNthCListInt" 3 [AtLeast 10, RForAll getNthErrGenTest2'] - , checkExpr "tests/Samples/GetNthPoly.hs" 600 Nothing Nothing "getNthCListX" 3 [AtLeast 10, RForAll getNthErrGenTest2] - , checkExpr "tests/Samples/GetNthPoly.hs" 1000 Nothing Nothing "getNth" 4 [AtLeast 10] - - , checkExpr "tests/Samples/GetNthPoly.hs" 1000 Nothing Nothing "cfmapInt" 3 [AtLeast 10, RForAll cfmapTest] - , checkExpr "tests/Samples/GetNthPoly.hs" 1600 Nothing Nothing "cfmapIntX" 3 [AtLeast 10, RForAll cfmapTest] - , checkExpr "tests/Samples/GetNthPoly.hs" 600 Nothing Nothing "cfmapIntCListInt" 3 [AtLeast 2, RForAll cfmapTest] - - , checkExprReaches "tests/Samples/GetNthErr.hs" 800 Nothing Nothing (Just "error") "getNth" 3 [AtLeast 8, RForAll errors] - - , checkExpr "tests/Samples/FoldlUses.hs" 1600 Nothing Nothing "sum" 2 [AtLeast 3] - , checkExpr "tests/Samples/FoldlUses.hs" 1000 Nothing Nothing "dotProd" 3 [AtLeast 3] - - , checkExpr "tests/Samples/FoldlUsesPoly.hs" 600 Nothing Nothing "sumMinAndMax" 5 [AtLeast 10] - , checkExpr "tests/Samples/FoldlUsesPoly.hs" 400 Nothing Nothing "maxes" 7 [AtLeast 10] - , checkExpr "tests/Samples/FoldlUsesPoly.hs" 400 Nothing Nothing "switchInt" 2 [AtLeast 1] - , checkExpr "tests/Samples/FoldlUsesPoly.hs" 400 Nothing Nothing "getInInt" 2 [AtLeast 1] - , checkExpr "tests/Samples/FoldlUsesPoly.hs" 400 Nothing Nothing "switchP" 6 [AtLeast 1] - ] +sampleTests :: TestTree +sampleTests = testGroup "Samples" + [ + checkExprAssert "tests/Samples/Peano.hs" 900 (Just "equalsFour") "add" + [RForAll $ not . peano_4_out, AtLeast 10] + , checkExprAssumeAssert "tests/Samples/Peano.hs" 900 (Just "fstIsEvenAddToFour") (Just "fstIsTwo") "add" + [RExists peano_0_4, RExists peano_4_0, Exactly 2] + , checkExprAssumeAssert "tests/Samples/Peano.hs" 1200 (Just "multiplyToFour") (Just "equalsFour") "add" + [RExists peano_1_4_5, RExists peano_4_1_5, Exactly 2] + , checkExprAssumeAssert "tests/Samples/Peano.hs" 750 (Just "eqEachOtherAndAddTo4") Nothing "add" + [RForAll peano_2_2, Exactly 1] + , checkExprAssumeAssert "tests/Samples/Peano.hs" 600 (Just "equalsFour") Nothing "add" + [ RExists peano_0_4 + , RExists peano_1_3 + , RExists peano_2_2 + , RExists peano_3_1 + , RExists peano_4_0 + , Exactly 5] + , checkExprAssumeAssert "tests/Samples/Peano.hs" 750 (Just "equalsFour") Nothing "multiply" + [ RExists peano_1_4 + , RExists peano_2_2 + , RExists peano_4_1 + , Exactly 3] -liquidTests :: IO TestTree -liquidTests = - return . testGroup "Liquid" - =<< sequence [ - checkLiquid "tests/Liquid/SimpleMath.hs" "abs2" 2000 2 [RForAll (\[x, y] -> isDouble x ((==) 0) && isDouble y ((==) 0)), Exactly 1] - , checkLiquid "tests/Liquid/SimpleMath.hs" "add" 800 3 - [RForAll (\[x, y, z] -> isInt x $ \x' -> isInt y $ \y' -> isInt z $ \z' -> x' > z' || y' > z'), AtLeast 1] - , checkLiquid "tests/Liquid/SimpleMath.hs" "subToPos" 1000 3 - [RForAll (\[x, y, z] -> isInt x $ \x' -> isInt y $ \y' -> isInt z $ \z' -> x' > 0 && x' >= y' && z' <= 0), AtLeast 1] - , checkLiquidWithNoCutOff "tests/Liquid/SimpleMath.hs" "fib" 4000 2 - [RForAll (\[x, y] -> isInt x $ \x' -> isInt y $ \y' -> x' > y'), AtLeast 3] - , checkLiquidWithNoCutOff "tests/Liquid/SimpleMath.hs" "fib'" 6000 2 - [RForAll (\[x, y] -> isInt x $ \x' -> isInt y $ \y' -> x' > y'), AtLeast 3] - , checkLiquid "tests/Liquid/SimpleMath.hs" "xSqPlusYSq" 1000 3 - [RForAll (\[x, y, z] -> isInt x $ \x' -> isInt y $ \y' -> isInt z $ \z' -> x' + y' >= z'), AtLeast 1] + , checkExprAssume "tests/Samples/HigherOrderMath.hs" 800 (Just "isTrue0") "notNegativeAt0NegativeAt1" + [RExists negativeSquareRes, AtLeast 1] + , checkExprAssume "tests/Samples/HigherOrderMath.hs" 600 (Just "isTrue1") "fixed" + [ RExists abs2NonNeg + , RExists squareRes + , RExists fourthPowerRes + , RForAll allabs2NonNeg + , AtLeast 4] + , checkExpr "tests/Samples/HigherOrderMath.hs" 600 "fixed" [ RExists abs2NonNeg + , RExists squareRes + , RExists fourthPowerRes + , AtLeast 4] + , checkExprAssumeAssert "tests/Samples/HigherOrderMath.hs" 600 (Just "isTrue2") Nothing "sameFloatArgLarger" + [ RExists addRes + , RExists subRes + , AtLeast 2] + , checkExpr "tests/Samples/HigherOrderMath.hs" 600 "functionSatisfies" [RExists functionSatisfiesRes, AtLeast 1] + , checkExpr "tests/Samples/HigherOrderMath.hs" 1000 "approxSqrt" [AtLeast 2] + -- The below test fails because Z3 returns unknown. + -- , checkExprAssume "tests/Samples/HigherOrderMath.hs" 1200 (Just "isTrue2") "sameFloatArgLarger" 2 + -- [ RExists approxSqrtRes + -- , RExists pythagoreanRes + -- , AtLeast 2] + + , checkExprAssumeAssert "tests/Samples/McCarthy91.hs" 1000 (Just "lessThan91") Nothing "mccarthy" + [ RForAll (\[App _ (Lit (LitInt x)), _] -> x <= 100) + , AtLeast 1] + , checkExprAssumeAssert "tests/Samples/McCarthy91.hs" 400 (Just "greaterThan10Less") Nothing "mccarthy" + [ RForAll (\[App _ (Lit (LitInt x)), _] -> x > 100) + , AtLeast 1] + , checkExprAssumeAssert "tests/Samples/McCarthy91.hs" 1000 (Just "lessThanNot91") Nothing "mccarthy" [Exactly 0] + , checkExprAssumeAssert "tests/Samples/McCarthy91.hs" 1000 (Just "greaterThanNot10Less") Nothing "mccarthy" + [Exactly 0] - , checkLiquid "tests/Liquid/SimplePoly.hs" "snd2Int" 800 3 [RForAll (\[x, y, z] -> isInt x $ \x' -> isInt y $ \y' -> isInt z $ \z' -> x' /= y' && y' == z'), Exactly 1] - , checkLiquid "tests/Liquid/SimplePoly.hs" "sumPair" 800 2 [AtLeast 1, RForAll (\[App (App _ x) y, z] -> isInt x $ \x' -> isInt y $ \y' -> isInt z $ \z' -> x' > z' || y' > z')] - , checkLiquid "tests/Liquid/SimplePoly.hs" "switchInt" 600 2 [Exactly 1, RForAll (\[App (App _ x) _, App (App _ _) y] -> getIntB x $ \ x' -> getIntB y $ \ y' -> x' == y')] + , checkInputOutput "tests/Samples/GetNth.hs" "getNth" 600 [AtLeast 10] + , checkInputOutputs "tests/Samples/GetNthPoly.hs" [ ("getNthInt", 600, [AtLeast 10]) + , ("getNthX", 600, [AtLeast 10]) + , ("getNthPeano", 600, [AtLeast 10]) + , ("getNthCListInt", 600, [AtLeast 10]) + , ("getNthCListX", 600, [AtLeast 10]) + , ("getNth", 1000, [AtLeast 10]) - , checkLiquid "tests/Liquid/Peano.hs" "add" 1400 3 [RForAll (\[x, y, _] -> x `eqIgT` zeroPeano || y `eqIgT` zeroPeano), AtLeast 5] - , checkLiquid "tests/Liquid/Peano.hs" "fromInt" 600 2 [RForAll (\[x, y] -> isInt x (\x' -> x' == 0) && y `eqIgT` zeroPeano), AtLeast 1] + , ("cfmapInt", 1000, [AtLeast 10]) + , ("cfmapIntX", 1600, [AtLeast 10]) + , ("cfmapIntCListInt", 600, [AtLeast 2]) ] - , checkLiquidWithNoCutOff "tests/Liquid/GetNth.hs" "getNthInt" 2700 3 [AtLeast 3, RForAll getNthErrors] - , checkLiquidWithCutOff "tests/Liquid/GetNth.hs" "sumC" 2000 1000 2 [AtLeast 3, RForAll (\[_, y] -> isInt y $ (==) 0)] - , checkLiquidWithNoCutOff "tests/Liquid/GetNth.hs" "getNth" 2700 4 [AtLeast 3] - , checkLiquidWithCutOff "tests/Liquid/GetNth.hs" "sumCList" 2000 1000 4 [AtLeast 3] + , checkExprReaches "tests/Samples/GetNthErr.hs" 800 Nothing Nothing (Just "error") "getNth" + [AtLeast 8, RForAll errors] - , checkLiquid "tests/Liquid/DataRefTest.hs" "addMaybe" 1000 3 - [AtLeast 1, RForAll (\[_, y, z] -> isInt y $ \y' -> appNthArgIs z (\z' -> isInt z' $ \z'' -> z'' <= y') 2)] - , checkLiquid "tests/Liquid/DataRefTest.hs" "addMaybe2" 2000 3 - [AtLeast 1, RForAll (\[x, _, _] -> appNthArgIs x (\x' -> isInt x' $ \x'' -> x'' >= 0) 2) - , RForAll (\[_, y, z] -> isInt y $ \y' -> appNthArgIs z (\z' -> isInt z' $ \z'' -> z'' <= y') 2)] - , checkLiquid "tests/Liquid/DataRefTest.hs" "getLeftInts" 2000 2 - [AtLeast 1, RForAll (\[x, _] -> dcInAppHasName "Right" x 3)] - , checkLiquid "tests/Liquid/DataRefTest.hs" "sumSameInts" 2000 3 - [AtLeast 1, RForAll (\[x, y, _] -> dcInAppHasName "Right" x 3 && dcInAppHasName "Left" y 3)] - , checkLiquid "tests/Liquid/DataRefTest.hs" "sub1" 1200 4 [AtLeast 1] + , checkInputOutputs "tests/Samples/FoldlUses.hs" [ ("sum_foldl", 1600, [AtLeast 3]) + , ("dotProd", 1000, [AtLeast 3]) ] - , checkLiquid "tests/Liquid/NumOrd.hs" "subTuple" 1200 3 [AtLeast 1] + , checkInputOutputs "tests/Samples/FoldlUsesPoly.hs" [ ("sumMinAndMax", 600, [AtLeast 10]) + , ("maxes", 400, [AtLeast 10]) + , ("switchInt", 400, [AtLeast 1]) + , ("getInInt", 400, [AtLeast 1]) + , ("switchP", 400, [AtLeast 1]) ] - , checkLiquid "tests/Liquid/CommentMeasures.hs" "d" 1000 2 [AtLeast 1] - , checkLiquid "tests/Liquid/CommentMeasures.hs" "unpackCP'" 100000 2 [Exactly 0] - , checkLiquid "tests/Liquid/CommentMeasures.hs" "unpackBool" 1000 2 [AtLeast 1, RForAll (\[_, r] -> getBoolB r (== False))] - , checkLiquid "tests/Liquid/CommentMeasures.hs" "sumSameOneOfs" 100000 3 [Exactly 0] - , checkLiquid "tests/Liquid/CommentMeasures.hs" "gets2As" 2000 3 - [AtLeast 1, RExists (\[x, y, _] -> buriedDCName "B" x && buriedDCName "B" y)] - , checkLiquid "tests/Liquid/CommentMeasures.hs" "gets2As'" 1000 3 - [AtLeast 1, RExists (\[x, y, _] -> buriedDCName "A" x && buriedDCName "B" y) - , RExists (\[x, y, _] -> buriedDCName "B" x && buriedDCName "A" y)] - , checkLiquid "tests/Liquid/CommentMeasures.hs" "ge4gt5" 1000 2 - [AtLeast 1, RForAll (\[x, y] -> appNth x 1 $ \x' -> isInt x' $ \x'' -> isInt y $ \y' -> x'' == 4 && y' == 5)] + , checkInputOutput "tests/Samples/NQueens.hs" "allQueensSafe" 2000 [AtLeast 14] - , checkLiquid "tests/Liquid/ConcatList.hs" "concat2" 800 3 [AtLeast 2] - , checkLiquid "tests/Liquid/ConcatList.hs" "concat3" 800 3 [AtLeast 2] - , checkLiquid "tests/Liquid/ConcatList.hs" "concat5" 1600 3 [AtLeast 1] + ] - , checkLiquidWithConfig "tests/Liquid/Tests/Group3.lhs" "f" 1 (mkConfigTestWithMap {steps = 2200}) [AtLeast 1] +-- Tests that are intended to ensure a specific feature works, but that are not neccessarily interesting beyond that +testFileTests :: TestTree +testFileTests = testGroup "TestFiles" + [ + checkExpr "tests/TestFiles/IfTest.hs" 400 "f" + [ RForAll (\[App _ (Lit (LitInt x)), App _ (Lit (LitInt y)), App _ (Lit (LitInt r))] -> + if x == y then r == x + y else r == y) + , AtLeast 2] - , checkLiquid "tests/Liquid/Nonused.hs" "g" 2000 1 [AtLeast 1] + , checkExprAssert "tests/TestFiles/AssumeAssert.hs" 400 (Just "assertGt5") "outShouldBeGt5" [Exactly 0] + , checkExprAssert "tests/TestFiles/AssumeAssert.hs" 400 (Just "assertGt5") "outShouldBeGe5" [AtLeast 1] + , checkExprAssumeAssert "tests/TestFiles/AssumeAssert.hs" 400 + (Just "assumeGt5") (Just "assertGt5") "outShouldBeGt5" [Exactly 0] + , checkExprAssumeAssert "tests/TestFiles/AssumeAssert.hs" 400 + (Just "assumeGt5") (Just "assertGt5") "outShouldBeGe5" [Exactly 0] - -- , checkLiquid "tests/Liquid/HigherOrderRef.hs" "f1" 2000 3 [Exactly 0] - -- , checkLiquid "tests/Liquid/HigherOrderRef.hs" "f2" 2000 3 [AtLeast 4, RForAll (\[_, x, y] -> x == y)] - -- , checkLiquid "tests/Liquid/HigherOrderRef.hs" "f3" 2000 3 [Exactly 0] - -- , checkLiquid "tests/Liquid/HigherOrderRef.hs" "f4" 2000 3 [AtLeast 4, RForAll (\[_, x, _] -> isInt x $ \x' -> x' == 0)] - -- , checkLiquid "tests/Liquid/HigherOrderRef.hs" "f5" 2000 3 [Exactly 0] - -- , checkLiquid "tests/Liquid/HigherOrderRef.hs" "f6" 2000 3 [AtLeast 10] - -- , checkLiquid "tests/Liquid/HigherOrderRef.hs" "f7" 2000 3 [AtLeast 10, RForAll (\[x, _, y] -> isInt x $ \x' -> isInt y $ \y' -> x' == y')] - -- , checkLiquid "tests/Liquid/HigherOrderRef.hs" "f8" 2000 3 [AtLeast 10] - -- , checkLiquid "tests/Liquid/HigherOrderRef.hs" "callf" 2000 3 [AtLeast 1] + , checkInputOutputs "tests/TestFiles/Char.hs" [ ("char", 400, [Exactly 2]) ] - -- , checkLiquid "tests/Liquid/Error/Error1.hs" "f" 600 2 [AtLeast 1] - , checkLiquid "tests/Liquid/Error/Error2.hs" "f1" 2000 4 [AtLeast 1] - , checkLiquid "tests/Liquid/ZipWith.lhs" "distance" 1000 4 [AtLeast 3] + , checkExpr "tests/TestFiles/CheckSq.hs" 400 "checkSq" + [AtLeast 2, RExists (\[x, _] -> isInt x (\x' -> x' == 3 || x' == -3))] - , checkLiquid "tests/Liquid/HigherOrder2.hs" "f" 2000 2 [Exactly 0] - , checkLiquid "tests/Liquid/HigherOrder2.hs" "h" 2000 2 [AtLeast 1] + , checkExpr "tests/TestFiles/Defunc1.hs" 400 "f" + [RExists defunc1Add1, RExists defunc1Multiply2, RExists defuncB, AtLeast 3] + , checkInputOutputs "tests/TestFiles/Defunc1.hs" [ ("x", 400, [AtLeast 1]) + , ("mapYInt", 600, [AtLeast 1]) + , ("makeMoney", 600, [AtLeast 2]) + , ("compZZ", 1600, [AtLeast 2]) + , ("compZZ2", 1600, [AtLeast 2]) ] - , checkLiquid "tests/Liquid/Ordering.hs" "oneOrOther" 1000 2 [Exactly 0] + , checkInputOutput "tests/TestFiles/Defunc2.hs" "funcMap" 400 [AtLeast 30] - , checkLiquid "tests/Liquid/AddKV.lhs" "empty" 1000 3 [Exactly 0] + , checkExpr "tests/TestFiles/MultCase.hs" 400 "f" + [ RExists (\[App _ (Lit (LitInt x)), y] -> x == 2 && getBoolB y id) + , RExists (\[App _ (Lit (LitInt x)), y] -> x == 1 && getBoolB y id) + , RExists (\[App _ (Lit (LitInt x)), y] -> x /= 2 && x /= 1 && getBoolB y not)] - , checkLiquid "tests/Liquid/PropSize.hs" "prop_size" 2000 1 [AtLeast 1] - , checkLiquid "tests/Liquid/PropSize2.hs" "prop_size" 2000 1 [AtLeast 1] + , checkExprAssumeAssert "tests/TestFiles/LetFloating/LetFloating.hs" 400 (Just "output6") Nothing "f" + [AtLeast 1, RExists (\[App _ (Lit (LitInt x)), _] -> x == 6)] + , checkExprAssumeAssert "tests/TestFiles/LetFloating/LetFloating2.hs" 400 (Just "output16") Nothing "f" + [AtLeast 1, RExists (\[App _ (Lit (LitInt x)), _] -> x == 15)] + , checkExprAssumeAssert "tests/TestFiles/LetFloating/LetFloating3.hs" 600 (Just "output32") Nothing "f" + [AtLeast 1, RExists (\[App _ (Lit (LitInt x)), _] -> x == 4)] + , checkExprAssumeAssert "tests/TestFiles/LetFloating/LetFloating4.hs" 400 (Just "output12") Nothing "f" + [AtLeast 1, RExists (\[App _ (Lit (LitInt x)), _] -> x == 11)] + , checkExprAssumeAssert "tests/TestFiles/LetFloating/LetFloating5.hs" 400 (Just "output19") Nothing "f" + [AtLeast 1, RForAll (\[App _ (Lit (LitInt x)), App _ (Lit (LitInt y)), _] -> x + y + 1 == 19)] + , checkExprAssumeAssert "tests/TestFiles/LetFloating/LetFloating6.hs" 400 (Just "output32") Nothing "f" + [AtLeast 1, RExists (\[App _ (Lit (LitInt x)), _] -> x == 25)] - , checkLiquidWithConfig "tests/Liquid/WhereFuncs.lhs" "f" 3 (mkConfigTestWithMap {steps = 1000}) [Exactly 0] - , checkLiquidWithConfig "tests/Liquid/WhereFuncs.lhs" "g" 3 (mkConfigTestWithMap {steps = 1000}) [Exactly 0] + , checkExpr "tests/TestFiles/TypeClass/TypeClass1.hs" 400 "f" [RExists (\[x, y] -> x == y), Exactly 1] + , checkExpr "tests/TestFiles/TypeClass/TypeClass2.hs" 400 "f" [RExists (\[x, y] -> x == y), Exactly 1] + , checkExpr "tests/TestFiles/TypeClass/TypeClass3.hs" 400 "f" + [RExists (\[x, y] -> getIntB x $ \x' -> getIntB y $ \y' -> x' + 8 == y'), Exactly 1] + , checkExpr "tests/TestFiles/TypeClass/TypeClass4.hs" 1000 "f" [AtLeast 1] - , checkLiquid "tests/Liquid/PropConcat.lhs" "prop_concat" 1000 1 [AtLeast 1] + , checkExprAssumeAssert "tests/TestFiles/TypeClass/HKTypeClass1.hs" 400 (Just "largeJ") Nothing "extractJ" + [RForAll (\[x, ly@(App _ (Lit (LitInt y)))] -> appNthArgIs x (ly ==) 2 && y > 100), Exactly 1] + , checkExprAssumeAssert "tests/TestFiles/TypeClass/HKTypeClass1.hs" 400 (Just "largeE") Nothing "extractE" + [RForAll (\[x, ly@(App _ (Lit (LitInt y)))] -> appNthArgIs x (ly ==) 4 && y > 100), Exactly 1] + , checkExpr "tests/TestFiles/TypeClass/HKTypeClass1.hs" 400 "changeJ" + [RForAll (\[_, x, y] -> dcInAppHasName "J" x 2 && (dcInAppHasName "J" y 2 || isError y)), AtLeast 2] - , checkLiquid "tests/Liquid/Distance.lhs" "distance" 1000 4 [AtLeast 1] - , checkLiquid "tests/Liquid/MultModules/CallZ.lhs" "callZ" 1000 3 [AtLeast 1] - , checkAbsLiquid "tests/Liquid/AddToEven.hs" "f" 2000 1 - [ AtLeast 1 - , RForAll $ \[i] r [(FuncCall { funcName = Name n _ _ _, returns = fcr }) ] - -> n == "g" - && isInt i (\i' -> i' `mod` 2 == 0 && - isInt r (\r' -> isInt fcr (\fcr' -> r' == i' + fcr')))] + , checkExpr "tests/TestFiles/Case1.hs" 400 "f" + [ RExists (\[App _ (Lit (LitInt x)), y] -> x < 0 && dcHasName "A" y) + , RExists (\[App _ (Lit (LitInt x)), y] -> x >= 0 && dcHasName "C" y), Exactly 2] + , checkExpr "tests/TestFiles/Case2.hs" 400 "f" + [ RExists exists1 + , RExists exists2 + , RExists exists3 + , RExists exists4 + , AtLeast 4] - , checkLiquid "tests/Liquid/ListTests.lhs" "r" 1000 1 [Exactly 0] - , checkLiquid "tests/Liquid/ListTests.lhs" "prop_map" 1500 3 [AtLeast 3] - , checkLiquid "tests/Liquid/ListTests.lhs" "prop_concat_1" 1500 1 [AtLeast 1] - , checkAbsLiquid "tests/Liquid/ListTests2.lhs" "prop_map" 2000 4 - [ AtLeast 3 - , RForAll (\[_, _, f, _] _ [(FuncCall { funcName = Name n _ _ _, arguments = [_, _, _, _, f', _] }) ] -> n == "map" && f == f') ] - , checkAbsLiquid "tests/Liquid/ListTests2.lhs" "replicate" 2000 3 - [ AtLeast 3 - , RForAll (\[_, nA, aA] _ [(FuncCall { funcName = Name n _ _ _, arguments = [_, _, nA', aA'] }) ] - -> n == "replicate" && nA == nA' && aA == aA') ] - , checkAbsLiquid "tests/Liquid/ListTests2.lhs" "prop_size" 2000 0 - [ AtLeast 1 - , RForAll (\[] _ [(FuncCall { funcName = Name n _ _ _, returns = r }) ] - -> n == "length2" && getIntB r (/= 3)) ] + , checkExprAssumeAssert "tests/TestFiles/Guards.hs" 400 (Just "g") Nothing "f" + [AtLeast 1, RExists (\[dc, _] -> getBoolB dc id)] - , checkLiquid "tests/Liquid/MapReduceTest2.lhs" "mapReduce" 1500 3 [Exactly 0] + , checkExprAssumeAssert "tests/TestFiles/Infinite.hs" 400 (Just "g") Nothing "f" + [AtLeast 1, RExists (\[App _ (Lit (LitInt x)), _] -> x <= 100 && x /= 80)] - , checkLiquid "tests/Liquid/MeasErr.hs" "f" 1500 2 [Exactly 0] + , checkExpr "tests/TestFiles/Strictness1.hs" 400 "f" + [AtLeast 1, RExists (\[(App x (App _ (Lit (LitInt y))))] -> dcHasName "A" x && y == 9)] - , checkAbsLiquid "tests/Liquid/Replicate.hs" "replicate" 2000 3 - [ AtLeast 1 - , RExists (\_ _ [(FuncCall { funcName = Name n _ _ _ }) ] -> n == "foldl") ] - , checkAbsLiquid "tests/Liquid/Replicate.hs" "r" 2000 2 - [ AtLeast 1 - , RExists (\_ _ [(FuncCall { funcName = Name n _ _ _ }) ] -> n == "foldl") ] + , checkExpr "tests/TestFiles/Where1.hs" 400 "f" + [ RExists (\[App _ (Lit (LitInt x)), App _ (Lit (LitInt y))] -> x == 4 && y == 1) + , RExists (\[App _ (Lit (LitInt x)), App _ (Lit (LitInt y))] -> x /= 4 && y == 1) ] + + , checkInputOutputs "tests/TestFiles/Error/Error1.hs" [ ("f", 400, [AtLeast 1]) + , ("g", 400, [AtLeast 1]) + , ("f", 400, [AtLeast 1]) + , ("f", 400, [AtLeast 1]) + , ("g", 400, [AtLeast 1]) ] + , checkInputOutputs "tests/TestFiles/Error/Undefined1.hs" [ ("undefined1", 400, [AtLeast 1]) + , ("undefined2", 400, [AtLeast 1])] + , checkInputOutput "tests/TestFiles/Error/IrrefutError.hs" "f" 400 [AtLeast 2] - , checkAbsLiquid "tests/Liquid/AbsTypeClass.hs" "callF" 1000 1 - [ AtLeast 1 - , RExists (\_ _ [(FuncCall { funcName = Name n _ _ _ }) ] -> n == "f") ] - , checkAbsLiquid "tests/Liquid/AbsTypeClassVerified.hs" "callF" 10000 1 [ Exactly 0 ] - ] + , checkInputOutputs "tests/TestFiles/BadNames1.hs" [ ("abs'", 400, [Exactly 2]) + , ("xswitch", 400, [AtLeast 10]) ] --- Tests that are intended to ensure a specific feature works, but that are not neccessarily interesting beyond that -testFileTests :: IO TestTree -testFileTests = - return . testGroup "TestFiles" - =<< sequence [ - checkExpr "tests/TestFiles/IfTest.hs" 400 Nothing Nothing "f" 3 [RForAll (\[App _ (Lit (LitInt x)), App _ (Lit (LitInt y)), App _ (Lit (LitInt r))] -> if x == y then r == x + y else r == y), AtLeast 2] + , checkInputOutputs "tests/TestFiles/ListCallStack.hs" [ ("indexOf", 400, [AtLeast 2]) + , ("headOf", 400, [AtLeast 2]) + , ("tailOf", 400, [AtLeast 2]) + , ("lastOf", 400, [AtLeast 2]) + , ("initOf", 400, [AtLeast 2]) + , ("cycleOf", 400, [AtLeast 2]) ] - , checkExpr "tests/TestFiles/AssumeAssert.hs" 400 Nothing (Just "assertGt5") "outShouldBeGt5" 2 [Exactly 0] - , checkExpr "tests/TestFiles/AssumeAssert.hs" 400 Nothing (Just "assertGt5") "outShouldBeGe5" 2 [AtLeast 1] - , checkExpr "tests/TestFiles/AssumeAssert.hs" 400 (Just "assumeGt5") (Just "assertGt5") "outShouldBeGt5" 2 [Exactly 0] - , checkExpr "tests/TestFiles/AssumeAssert.hs" 400 (Just "assumeGt5") (Just "assertGt5") "outShouldBeGe5" 2 [Exactly 0] + , checkExpr "tests/TestFiles/PolyDataTy1.hs" 400 "f" + [Exactly 2, RExists (\[x, _, y] -> x == y), RExists (\[_, App _ x, y] -> x == y)] + , checkExpr "tests/TestFiles/PolyDataTy1.hs" 400 "getFstXIntInt" + [AtLeast 2, RExists (\[x, y] -> isApp x && isError y)] + , checkExpr "tests/TestFiles/PolyDataTy1.hs" 400 "sum" [AtLeast 3, RExists (\[x, y] -> isApp x && isError y)] - , checkExpr "tests/TestFiles/CheckSq.hs" 400 Nothing Nothing "checkSq" 2 [AtLeast 2, RExists (\[x, _] -> isInt x (\x' -> x' == 3))] + , checkExprAssumeAssert "tests/TestFiles/MultiSplit.hs" 1000 (Just "equals1") Nothing "f" [Exactly 0] - , checkExpr "tests/TestFiles/Defunc1.hs" 400 Nothing Nothing "f" 2 [RExists defunc1Add1, RExists defunc1Multiply2, RExists defuncB, AtLeast 3] - , checkExpr "tests/TestFiles/Defunc1.hs" 400 Nothing Nothing "x" 2 [AtLeast 1] - , checkExpr "tests/TestFiles/Defunc1.hs" 600 Nothing Nothing "mapYInt" 3 [AtLeast 1] - , checkExpr "tests/TestFiles/Defunc1.hs" 600 Nothing Nothing "makeMoney" 3 [AtLeast 3] - , checkExpr "tests/TestFiles/Defunc1.hs" 1600 Nothing Nothing "compZZ" 4 [AtLeast 2, RForAll (\[_, _, _, x] -> getBoolB x not)] - , checkExpr "tests/TestFiles/Defunc1.hs" 1600 Nothing Nothing "compZZ2" 4 [AtLeast 2, RForAll (\[_, _, _, x] -> getBoolB x not)] + , checkExpr "tests/TestFiles/MatchesFunc1.hs" 400 "f" + [RExists (\[x, y] -> getIntB x $ \x' -> getIntB y $ \y' -> y' == 6 + x'), AtLeast 1] - , checkExpr "tests/TestFiles/Defunc2.hs" 400 Nothing Nothing "funcMap" 3 [RForAll defunc2Check, AtLeast 30] + , checkInputOutput "tests/TestFiles/Read.hs" "concRead" 20000 [Exactly 1] - , checkExpr "tests/TestFiles/MultCase.hs" 400 Nothing Nothing "f" 2 - [ RExists (\[App _ (Lit (LitInt x)), y] -> x == 2 && getBoolB y id) - , RExists (\[App _ (Lit (LitInt x)), y] -> x == 1 && getBoolB y id) - , RExists (\[App _ (Lit (LitInt x)), y] -> x /= 2 && x /= 1 && getBoolB y not)] + , checkExpr "tests/TestFiles/RecordFields1.hs" 400 "f" + [ RExists + (\[x, y] -> appNthArgIs x notCast 0 + && appNthArgIs x (\x' -> getIntB x' $ \x'' -> getIntB y $ \y' -> x'' + 1 == y') 1) + , Exactly 1] + , checkExpr "tests/TestFiles/RecordFields1.hs" 400 "fCall" [RExists (\[x] -> isInt x ((==) 35)), Exactly 1] + , checkExpr "tests/TestFiles/RecordFields1.hs" 400 "g" + [ RExists (\[x, y] -> appNthArgIs x (dcHasName "A") 2 && appNthArgIs y (dcHasName "B") 2) + , RExists (\[x, y] -> appNthArgIs x (dcHasName "B") 2 && appNthArgIs y (dcHasName "C") 2) + , RExists (\[x, y] -> appNthArgIs x (dcHasName "C") 2 && appNthArgIs y (dcHasName "A") 2) + , Exactly 3] - , checkExpr "tests/TestFiles/LetFloating/LetFloating.hs" 400 (Just "output6") Nothing "f" 2 [AtLeast 1, RExists (\[App _ (Lit (LitInt x)), _] -> x == 6)] - , checkExpr "tests/TestFiles/LetFloating/LetFloating2.hs" 400 (Just "output16") Nothing "f" 2 [AtLeast 1, RExists (\[App _ (Lit (LitInt x)), _] -> x == 15)] - , checkExpr "tests/TestFiles/LetFloating/LetFloating3.hs" 600 (Just "output32") Nothing "f" 2 [AtLeast 1, RExists (\[App _ (Lit (LitInt x)), _] -> x == 4)] - , checkExpr "tests/TestFiles/LetFloating/LetFloating4.hs" 400 (Just "output12") Nothing "f" 2 [AtLeast 1, RExists (\[App _ (Lit (LitInt x)), _] -> x == 11)] - , checkExpr "tests/TestFiles/LetFloating/LetFloating5.hs" 400 (Just "output19") Nothing "f" 3 [AtLeast 1, RForAll (\[App _ (Lit (LitInt x)), App _ (Lit (LitInt y)), _] -> x + y + 1 == 19)] - , checkExpr "tests/TestFiles/LetFloating/LetFloating6.hs" 400 (Just "output32") Nothing "f" 2 [AtLeast 1, RExists (\[App _ (Lit (LitInt x)), _] -> x == 25)] + , checkInputOutputs "tests/TestFiles/Deriving/DerivingSimple.hs" [ ("eq", 400, [AtLeast 2]) + , ("lt", 400, [AtLeast 2]) ] + , checkInputOutputs "tests/TestFiles/Deriving/DerivingComp.hs" [ ("eq", 800, [AtLeast 2]) + , ("lt", 800, [AtLeast 2]) ] - , checkExpr "tests/TestFiles/TypeClass/TypeClass1.hs" 400 Nothing Nothing "f" 2 [RExists (\[x, y] -> x == y), Exactly 1] - , checkExpr "tests/TestFiles/TypeClass/TypeClass2.hs" 400 Nothing Nothing "f" 2 [RExists (\[x, y] -> x == y), Exactly 1] - , checkExpr "tests/TestFiles/TypeClass/TypeClass3.hs" 400 Nothing Nothing "f" 2 [RExists (\[x, y] -> getIntB x $ \x' -> getIntB y $ \y' -> x' + 8 == y'), Exactly 1] - , checkExprWithConfig "tests/TestFiles/TypeClass/TypeClass4.hs" Nothing Nothing Nothing "f" 1 (mkConfigTestWithMap {steps = 1000}) [AtLeast 1] + , checkInputOutputs "tests/TestFiles/Coercions/Age.hs" [ ("born", 400, [Exactly 1]) + , ("yearPasses", 400, [AtLeast 1]) + , ("age", 400, [AtLeast 1]) + , ("diffAge", 400, [AtLeast 1]) + , ("yearBefore", 400, [AtLeast 5])] + , checkInputOutputs "tests/TestFiles/Coercions/NewType1.hs" [ ("add1N4", 400, [Exactly 1]) + , ("f", 400, [Exactly 1]) + , ("g", 400, [Exactly 1]) + , ("mapWInt", 400, [AtLeast 2]) + , ("appLeftFloat", 400, [AtLeast 2]) + , ("getLIntFloat", 400, [AtLeast 2]) + , ("getRIntFloat", 400, [AtLeast 2]) + , ("getCIntFloatDouble", 400, [AtLeast 2]) + , ("getRIntFloatX'", 400, [AtLeast 2])] - , checkExpr "tests/TestFiles/TypeClass/HKTypeClass1.hs" 400 (Just "largeJ") Nothing "extractJ" 2 [RForAll (\[x, ly@(App _ (Lit (LitInt y)))] -> appNthArgIs x (ly ==) 2 && y > 100), Exactly 1] - , checkExpr "tests/TestFiles/TypeClass/HKTypeClass1.hs" 400 (Just "largeE") Nothing "extractE" 2 [RForAll (\[x, ly@(App _ (Lit (LitInt y)))] -> appNthArgIs x (ly ==) 4 && y > 100), Exactly 1] - , checkExpr "tests/TestFiles/TypeClass/HKTypeClass1.hs" 400 Nothing Nothing "changeJ" 3 [RForAll (\[_, x, y] -> dcInAppHasName "J" x 2 && (dcInAppHasName "J" y 2 || isError y)), AtLeast 2] + , checkInputOutput "tests/TestFiles/Coercions/BadCoerce.hs" "f" 400 [AtLeast 1] + , checkInputOutput "tests/TestFiles/Expr.hs" "leadingLams" 400 [AtLeast 5] - , checkExpr "tests/TestFiles/Case1.hs" 400 Nothing Nothing "f" 2 [ RExists (\[App _ (Lit (LitInt x)), y] -> x < 0 && dcHasName "A" y) - , RExists (\[App _ (Lit (LitInt x)), y] -> x >= 0 && dcHasName "C" y), Exactly 2] - , checkExpr "tests/TestFiles/Case2.hs" 400 Nothing Nothing "f" 2 - [ RExists exists1 - , RExists exists2 - , RExists exists3 - , RExists exists4 - , AtLeast 4] + , checkExprAssume "tests/TestFiles/Subseq.hs" 1200 (Just "assume") "subseqTest" [AtLeast 1] - , checkExpr "tests/TestFiles/Guards.hs" 400 (Just "g") Nothing "f" 2 [AtLeast 1, RExists (\[dc, _] -> getBoolB dc id)] + , checkInputOutputs "tests/TestFiles/Strings/Strings1.hs" [ ("con", 300, [AtLeast 10]) + , ("eq", 700, [AtLeast 10]) + , ("eqGt1", 700, [AtLeast 10]) + , ("capABC", 200, [AtLeast 10]) + , ("appendEq", 500, [AtLeast 5]) ] - , checkExpr "tests/TestFiles/Infinite.hs" 400 (Just "g") Nothing "f" 2 [AtLeast 1, RExists (\[App _ (Lit (LitInt x)), _] -> x <= 100 && x /= 80)] + , checkExpr "tests/TestFiles/Strings/Strings1.hs" 1000 "exclaimEq" + [AtLeast 5, RExists (\[_, _, r] -> dcHasName "True" r)] - , checkExpr "tests/TestFiles/Strictness1.hs" 400 Nothing Nothing "f" 1 [AtLeast 1, RExists (\[(App x (App _ (Lit (LitInt y))))] -> dcHasName "A" x && y == 9)] + , checkExpr "tests/TestFiles/Sets/SetInsert.hs" 700 "prop" [AtLeast 3] + + , checkInputOutputs "tests/TestFiles/BadDC.hs" [ ("f", 400, [AtLeast 5]) + , ("g", 400, [AtLeast 3]) ] - , checkExpr "tests/TestFiles/Where1.hs" 400 Nothing Nothing "f" 2 [ RExists (\[App _ (Lit (LitInt x)), App _ (Lit (LitInt y))] -> x == 4 && y == 1) - , RExists (\[App _ (Lit (LitInt x)), App _ (Lit (LitInt y))] -> x /= 4 && y == 1) ] - - , checkExpr "tests/TestFiles/Error/Error1.hs" 400 Nothing Nothing "f" 2 [AtLeast 1, RForAll(errors)] - , checkExpr "tests/TestFiles/Error/Error1.hs" 400 Nothing Nothing "g" 2 [AtLeast 1, RForAll(errors)] - , checkExpr "tests/TestFiles/Error/Error2.hs" 400 Nothing Nothing "f" 1 [AtLeast 1, RForAll(errors)] - , checkExpr "tests/TestFiles/Error/Error3.hs" 400 Nothing Nothing "f" 2 [AtLeast 1, RForAll(errors)] - , checkExpr "tests/TestFiles/Error/Error3.hs" 400 Nothing Nothing "g" 2 [AtLeast 1, RForAll(not . errors)] - , checkExpr "tests/TestFiles/Error/Undefined1.hs" 400 Nothing Nothing "undefined1" 2 [AtLeast 1, RForAll(errors)] - , checkExpr "tests/TestFiles/Error/Undefined1.hs" 400 Nothing Nothing "undefined2" 2 [AtLeast 1, RForAll(errors)] + , checkInputOutputsTemplate "tests/HigherOrder/HigherOrder.hs" [ ("f", 50, [AtLeast 5]) + , ("h", 100, [AtLeast 3]) + , ("assoc", 200, [AtLeast 5]) + , ("sf", 150, [AtLeast 5]) + , ("thirdOrder", 75, [AtLeast 10]) + , ("tupleTestMono", 175, [AtLeast 10])] + , checkInputOutputsTemplate "tests/HigherOrder/PolyHigherOrder.hs" [ ("f", 50, [AtLeast 5]) + , ("h", 200, [AtLeast 3]) + , ("assoc", 200, [AtLeast 5]) + , ("sf", 150, [AtLeast 5]) + , ("tupleTest", 175, [AtLeast 8])] + , checkInputOutputsNonRedTemp "tests/HigherOrder/HigherOrder.hs" [ ("f", 200, [Exactly 3]) + , ("h", 150, [Exactly 2]) + , ("assoc", 200, [Exactly 2]) + , ("sf", 200, [Exactly 2]) + , ("thirdOrder", 300, [Exactly 2]) + , ("thirdOrder2", 300, [Exactly 3]) + , ("tupleTestMono", 175, [Exactly 2])] + -- , checkInputOutput "tests/TestFiles/BadBool.hs" "BadBool" "f" 1400 [AtLeast 1] + -- , checkExprAssumeAssert "tests/TestFiles/Coercions/GADT.hs" 400 Nothing Nothing "g" 2 + -- [ AtLeast 2 + -- , RExists (\[x, y] -> x == Lit (LitInt 0) && y == App (Data (PrimCon I)) (Lit (LitInt 0))) + -- , RExists (\[x, _] -> x /= Lit (LitInt 0))] + -- , checkExprAssumeAssert "tests/TestFiles/HigherOrderList.hs" 400 Nothing Nothing "g" [AtLeast 10] + , checkExpr "tests/TestFiles/MkSymbolic.hs" 1500 "f" [ Exactly 9 ] - , checkExpr "tests/TestFiles/BadNames1.hs" 400 Nothing Nothing "abs'" 2 [Exactly 2] - , checkExpr "tests/TestFiles/BadNames1.hs" 400 Nothing Nothing "xswitch" 2 [AtLeast 10] + , checkInputOutputs "tests/TestFiles/Show.hs" [ ("show1", 1000, [Exactly 1]) + , ("show2", 1000, [Exactly 1]) + , ("show3", 1000, [AtLeast 3]) + , ("show4", 1000, [Exactly 2]) + , ("show5", 1300, [AtLeast 12]) + , ("checkWS", 1000, [Exactly 5]) ] + ] - , checkExpr "tests/TestFiles/PolyDataTy1.hs" 400 Nothing Nothing "f" 3 [Exactly 2, RExists (\[x, _, y] -> x == y), RExists (\[_, App _ x, y] -> x == y)] - , checkExpr "tests/TestFiles/PolyDataTy1.hs" 400 Nothing Nothing "getFstXIntInt" 2 [AtLeast 2, RExists (\[x, y] -> isApp x && isError y)] - , checkExpr "tests/TestFiles/PolyDataTy1.hs" 400 Nothing Nothing "sum" 2 [AtLeast 3, RExists (\[x, y] -> isApp x && isError y)] +extensionTests :: TestTree +extensionTests = testGroup "Extensions" + [ + checkInputOutputs "tests/TestFiles/Extensions/PatternSynonyms1.hs" [ ("isNineInt", 400, [AtLeast 2]) + , ("isNineInteger", 400, [AtLeast 2]) + , ("isNineFloat", 400, [AtLeast 2]) + , ("isFunc", 400, [AtLeast 2]) + , ("funcArg", 400, [AtLeast 2]) + + , ("consArrow", 400, [AtLeast 2]) ] + , checkInputOutputs "tests/TestFiles/Extensions/ViewPatterns1.hs" [ ("shapeToNumSides", 4000, [Exactly 4]) ] + , checkInputOutputs "tests/TestFiles/Extensions/FlexibleContexts1.hs" [ ("callF", 400, [AtLeast 2]) + , ("callF2", 400, [AtLeast 2]) + , ("callF3", 400, [AtLeast 2]) + , ("callG", 400, [AtLeast 1]) + , ("callG2", 400, [AtLeast 1]) ] + ] - , checkExpr "tests/TestFiles/MultiSplit.hs" 1000 (Just "equals1") Nothing "f" 3 [Exactly 0] +baseTests :: TestTree +baseTests = testGroup "Base" + [ + checkInputOutput "tests/Samples/Peano.hs" "add" 400 [AtLeast 4] - , checkExpr "tests/TestFiles/MatchesFunc1.hs" 400 Nothing Nothing "f" 2 [RExists (\[x, y] -> getIntB x $ \x' -> getIntB y $ \y' -> y' == 6 + x'), AtLeast 1] + , checkInputOutputs "tests/BaseTests/ListTests.hs" [ ("test", 1000, [AtLeast 1]) + , ("maxMap", 1000, [AtLeast 4]) + , ("minTest", 1000, [AtLeast 2]) + , ("foldrTest2", 1000, [AtLeast 1]) ] - , checkExpr "tests/TestFiles/RecordFields1.hs" 400 Nothing Nothing "f" 2 [RExists (\[x, y] -> appNthArgIs x notCast 0 && appNthArgIs x (\x' -> getIntB x' $ \x'' -> getIntB y $ \y' -> x'' + 1 == y') 1), Exactly 1] - , checkExpr "tests/TestFiles/RecordFields1.hs" 400 Nothing Nothing "fCall" 1 [RExists (\[x] -> isInt x ((==) 35)), Exactly 1] - , checkExpr "tests/TestFiles/RecordFields1.hs" 400 Nothing Nothing "g" 2 [ RExists (\[x, y] -> appNthArgIs x (dcHasName "A") 2 && appNthArgIs y (dcHasName "B") 2) - , RExists (\[x, y] -> appNthArgIs x (dcHasName "B") 2 && appNthArgIs y (dcHasName "C") 2) - , RExists (\[x, y] -> appNthArgIs x (dcHasName "C") 2 && appNthArgIs y (dcHasName "A") 2) - , Exactly 3] + , checkInputOutput "tests/BaseTests/Tuples.hs" "addTupleElems" 1000 [AtLeast 2] - , checkExpr "tests/TestFiles/Deriving/DerivingSimple.hs" 400 Nothing Nothing "eq" 3 [AtLeast 2, RForAll (\[_, _, x] -> isBool x)] - , checkExpr "tests/TestFiles/Deriving/DerivingSimple.hs" 400 Nothing Nothing "lt" 3 [AtLeast 2, RForAll (\[_, _, x] -> isBool x)] - , checkExpr "tests/TestFiles/Deriving/DerivingComp.hs" 800 Nothing Nothing "eq" 3 [AtLeast 2, RForAll (\[_, _, x] -> isBool x)] - , checkExpr "tests/TestFiles/Deriving/DerivingComp.hs" 800 Nothing Nothing "lt" 3 [AtLeast 2, RForAll (\[_, _, x] -> isBool x)] + , checkInputOutputs "tests/BaseTests/MaybeTest.hs" [ ("headMaybeInt", 1000, [AtLeast 2]) + , ("sumN", 1000, [AtLeast 6]) + , ("lengthN", 1000, [AtLeast 6]) ] - , checkExpr "tests/TestFiles/Coercions/Age.hs" 400 Nothing Nothing "born" 1 [ Exactly 1 - , RForAll (\[x] -> inCast x (\x' -> appNthArgIs x' (Lit (LitInt 0) ==) 1) (\(t1 :~ t2) -> isIntT t1 && typeNameIs t2 "Age"))] - , checkExpr "tests/TestFiles/Coercions/Age.hs" 400 Nothing Nothing "yearPasses" 2 [ AtLeast 1 - , RForAll (\[x, y] -> inCast x (const True) (\(_ :~ t2) -> typeNameIs t2 "Age") - && inCast y (const True) (\(_ :~ t2) -> typeNameIs t2 "Age") )] - , checkExpr "tests/TestFiles/Coercions/Age.hs" 400 Nothing Nothing "age" 2 [ AtLeast 1 - , RForAll (\[x, y] -> inCast x (const True) (\(_ :~ t2) -> typeNameIs t2 "Age") && isInt y (const True))] - , checkExpr "tests/TestFiles/Coercions/Age.hs" 400 Nothing Nothing "diffAge" 3 [ AtLeast 1 - , RForAll (\[x, y, z] -> inCast x (const True) (\(_ :~ t2) -> typeNameIs t2 "Age") - && inCast y (const True) (\(_ :~ t2) -> typeNameIs t2 "Age") - && inCast z (const True) (\(_ :~ t2) -> typeNameIs t2 "Years"))] - , checkExpr "tests/TestFiles/Coercions/Age.hs" 400 Nothing Nothing "yearBefore" 2 [ AtLeast 5 ] - , checkExpr "tests/TestFiles/Coercions/NewType1.hs" 400 Nothing Nothing "add1N4" 2 [ Exactly 1 - , RForAll (\[x, y] -> inCast x (const True) (\(_ :~ t2) -> typeNameIs t2 "N4") - && inCast y (const True) (\(_ :~ t2) -> typeNameIs t2 "N4"))] - , checkExpr "tests/TestFiles/Coercions/NewType1.hs" 400 Nothing Nothing "f" 2 [ Exactly 1 - , RForAll (\[x, y] -> inCast x (const True) (\(_ :~ t2) -> typeNameIs t2 "NewX") && dcHasName "X" y)] - , checkExpr "tests/TestFiles/Coercions/NewType1.hs" 400 Nothing Nothing "g" 2 [ Exactly 1 - , RForAll (\[x, y] -> dcHasName "X" x && inCast y (const True) (\(_ :~ t2) -> typeNameIs t2 "NewX"))] + , checkInputOutput "tests/BaseTests/Other.hs" "check4VeryEasy2" 600 [AtLeast 1] + ] - , checkExpr "tests/TestFiles/Coercions/NewType1.hs" 400 Nothing Nothing "mapWInt" 3 [ AtLeast 2 - , RForAll (\[_, x, y] -> isError y - || (inCast x (const True) (\(_ :~ t2) -> typeNameIs t2 "W") && - inCast x (const True) (\(_ :~ t2) -> typeNameIs t2 "W"))) ] +primTests :: TestTree +primTests = testGroup "Prims" + [ + checkInputOutputs "tests/Prim/Prim2.hs" [ ("quotI1", 1000, [AtLeast 4]) + , ("quotI2", 1000, [AtLeast 4]) + , ("remI1", 1000, [AtLeast 4]) + , ("remI2", 1000, [AtLeast 3]) + , ("remI3", 1000, [AtLeast 1]) + , ("remI4", 1000, [AtLeast 1]) - , checkExpr "tests/TestFiles/Coercions/NewType1.hs" 400 Nothing Nothing "appLeftFloat" 3 [ AtLeast 2 - , RExists (\[_, _, y] -> inCast y (\y' -> dcInAppHasName "L" y' 3) (const True)) - , RExists (\[_, _, y] -> inCast y (\y' -> dcInAppHasName "R" y' 3) (const True))] - , checkExpr "tests/TestFiles/Coercions/NewType1.hs" 400 Nothing Nothing "getLIntFloat" 2 [ AtLeast 2 - , RExists (\[_, y] -> isInt y (const True)) - , RExists (\[_, y] -> isError y)] - , checkExpr "tests/TestFiles/Coercions/NewType1.hs" 400 Nothing Nothing "getRIntFloat" 2 [ AtLeast 2 - , RExists (\[_, y] -> isFloat y (const True)) - , RExists (\[_, y] -> isError y)] - , checkExpr "tests/TestFiles/Coercions/NewType1.hs" 400 Nothing Nothing "getCIntFloatDouble" 2 [ AtLeast 2 - , RExists (\[_, y] -> isFloat y (const True)) - , RExists (\[_, y] -> isError y)] - , checkExpr "tests/TestFiles/Coercions/NewType1.hs" 400 Nothing Nothing "getRIntFloatX'" 2 [ AtLeast 2 - , RExists (\[x, y] -> inCast x (\x' -> dcInAppHasName "TR" x' 4) (const True) - && isInt y (const True)) - , RExists (\[_, y] -> isError y)] - , checkInputOutput "tests/TestFiles/Coercions/BadCoerce.hs" "BadCoerce" "f" 400 3 [AtLeast 1] - , checkExpr "tests/TestFiles/Expr.hs" 400 Nothing Nothing "leadingLams" 2 [AtLeast 5, RForAll (\[_, y] -> noUndefined y)] + , ("p1List", 300000, [AtLeast 1]) + , ("p2List", 700000, [AtLeast 1]) - , checkInputOutput "tests/TestFiles/Strings/Strings1.hs" "Strings1" "con" 300 3 [AtLeast 10] - , checkInputOutput "tests/TestFiles/Strings/Strings1.hs" "Strings1" "eq" 700 3 [AtLeast 10] - , checkInputOutput "tests/TestFiles/Strings/Strings1.hs" "Strings1" "eqGt1" 700 3 [AtLeast 10] - , checkInputOutput "tests/TestFiles/Strings/Strings1.hs" "Strings1" "capABC" 150 2 [AtLeast 10] - , checkInputOutput "tests/TestFiles/Strings/Strings1.hs" "Strings1" "appendEq" 500 2 [AtLeast 5] - , checkExpr "tests/TestFiles/Strings/Strings1.hs" 1000 Nothing Nothing "exclaimEq" 3 [AtLeast 5, RExists (\[_, _, r] -> dcHasName "True" r)] - - , checkInputOutput "tests/TestFiles/BadDC.hs" "BadDC" "f" 400 2 [AtLeast 5] - , checkInputOutput "tests/TestFiles/BadDC.hs" "BadDC" "g" 400 2 [AtLeast 3] - -- , checkInputOutput "tests/TestFiles/BadBool.hs" "BadBool" "f" 1400 4 [AtLeast 1] - -- , checkExpr "tests/TestFiles/Coercions/GADT.hs" 400 Nothing Nothing "g" 2 [ AtLeast 2 - -- , RExists (\[x, y] -> x == Lit (LitInt 0) && y == App (Data (PrimCon I)) (Lit (LitInt 0))) - -- , RExists (\[x, _] -> x /= Lit (LitInt 0))] - -- , checkExpr "tests/TestFiles/HigherOrderList.hs" 400 Nothing Nothing "g" 3 [AtLeast 10] - - ] + , ("integerToFloatList", 150000, [AtLeast 1]) ] -baseTests :: IO TestTree -baseTests = - return . testGroup "Base" - =<< sequence [ - checkInputOutput "tests/Samples/Peano.hs" "Peano" "add" 400 3 [AtLeast 4] - , checkInputOutput "tests/BaseTests/ListTests.hs" "ListTests" "test" 1000 2 [AtLeast 1] - , checkInputOutput "tests/BaseTests/ListTests.hs" "ListTests" "maxMap" 1000 2 [AtLeast 4] - , checkInputOutput "tests/BaseTests/ListTests.hs" "ListTests" "minTest" 1000 2 [AtLeast 2] - , checkInputOutput "tests/BaseTests/ListTests.hs" "ListTests" "foldrTest2" 1000 2 [AtLeast 1] - , checkInputOutput "tests/BaseTests/Tuples.hs" "Tuples" "addTupleElems" 1000 2 [AtLeast 2] + , checkInputOutputs "tests/Prim/Prim3.hs" [ ("int2FloatTest", 1000, [AtLeast 1]) + , ("int2DoubleTest", 1000, [AtLeast 1]) ] - , checkInputOutput "tests/BaseTests/MaybeTest.hs" "MaybeTest" "sumN" 1000 4 [AtLeast 6] - , checkInputOutput "tests/BaseTests/MaybeTest.hs" "MaybeTest" "lengthN" 1000 5 [AtLeast 6] + , checkInputOutputs "tests/Prim/Prim4.hs" [ ("divIntTest", 1500, [AtLeast 4]) + , ("divIntegerTest", 1500, [AtLeast 1]) + , ("divIntegerTest2", 1500, [AtLeast 4]) + , ("divFloatTest", 1500, [AtLeast 1]) ] - , checkInputOutput "tests/BaseTests/Other.hs" "Other" "check4VeryEasy2" 600 1 [AtLeast 1] - ] + , checkInputOutputs "tests/Prim/DataTag.hs" [ ("dataToTag1", 1000, [Exactly 1]) + , ("dataToTag2", 1000, [AtLeast 1]) + , ("dataToTag3", 1000, [Exactly 5]) + , ("tagToEnum1", 1000, [AtLeast 1]) + , ("tagToEnum3", 1000, [AtLeast 4]) + , ("tagToEnum4", 1000, [AtLeast 4]) + , ("tagToEnum5", 1000, [Exactly 1]) + , ("tagToEnum6", 1000, [AtLeast 4]) ] -primTests :: IO TestTree -primTests = - return . testGroup "Prims" - =<< sequence [ - checkInputOutput "tests/Prim/Prim2.hs" "Prim2" "quotI1" 1000 3 [AtLeast 4] - , checkInputOutput "tests/Prim/Prim2.hs" "Prim2" "quotI2" 1000 3 [AtLeast 4] - , checkInputOutput "tests/Prim/Prim2.hs" "Prim2" "remI1" 1000 3 [AtLeast 4] - , checkInputOutput "tests/Prim/Prim2.hs" "Prim2" "remI2" 1000 3 [AtLeast 3] + , checkExpr "tests/Prim/DataTag.hs" 1000 "tagToEnum2" [Exactly 1, RForAll (\[r] -> isError r)] - , checkInputOutput "tests/Prim/Prim2.hs" "Prim2" "p1List" 300000 1 [AtLeast 1] - , checkInputOutput "tests/Prim/Prim2.hs" "Prim2" "p2List" 700000 1 [AtLeast 1] - , checkInputOutput "tests/Prim/Prim2.hs" "Prim2" "integerToFloatList" 150000 1 [AtLeast 1] + , checkInputOutputs "tests/Prim/Chr.hs" [ ("lowerLetters", 9000, [AtLeast 1]) + , ("allLetters", 20000, [AtLeast 1]) + , ("printBasedOnChr", 1500, [AtLeast 7]) + , ("printBasedOnOrd", 1500, [AtLeast 7]) ] + ] - , checkInputOutput "tests/Prim/Prim3.hs" "Prim3" "int2FloatTest" 1000 2 [AtLeast 1] - , checkInputOutput "tests/Prim/Prim3.hs" "Prim3" "int2DoubleTest" 1000 2 [AtLeast 1] - ] +ioTests :: TestTree +ioTests = testGroup "IO" + [ + checkInputOutput "tests/IO/UnsafePerformIO1.hs" "f" 1000 [Exactly 1] + ] -- To Do Tests -------------- -todoTests :: IO TestTree -todoTests = - return . testGroup "To Do" - =<< sequence [ - checkLiquid "tests/Liquid/TyApps.hs" "goodGet" 1000 4 [Exactly 0] - , checkLiquid "tests/Liquid/TyApps.hs" "getPosInt" 1000 4 - [ AtLeast 1 - , RForAll (\[_, _, (App _ x), y] -> getIntB x $ \x' -> getIntB y $ \y' -> x' == y' && y' == 10)] - , checkLiquid "tests/Liquid/TyApps.hs" "getPos" 1000 4 - [ AtLeast 1 - , RExists (\[_, _, (App _ x), y] -> getIntB x $ \x' -> getIntB y $ \y' -> x' == y' && y' == 10)] - , checkLiquid "tests/Liquid/FoldrTests.hs" "max2" 1000 2 [Exactly 0] - , checkLiquid "tests/Liquid/FoldrTests.hs" "max3" 1000 2 [Exactly 0] - , checkLiquid "tests/Liquid/SimpleAnnot.hs" "simpleF" 1000 1 [Exactly 0] - , checkLiquid "tests/Liquid/Ordering.hs" "lt" 1000 2 [AtLeast 1] - , checkLiquid "tests/Liquid/Ordering.hs" "gt" 1000 2 [AtLeast 1] - , checkLiquid "tests/Liquid/WhereFuncs2.hs" "hCalls" 1000 3 [AtLeast 1] - , checkLiquid "tests/Liquid/WhereFuncs2.hs" "i" 1000 2 [AtLeast 1] - , checkAbsLiquid "tests/Liquid/AddToEvenWhere.hs" "f" 2000 1 - [ AtLeast 1 - , RForAll (\[i] r [(FuncCall { funcName = Name n _ _ _, returns = r' }) ] - -> n == "g" && isInt i (\i' -> i' `mod` 2 == 0) && r == r' )] - , checkLiquid "tests/Liquid/ListTests.lhs" "concat" 1000 2 [AtLeast 3] - , checkLiquidWithConfig "tests/Liquid/MapReduceTest.lhs" "mapReduce" 2 (mkConfigTestWithMap {steps = 1500})[Exactly 0] - , checkLiquid "tests/Liquid/NearestTest.lhs" "nearest" 1500 1 [Exactly 1] - - , checkExpr "tests/TestFiles/TypeClass/TypeClass5.hs" 800 Nothing Nothing "run" 2 [AtLeast 1] - , checkExpr "tests/TestFiles/TypeClass/TypeClass5.hs" 800 Nothing Nothing "run2" 2 [AtLeast 0] - , checkInputOutput "tests/Prim/Prim2.hs" "Prim2" "sqrtList" 10000 1 [AtLeast 1] - - , checkInputOutput "tests/BaseTests/MaybeTest.hs" "MaybeTest" "average" 2000 5 [AtLeast 6] - , checkInputOutput "tests/BaseTests/MaybeTest.hs" "MaybeTest" "averageF" 2000 2 [AtLeast 6] - , checkInputOutput "tests/BaseTests/MaybeTest.hs" "MaybeTest" "maybeAvg" 200 4 [AtLeast 6] +todoTests :: TestTree +todoTests = testGroup "To Do" + [ + checkExpr "tests/TestFiles/TypeClass/TypeClass5.hs" 800 "run" [AtLeast 1] + , checkExpr "tests/TestFiles/TypeClass/TypeClass5.hs" 800 "run2" [AtLeast 0] + , checkInputOutput "tests/Prim/Prim2.hs" "sqrtList" 10000 [AtLeast 1] + + , checkInputOutputs "tests/BaseTests/MaybeTest.hs" [ ("average", 2000, [AtLeast 6]) + , ("averageF", 2000, [AtLeast 6]) + , ("maybeAvg", 200, [AtLeast 6]) + ] - , checkInputOutput "tests/Prim/Prim3.hs" "Prim3" "float2IntTest" 1000 2 [AtLeast 1] - , checkInputOutput "tests/Prim/Prim3.hs" "Prim3" "double2IntTest" 1000 2 [AtLeast 1] - ] + , checkInputOutputs "tests/Prim/Prim3.hs" [ ("float2IntTest", 1000, [AtLeast 1]) + , ("double2IntTest", 1000, [AtLeast 1])] + ] data ToDo = RunMain | RunToDo @@ -494,29 +487,106 @@ -- Generic helpers for tests ---------------------------- -checkExpr :: String -> Int -> Maybe String -> Maybe String -> String -> Int -> [Reqs ([Expr] -> Bool)] -> IO TestTree -checkExpr src stps m_assume m_assert entry i reqList = - checkExprReaches src stps m_assume m_assert Nothing entry i reqList +checkExpr :: String -> Int -> String -> [Reqs ([Expr] -> Bool)] -> TestTree +checkExpr src stps entry reqList = + checkExprReaches src stps Nothing Nothing Nothing entry reqList -checkExprReaches :: String -> Int -> Maybe String -> Maybe String -> Maybe String -> String -> Int -> [Reqs ([Expr] -> Bool)] -> IO TestTree -checkExprReaches src stps m_assume m_assert m_reaches entry i reqList = do - checkExprWithConfig src m_assume m_assert m_reaches entry i (mkConfigTest {steps = stps}) reqList +checkExprAssume :: String -> Int -> Maybe String -> String -> [Reqs ([Expr] -> Bool)] -> TestTree +checkExprAssume src stps m_assume entry reqList = + checkExprReaches src stps m_assume Nothing Nothing entry reqList -checkExprWithConfig :: String -> Maybe String -> Maybe String -> Maybe String -> String -> Int -> Config -> [Reqs ([Expr] -> Bool)] -> IO TestTree -checkExprWithConfig src m_assume m_assert m_reaches entry i config reqList = do - res <- testFile src m_assume m_assert m_reaches entry config - - let ch = case res of - Left _ -> False - Right exprs -> checkExprGen (map (\(inp, out) -> inp ++ [out]) exprs) i reqList +checkExprAssert :: String -> Int -> Maybe String -> String -> [Reqs ([Expr] -> Bool)] -> TestTree +checkExprAssert src stps m_assert entry reqList = + checkExprReaches src stps Nothing m_assert Nothing entry reqList - return . testCase src - $ assertBool ("Assume/Assert for file " ++ src ++ - " with functions [" ++ (fromMaybe "" m_assume) ++ "] " ++ - "[" ++ (fromMaybe "" m_assert) ++ "] " ++ - entry ++ " failed.\n") ch +checkExprAssumeAssert :: String + -> Int + -> Maybe String + -> Maybe String + -> String + -> [Reqs ([Expr] -> Bool)] + -> TestTree +checkExprAssumeAssert src stps m_assume m_assert entry reqList = + checkExprReaches src stps m_assume m_assert Nothing entry reqList + +checkExprReaches :: String + -> Int + -> Maybe String + -> Maybe String + -> Maybe String + -> String + -> [Reqs ([Expr] -> Bool)] + -> TestTree +checkExprReaches src stps m_assume m_assert m_reaches entry reqList = do + checkExprWithConfig src m_assume m_assert m_reaches entry reqList + (do + config <- mkConfigTestIO + return $ config {steps = stps}) + +checkExprWithMap :: String + -> Int + -> Maybe String + -> Maybe String + -> Maybe String + -> String + -> [Reqs ([Expr] -> Bool)] + -> TestTree +checkExprWithMap src stps m_assume m_assert m_reaches entry reqList = do + checkExprWithConfig src m_assume m_assert m_reaches entry reqList + (do + config <- mkConfigTestWithMapIO + return $ config {steps = stps}) + +checkExprWithSet :: String + -> Int + -> Maybe String + -> Maybe String + -> Maybe String + -> String + -> [Reqs ([Expr] -> Bool)] + -> TestTree +checkExprWithSet src stps m_assume m_assert m_reaches entry reqList = do + checkExprWithConfig src m_assume m_assert m_reaches entry reqList + (do + config <- mkConfigTestWithSetIO + return $ config {steps = stps}) + +checkExprWithConfig :: String + -> Maybe String + -> Maybe String + -> Maybe String + -> String + -> [Reqs ([Expr] -> Bool)] + -> IO Config + -> TestTree +checkExprWithConfig src m_assume m_assert m_reaches entry reqList config_f = do + testCase src (do + config <- config_f + res <- testFile src m_assume m_assert m_reaches entry config + + let ch = case res of + Left _ -> False + Right exprs -> null $ checkExprGen (map (\(inp, out) -> inp ++ [out]) exprs) reqList + assertBool ("Assume/Assert for file " ++ src + ++ " with functions [" ++ (fromMaybe "" m_assume) ++ "] " + ++ "[" ++ (fromMaybe "" m_assert) ++ "] " + ++ entry ++ " failed.\n" ++ show res) + ch + ) + + -- return . testCase src + -- $ assertBool ("Assume/Assert for file " ++ src ++ + -- " with functions [" ++ (fromMaybe "" m_assume) ++ "] " ++ + -- "[" ++ (fromMaybe "" m_assert) ++ "] " ++ + -- entry ++ " failed.\n") ch -testFile :: String -> Maybe String -> Maybe String -> Maybe String -> String -> Config -> IO (Either SomeException [([Expr], Expr)]) +testFile :: String + -> Maybe String + -> Maybe String + -> Maybe String + -> String + -> Config + -> IO (Either SomeException [([Expr], Expr)]) testFile src m_assume m_assert m_reaches entry config = try (testFileWithConfig src m_assume m_assert m_reaches entry config) @@ -529,73 +599,35 @@ -> IO [([Expr], Expr)] testFileWithConfig src m_assume m_assert m_reaches entry config = do let proj = takeDirectory src - r <- doTimeout (timeLimit config) $ runG2FromFile [proj] [src] [] (fmap T.pack m_assume) (fmap T.pack m_assert) (fmap T.pack m_reaches) (isJust m_assert || isJust m_reaches) (T.pack entry) config + r <- doTimeout (timeLimit config) + $ runG2FromFile + [proj] + [src] + (fmap T.pack m_assume) + (fmap T.pack m_assert) + (fmap T.pack m_reaches) + (isJust m_assert || isJust m_reaches) + (T.pack entry) + simplTranslationConfig + config let (states, _) = maybe (error "Timeout") fst r return $ map (\(ExecRes { conc_args = i, conc_out = o}) -> (i, o)) states -checkLiquidWithNoCutOff :: FilePath -> String -> Int -> Int -> [Reqs ([Expr] -> Bool)] -> IO TestTree -checkLiquidWithNoCutOff fp entry stps i reqList = - checkLiquidWithConfig fp entry i (mkConfigTest {steps = stps, cut_off = stps}) reqList - -checkLiquid :: FilePath -> String -> Int -> Int -> [Reqs ([Expr] -> Bool)] -> IO TestTree -checkLiquid fp entry stps i reqList = checkLiquidWithConfig fp entry i (mkConfigTest {steps = stps}) reqList - -checkLiquidWithCutOff :: FilePath -> String -> Int -> Int -> Int -> [Reqs ([Expr] -> Bool)] -> IO TestTree -checkLiquidWithCutOff fp entry stps co i reqList = checkLiquidWithConfig fp entry i (mkConfigTest {steps = stps, cut_off = co}) reqList - -checkLiquidWithConfig :: FilePath -> String -> Int -> Config -> [Reqs ([Expr] -> Bool)] -> IO TestTree -checkLiquidWithConfig fp entry i config reqList = do - res <- findCounterExamples' fp (T.pack entry) [] [] config - - let (ch, r) = case res of - Nothing -> (False, Right ()) - Just (Left e) -> (False, Left e) - Just (Right exprs) -> (checkExprGen - (map (\(ExecRes { conc_args = inp, conc_out = out}) - -> inp ++ [out]) exprs - ) i reqList, Right ()) - - return . testCase fp - $ assertBool ("Liquid test for file " ++ fp ++ - " with function " ++ entry ++ " failed.\n" ++ show r) ch - -checkAbsLiquid :: FilePath -> String -> Int -> Int -> [Reqs ([Expr] -> Expr -> [FuncCall] -> Bool)] -> IO TestTree -checkAbsLiquid fp entry stps i reqList = checkAbsLiquidWithConfig fp entry i (mkConfigTest {steps = stps}) reqList - -checkAbsLiquidWithConfig :: FilePath -> String -> Int -> Config -> [Reqs ([Expr] -> Expr -> [FuncCall] -> Bool)] -> IO TestTree -checkAbsLiquidWithConfig fp entry i config reqList = do - res <- findCounterExamples' fp (T.pack entry) [] [] config - - let (ch, r) = case res of - Nothing -> (False, Right []) - Just (Left e) -> (False, Left e) - Just (Right exprs) -> - let - te = checkAbsLHExprGen - (map (\(ExecRes { final_state = s, conc_args = inp, conc_out = out}) - -> (s, inp, out) - ) exprs - ) i reqList - in - (null te, Right te) - - return . testCase fp - $ assertBool ("Liquid test for file " ++ fp ++ - " with function " ++ entry ++ " failed.\n" ++ show r) ch - +-- For mergeState unit tests +checkFn :: Either String Bool -> String -> IO TestTree +checkFn f testName = do + let res = f + case res of + Left e -> return . testCase testName $ assertFailure e + Right _ -> return . testCase testName $ return () -findCounterExamples' :: FilePath - -> T.Text - -> [FilePath] - -> [FilePath] - -> Config - -> IO (Maybe (Either SomeException [ExecRes [FuncCall]])) -findCounterExamples' fp entry libs lhlibs config = - let - proj = takeDirectory fp - in - doTimeout (timeLimit config) $ try (return . fst. fst =<< findCounterExamples [proj] [fp] entry libs lhlibs config) +checkFnIO :: IO (Either String Bool) -> String -> IO TestTree +checkFnIO f testName = do + res <- f + case res of + Left e -> return . testCase testName $ assertFailure e + Right _ -> return . testCase testName $ return () errors :: [Expr] -> Bool errors e = diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs --- a/tests/TestUtils.hs +++ b/tests/TestUtils.hs @@ -6,23 +6,31 @@ import Data.Monoid import qualified Data.Text as T +import System.Directory + import G2.Config import G2.Language -mkConfigTest :: Config -mkConfigTest = (mkConfig "/whatever/" [] M.empty) - { higherOrderSolver = AllFuncs - , timeLimit = 50 - , baseInclude = [ "./base-4.9.1.0/Control/Exception/" - , "./base-4.9.1.0/" ] - , base = [ "./base-4.9.1.0/Control/Exception/Base.hs" - , "./base-4.9.1.0/Prelude.hs" ] - , extraDefaultMods = [] } +mkConfigTestIO :: IO Config +mkConfigTestIO = do + homedir <- getHomeDirectory + return $ + (mkConfigDirect homedir [] M.empty) + { higherOrderSolver = AllFuncs + , timeLimit = 150 + -- , baseInclude = [ "./base-4.9.1.0/Control/Exception/" + -- , "./base-4.9.1.0/" ] + , base = baseSimple homedir + , extraDefaultMods = [] } -mkConfigTestWithMap :: Config -mkConfigTestWithMap = - mkConfigTest { baseInclude = baseInclude mkConfigTest ++ ["./base-4.9.1.0/Data/Internal/"] - , base = base mkConfigTest ++ ["./base-4.9.1.0/Data/Internal/Map.hs"] } +mkConfigTestWithSetIO :: IO Config +mkConfigTestWithSetIO = mkConfigTestWithMapIO + +mkConfigTestWithMapIO :: IO Config +mkConfigTestWithMapIO = do + config <- mkConfigTestIO + homedir <- getHomeDirectory + return $ config { base = base config } eqIgT :: Expr -> Expr -> Bool diff --git a/tests/Typing.hs b/tests/Typing.hs --- a/tests/Typing.hs +++ b/tests/Typing.hs @@ -6,14 +6,13 @@ import G2.Language +import Data.Maybe (isNothing) + import Test.Tasty import Test.Tasty.HUnit -typingTests :: IO TestTree -typingTests = return typingTests' - -typingTests' :: TestTree -typingTests' = +typingTests :: TestTree +typingTests = testGroup "Typing" [ testCase "Function application" $ assertBool "Function application failed" test1 @@ -30,6 +29,7 @@ , testCase "Specializes false test 1" $ assertBool ".:: failed" specFalseTest1 , testCase "Specializes false test 2" $ assertBool ".:: failed" specFalseTest2 + , testCase "Specializes false test 3" $ assertBool ".:: failed" specFalseTest3 ] test1 :: Bool @@ -69,7 +69,7 @@ funcAppTest = typeOf (App (App idDef (Type int)) x1) == int funcTest :: Bool -funcTest = idDef .:: (TyForAll (NamedTyBndr aid) (TyFun a a)) +funcTest = idDef .:: (TyForAll aid (TyFun a a)) tyAppKindTest :: Bool tyAppKindTest = typeOf (TyApp either a) == TyFun TYPE TYPE @@ -89,6 +89,16 @@ specFalseTest2 :: Bool specFalseTest2 = not $ f3 .:: typeOf f2 +specFalseTest3 :: Bool +specFalseTest3 = + let + c = Id (Name "c" Nothing 0 Nothing) TYPE + + t1 = TyFun (TyVar aid) (TyVar bid) + t2 = TyFun (TyVar c) (TyVar c) + in + isNothing $ t1 `specializes` t2 + -- Typed Expr's x1 :: Expr x1 = Var $ Id (Name "x1" Nothing 0 Nothing) int @@ -99,16 +109,16 @@ f2 :: Expr f2 = Var $ Id (Name "f2" Nothing 0 Nothing) (TyForAll - (NamedTyBndr bid) + bid (TyFun b b) ) f3 :: Expr f3 = Var $ Id (Name "f3" Nothing 0 Nothing) (TyForAll - (NamedTyBndr bid) + bid (TyForAll - (NamedTyBndr aid) + aid (TyFun b a) ) ) @@ -117,7 +127,7 @@ just = Data $ DataCon (Name "Just" Nothing 0 Nothing) (TyForAll - (NamedTyBndr aid) + aid (TyFun a (TyApp maybe a)) ) diff --git a/tests/UFMapTests.hs b/tests/UFMapTests.hs new file mode 100644 --- /dev/null +++ b/tests/UFMapTests.hs @@ -0,0 +1,245 @@ +module UFMapTests where + +import G2.Data.UFMap + +import Data.Hashable +import qualified Data.List as L +import Data.Maybe as M + +import Test.Tasty +import Test.Tasty.QuickCheck + +import qualified Data.HashMap.Lazy as HM +import qualified Data.HashSet as S + +import Prelude hiding (lookup, map, null) +import qualified Prelude as P + +ufMapQuickcheck :: TestTree +ufMapQuickcheck = + testGroup "UFMap" [ + testProperty "from hashset to hashset" prop_from_hs_to_hs + , testProperty "insert forces in list" prop_insert_forces_in_list + , testProperty "after joining two keys, they will return the same result from lookup" join_makes_lookup_match + , testProperty "lookup j after joining nonpresent j with some k in the map" prop_lookup_after_joining + , testProperty "if two keys are joined in the first map, they are joined after merging that map" prop_merge_preserves_joins1 + , testProperty "if two keys are joined in the second map, they are joined after merging that map" prop_merge_preserves_joins2 + , testProperty "if a key is present in two maps being merged, in will be present in the merge" prop_merge_preserves_values + , testProperty "if a key is present in two maps being merged, in will be present in the merge (less thorough, but simpler)" prop_merge_preserves_values_simple + , testProperty "merge function is applied to all values from original map" prop_merge_merges_values + , testProperty "toList . fromList preserves joins" prop_toList_fromList_joins + , testProperty "toList . fromList preserves stored values" prop_toList_fromList_values + , testProperty "the toList function returns a list with at least as many elements as in the simple map" prop_toList_leq_simple_map + + , testProperty "the unionWith function correctly preserves elements in the first UFMaps" prop_unionWith_preserves_values1 + , testProperty "the unionWith function correctly preserves elements in the second UFMaps" prop_unionWith_preserves_values2 + ] + +prop_from_hs_to_hs :: [([Integer], Maybe Integer)] -> Property +prop_from_hs_to_hs xs = + let + xs_tails = L.init $ L.tails xs + xs' = [ (ks', v) | ((ks, v):xs_tls') <- xs_tails + , let later_ks = concat (P.map fst xs_tls') + , let ks' = P.filter (\k -> k `notElem` later_ks) ks ] + hs = toHS xs' + in + all (not . P.null . fst) xs' + ==> + property (hs == toSet (fromSet hs)) + +toHS :: (Hashable k, Eq k, Hashable v, Eq v) => [([k], Maybe v)] -> S.HashSet (S.HashSet k, Maybe v) +toHS = S.fromList . mapMaybe (\(ks, v) -> if isJust v + then Just (S.fromList ks, v) + else Nothing ) + +prop_insert_forces_in_list :: Integer -> Integer -> UFMap Integer Integer -> Property +prop_insert_forces_in_list k v ufm = + let + ufm' = insert k v ufm + lst = toList ufm' + in + property (any (\(ks, v') -> k `elem` ks + && case v' of + Just v'' -> v == v'' + Nothing -> False) lst) + +join_makes_lookup_match :: Fun (Integer, Integer) Integer -> Integer -> Integer -> UFMap Integer Integer -> Property +join_makes_lookup_match (Fn2 f) x y ufm = + let + ufm' = join f x y ufm + in + property (lookup x ufm' == lookup y ufm') + +prop_lookup_after_joining :: Integer -> UFMap Integer Integer -> Property +prop_lookup_after_joining j ufm = + let + ks = keys ufm + k = head ks + in + not (L.null ks) && j `notElem` ks + ==> + property $ lookup j (join undefined j k ufm) == lookup k ufm + +prop_merge_preserves_joins1 :: Integer + -> Integer + -> Fun (Integer, Integer) Integer + -> Fun (Integer, Integer, Integer) (Integer, [(Integer, Integer)]) + -> Fun (Integer, Integer) (Integer, [(Integer, Integer)]) + -> Fun (Integer, Integer) (Integer, [(Integer, Integer)]) + -> Fun (Integer, Integer) Integer + -> Fun (Integer, Integer) Integer + -> Fun (Integer, Integer) Integer + -> UFMap Integer Integer + -> UFMap Integer Integer + -> Property +prop_merge_preserves_joins1 x y (Fn2 jf) (Fn3 fb) (Fn2 f1) (Fn2 f2) (Fn2 fj1) (Fn2 fj2) (Fn2 j) ufm1 ufm2 = + let + ufm1' = join jf x y ufm1 + + m_ufm = mergeJoiningWithKey fb f1 f2 fj1 fj2 j ufm1' ufm2 + in + property (lookup x m_ufm == lookup y m_ufm) + +prop_merge_preserves_joins2 :: Integer + -> Integer + -> Fun (Integer, Integer) Integer + -> Fun (Integer, Integer, Integer) (Integer, [(Integer, Integer)]) + -> Fun (Integer, Integer) (Integer, [(Integer, Integer)]) + -> Fun (Integer, Integer) (Integer, [(Integer, Integer)]) + -> Fun (Integer, Integer) Integer + -> Fun (Integer, Integer) Integer + -> Fun (Integer, Integer) Integer + -> UFMap Integer Integer + -> UFMap Integer Integer + -> Property +prop_merge_preserves_joins2 x y (Fn2 jf) (Fn3 fb) (Fn2 f1) (Fn2 f2) (Fn2 fj1) (Fn2 fj2) (Fn2 j) ufm1 ufm2 = + let + ufm2' = join jf x y ufm2 + + m_ufm = mergeJoiningWithKey fb f1 f2 fj1 fj2 j ufm1 ufm2' + in + property (lookup x m_ufm == lookup y m_ufm) + +prop_merge_preserves_values :: Integer + -> Fun (Integer, Integer, Integer) (Integer, [(Integer, Integer)]) + -> Fun (Integer, Integer) (Integer, [(Integer, Integer)]) + -> Fun (Integer, Integer) (Integer, [(Integer, Integer)]) + -> Fun (Integer, Integer) Integer + -> Fun (Integer, Integer) Integer + -> Fun (Integer, Integer) Integer + -> UFMap Integer Integer + -> UFMap Integer Integer + -> Property +prop_merge_preserves_values x (Fn3 fb) (Fn2 f1) (Fn2 f2) (Fn2 fj1) (Fn2 fj2) (Fn2 j) ufm1 ufm2 = + let + m_ufm = mergeJoiningWithKey fb f1 f2 fj1 fj2 j ufm1 ufm2 + in + isJust (lookup x ufm1) || isJust (lookup x ufm2) + ==> + property (isJust (lookup x m_ufm)) + +prop_merge_preserves_values_simple :: Integer + -> Fun (Integer, Integer) (Integer, [(Integer, Integer)]) + -> UFMap Integer Integer + -> UFMap Integer Integer + -> Property +prop_merge_preserves_values_simple x (Fn2 f2) ufm1 ufm2 = + let + m_ufm = mergeJoiningWithKey (\_ x y -> (x + y, [])) (\_ x -> (x, [])) f2 (+) (+) (+) ufm1 ufm2 + in + isJust (lookup x ufm1) || isJust (lookup x ufm2) + ==> + property (isJust (lookup x m_ufm)) + +prop_merge_merges_values :: Integer + -> UFMap Integer (S.HashSet Integer) + -> UFMap Integer (S.HashSet Integer) + -> Property +prop_merge_merges_values x ufm1 ufm2 = + let + m_ufm = mergeJoiningWithKey (\_ x y -> (S.union x y, [])) + (\_ x -> (x, [])) + (\_ x -> (x, [])) + S.union + S.union + S.union + ufm1 ufm2 + s1 = case lookup x ufm1 of + Just s -> s + Nothing -> S.empty + s2 = case lookup x ufm2 of + Just s -> s + Nothing -> S.empty + in + not (S.null s1) || not (S.null s2) + ==> + property (s1 `isSubsetOf` (m_ufm ! x) && s2 `isSubsetOf` (m_ufm ! x)) + +isSubsetOf :: (Eq a, Hashable a) => S.HashSet a -> S.HashSet a -> Bool +isSubsetOf xs ys = all (\x -> x `S.member` ys) $ S.toList xs + +prop_toList_fromList_joins :: Integer + -> Integer + -> UFMap Integer (S.HashSet Integer) + -> Property +prop_toList_fromList_joins i1 i2 ufm = + let + ufm' = fromList . toList $ join S.union i1 i2 ufm + in + property $ find i1 ufm' == find i2 ufm' + +prop_toList_fromList_values :: Integer + -> S.HashSet Integer + -> UFMap Integer (S.HashSet Integer) + -> Property +prop_toList_fromList_values i hs ufm = + let + ufm' = fromList . toList $ insert i hs ufm + in + property $ lookup i ufm' == Just hs + +prop_toList_leq_simple_map :: [(Integer, S.HashSet Integer)] -> UFMap Integer (S.HashSet Integer) -> Property +prop_toList_leq_simple_map els ufm = + let + ufm' = foldr (uncurry insert) ufm els + in + property $ length (toList ufm') >= HM.size (toSimpleMap ufm') + +prop_unionWith_preserves_values1 :: Integer + -> UFMap Integer (S.HashSet Integer) + -> UFMap Integer (S.HashSet Integer) + -> Property +prop_unionWith_preserves_values1 x ufm1 ufm2 = + let + union = unionWith S.union ufm1 ufm2 + + s1 = case lookup x ufm1 of + Just s -> s + Nothing -> S.empty + s2 = case lookup x union of + Just s -> s + Nothing -> S.empty + in + not (S.null s1) || not (S.null s2) ==> property $ s1 `isSubsetOf` s2 + +prop_unionWith_preserves_values2 :: Integer + -> UFMap Integer (S.HashSet Integer) + -> UFMap Integer (S.HashSet Integer) + -> Property +prop_unionWith_preserves_values2 x ufm1 ufm2 = + let + union = unionWith S.union ufm1 ufm2 + + s1 = case lookup x ufm2 of + Just s -> s + Nothing -> S.empty + s2 = case lookup x union of + Just s -> s + Nothing -> S.empty + in + not (S.null s1) || not (S.null s2) ==> property $ s1 `isSubsetOf` s2 + +instance (Hashable a, Eq a, Arbitrary a) => Arbitrary (S.HashSet a) where + arbitrary = return . S.fromList =<< arbitrary + shrink = P.map S.fromList . shrink . S.toList diff --git a/tests/UnionFindTests.hs b/tests/UnionFindTests.hs new file mode 100644 --- /dev/null +++ b/tests/UnionFindTests.hs @@ -0,0 +1,41 @@ +module UnionFindTests where + +import G2.Data.UnionFind + +import Test.Tasty +import Test.Tasty.QuickCheck + +import Prelude hiding (lookup, map, null) + +unionFindQuickcheck :: TestTree +unionFindQuickcheck = + testGroup "UnionFind" [ + testProperty "applyinf unionOfUfs preserves unions in the first UnionFind" prop_unionOfUFs_preserves_unions1 + , testProperty "applyinf unionOfUfs preserves unions in the second UnionFind" prop_unionOfUFs_preserves_unions2 + , testProperty "applyinf unionOfUfs creates new unions" prop_unionOfUFs_preserves_unions3 + ] + +prop_unionOfUFs_preserves_unions1 :: Integer -> Integer -> UnionFind Integer -> UnionFind Integer -> Property +prop_unionOfUFs_preserves_unions1 x y uf1 uf2 = + let + uf1' = union x y uf1 + m_uf = unionOfUFs uf1' uf2 + in + property (find x m_uf == find y m_uf) + +prop_unionOfUFs_preserves_unions2 :: Integer -> Integer -> UnionFind Integer -> UnionFind Integer -> Property +prop_unionOfUFs_preserves_unions2 x y uf1 uf2 = + let + uf2' = union x y uf2 + m_uf = unionOfUFs uf1 uf2' + in + property (find x m_uf == find y m_uf) + +prop_unionOfUFs_preserves_unions3 :: Integer -> Integer -> Integer -> UnionFind Integer -> UnionFind Integer -> Property +prop_unionOfUFs_preserves_unions3 x y z uf1 uf2 = + let + uf1' = union x y uf1 + uf2' = union y z uf2 + m_uf = unionOfUFs uf1' uf2' + in + property (find x m_uf == find z m_uf) diff --git a/tests_lh/LHTest.hs b/tests_lh/LHTest.hs new file mode 100644 --- /dev/null +++ b/tests_lh/LHTest.hs @@ -0,0 +1,590 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Test.Tasty +import Test.Tasty.HUnit + +import GetNthTest +import PeanoTest +import LHReqs +import TestUtils +import UnionPoly + +import G2.Config as G2 +import G2.Interface +import G2.Language +import G2.Liquid.Config +import G2.Liquid.Helpers +import G2.Liquid.Interface +import G2.Liquid.Inference.Interface +import G2.Liquid.Inference.Config +import G2.Liquid.Inference.G2Calls +import G2.Translation + +import Control.Exception +import Data.Time.Clock +import Data.Either +import qualified Data.Map.Lazy as M +import qualified Data.Text as T +import System.FilePath + +import G2.Liquid.Types +import qualified System.IO as T + + +import Language.Haskell.Liquid.UX.CmdLine hiding (config) + +-- Run with no arguments for default test cases. +-- All default test cases should pass. +-- Run with flag '--test-options="todo yes"' to run test cases corresponding to to-be-fixed bugs. +main :: IO () +main = do + defaultMainWithIngredients + defaultIngredients + tests + +tests :: TestTree +tests = testGroup "All Tests" + [ liquidTests + , posInfTests + , negInfTests + , cexInfTests + + , unionPolyTests ] + +liquidTests :: TestTree +liquidTests = testGroup "Liquid" + [ + checkLiquids "tests_lh/Liquid/SimpleMath.hs" + [ ("abs2", 2000, [RForAll (\[x, y] -> isDouble x ((==) 0) && isDouble y ((==) 0)), Exactly 1]) + , ("add", 800, [RForAll (\[x, y, z] -> isInt x $ \x' -> isInt y $ \y' -> isInt z $ \z' -> x' > z' || y' > z'), AtLeast 1]) + , ("subToPos", 1000, [ RForAll (\[x, y, z] -> isInt x $ \x' -> isInt y $ \y' -> isInt z $ \z' -> x' > 0 && x' >= y' && z' <= 0), AtLeast 1])] + , checkLiquidWithNoCutOff "tests_lh/Liquid/SimpleMath.hs" + [ ("fib", 4000, [RForAll (\[x, y] -> isInt x $ \x' -> isInt y $ \y' -> x' > y'), AtLeast 3]) + , ("fib'", 6000, [RForAll (\[x, y] -> isInt x $ \x' -> isInt y $ \y' -> x' > y'), AtLeast 3]) + , ("xSqPlusYSq", 1000 , [RForAll (\[x, y, z] -> isInt x $ \x' -> isInt y $ \y' -> isInt z $ \z' -> x' + y' >= z'), AtLeast 1]) + ] + + , checkLiquids "tests_lh/Liquid/SimplePoly.hs" + [ ("snd2Int", 800, [ RForAll (\[x, y, z] -> isInt x $ \x' -> isInt y $ \y' -> isInt z $ \z' -> x' /= y' && y' == z'), Exactly 1]) + , ("sumPair", 800, [ AtLeast 1, RForAll (\[App (App _ x) y, z] -> isInt x $ \x' -> isInt y $ \y' -> isInt z $ \z' -> x' > z' || y' > z')]) + , ("switchInt", 600, [ Exactly 1, RForAll (\[App (App _ x) _, App (App _ _) y] -> getIntB x $ \ x' -> getIntB y $ \ y' -> x' == y')]) ] + + , checkLiquids "tests_lh/Liquid/Peano.hs" + [ ("add", 1400, [RForAll (\[x, y, _] -> x `eqIgT` zeroPeano || y `eqIgT` zeroPeano), AtLeast 5]) + , ("fromInt", 600, [RForAll (\[x, y] -> isInt x (\x' -> x' == 0) && y `eqIgT` zeroPeano), AtLeast 1]) + ] + + , checkLiquidWithNoCutOff "tests_lh/Liquid/GetNth.hs" + [ ("getNthInt", 2700, [AtLeast 3, RForAll getNthErrors]) + , ("getNth", 2700, [AtLeast 3]) ] + , checkLiquidWithCutOff "tests_lh/Liquid/GetNth.hs" "sumC" 2000000 1000 + [AtLeast 3, RForAll (\[_, y] -> isInt y $ (==) 0)] + , checkLiquidWithCutOff "tests_lh/Liquid/GetNth.hs" "sumCList" 2000000 1000 [AtLeast 3] + + , checkLiquids "tests_lh/Liquid/DataRefTest.hs" + [ ("addMaybe", 1000, [AtLeast 1, RForAll (\[_, y, z] -> isInt y $ \y' -> appNthArgIs z (\z' -> isInt z' $ \z'' -> z'' <= y') 2)]) + , ("addMaybe2", 2000, [ AtLeast 1, RForAll (\[x, _, _] -> appNthArgIs x (\x' -> isInt x' $ \x'' -> x'' >= 0) 2) + , RForAll (\[_, y, z] -> isInt y $ \y' -> appNthArgIs z (\z' -> isInt z' $ \z'' -> z'' <= y') 2)]) + , ("getLeftInts", 2000, [AtLeast 1, RForAll (\[x, _] -> dcInAppHasName "Right" x 3)]) + , ("sumSameInts", 2000, [AtLeast 1, RForAll (\[x, y, _] -> dcInAppHasName "Right" x 3 && dcInAppHasName "Left" y 3)]) + , ("sub1", 1200, [AtLeast 1]) ] + + , checkLiquid "tests_lh/Liquid/NumOrd.hs" "subTuple" 1200 [AtLeast 1] + + , checkLiquids "tests_lh/Liquid/CommentMeasures.hs" + [ ("d", 1000, [AtLeast 1]) + , ("unpackCP'", 100000, [Exactly 0]) + , ("unpackBool", 1000, [AtLeast 1, RForAll (\[_, r] -> getBoolB r (== False))]) + , ("sumSameOneOfs", 100000, [Exactly 0]) + , ("gets2As", 2000, [AtLeast 1, RExists (\[x, y, _] -> buriedDCName "B" x && buriedDCName "B" y)]) + , ("gets2As'", 1000, [AtLeast 1, RExists (\[x, y, _] -> buriedDCName "A" x && buriedDCName "B" y) + , RExists (\[x, y, _] -> buriedDCName "B" x && buriedDCName "A" y)]) + , ("ge4gt5", 1000, [AtLeast 1, RForAll (\[x, y] -> appNth x 1 $ \x' -> isInt x' $ \x'' -> isInt y $ \y' -> x'' == 4 && y' == 5)]) + ] + + , checkLiquids "tests_lh/Liquid/ConcatList.hs" + [ ("concat2", 800, [AtLeast 2]) + , ("concat3", 800, [AtLeast 2]) + , ("concat5", 1600, [AtLeast 1])] + + , checkLiquid "tests_lh/Liquid/Tests/Group3.lhs" "f" 2200 [AtLeast 1] + + , checkLiquid "tests_lh/Liquid/Nonused.hs" "g" 2000 [AtLeast 1] + + -- , checkLiquid "tests_lh/Liquid/HigherOrderRef.hs" "f1" 2000 [Exactly 0] + -- , checkLiquid "tests_lh/Liquid/HigherOrderRef.hs" "f2" 2000 [AtLeast 4, RForAll (\[_, x, y] -> x == y)] + -- , checkLiquid "tests_lh/Liquid/HigherOrderRef.hs" "f3" 2000 [Exactly 0] + -- , checkLiquid "tests_lh/Liquid/HigherOrderRef.hs" "f4" 2000 + -- [AtLeast 4, RForAll (\[_, x, _] -> isInt x $ \x' -> x' == 0)] + -- , checkLiquid "tests_lh/Liquid/HigherOrderRef.hs" "f5" 2000 [Exactly 0] + -- , checkLiquid "tests_lh/Liquid/HigherOrderRef.hs" "f6" 2000 [AtLeast 10] + -- , checkLiquid "tests_lh/Liquid/HigherOrderRef.hs" "f7" 2000 + -- [AtLeast 10, RForAll (\[x, _, y] -> isInt x $ \x' -> isInt y $ \y' -> x' == y')] + -- , checkLiquid "tests_lh/Liquid/HigherOrderRef.hs" "f8" 2000 [AtLeast 10] + -- , checkLiquid "tests_lh/Liquid/HigherOrderRef.hs" "callf" 2000 [AtLeast 1] + + -- , checkLiquid "tests_lh/Liquid/Error/Error1.hs" "f" 600 [AtLeast 1] + , checkLiquid "tests_lh/Liquid/Error/Error2.hs" "f1" 2000 [AtLeast 1] + , checkLiquid "tests_lh/Liquid/ZipWith.lhs" "distance" 1000 [AtLeast 3] + + , checkLiquids "tests_lh/Liquid/HigherOrder2.hs" + [ ("f", 2000, [Exactly 0]) + , ("h", 2000, [AtLeast 1])] + , checkLiquid "tests_lh/Liquid/HigherOrder3.hs" "m" 600 [AtLeast 1] + + , checkLiquid "tests_lh/Liquid/Ordering.hs" "oneOrOther" 1000 [Exactly 0] + + , checkLiquid "tests_lh/Liquid/AddKV.lhs" "empty" 1000 [Exactly 0] + + , checkLiquid "tests_lh/Liquid/PropSize.hs" "prop_size" 2000 [AtLeast 1] + , checkLiquid "tests_lh/Liquid/PropSize2.hs" "prop_size" 2000 [AtLeast 1] + + , checkLiquids "tests_lh/Liquid/WhereFuncs.lhs" [ ("f", 1000, [Exactly 0]) + , ("g", 1000, [Exactly 0])] + + , checkLiquid "tests_lh/Liquid/PropConcat.lhs" "prop_concat" 1000 [AtLeast 1] + + , checkLiquid "tests_lh/Liquid/Distance.lhs" "distance" 1000 [AtLeast 1] + + -- The below test generates a LiquidHaskell error with newer LiquidHaskell versions + -- , checkLiquid "tests_lh/Liquid/MultModules/CallZ.lhs" "callZ" 1000 [AtLeast 1] + + , checkAbsLiquid "tests_lh/Liquid/AddToEven.hs" "f" 2500 + [ AtLeast 1 + , RForAll $ \[i] r [(FuncCall { funcName = Name n _ _ _, returns = fcr }) ] + -> n == "g" + && isInt i (\i' -> i' `mod` 2 == 0 && + isInt r (\r' -> isInt fcr (\fcr' -> r' == i' + fcr')))] + , checkAbsLiquid "tests_lh/Liquid/AddToEven4.hs" "f" 2000 [ AtLeast 1] + + , checkAbsLiquid "tests_lh/Liquid/Concat.hs" "prop_concat" 1000 [ AtLeast 1] + + , checkLiquids "tests_lh/Liquid/ListTests.lhs" + [ ("r", 1000, [Exactly 0]) + , ("prop_map", 1500, [AtLeast 3]) + , ("prop_concat_1", 1500, [AtLeast 1]) + ] + , checkAbsLiquid "tests_lh/Liquid/ListTests2.lhs" "prop_map" 2000 + [ AtLeast 2 + , RForAll (\_ _ [(FuncCall { funcName = Name n _ _ _ }) ] -> n == "map") ] + , checkAbsLiquid "tests_lh/Liquid/ListTests2.lhs" "prop_size" 2000 + [ AtLeast 1 + , RForAll (\[] _ [(FuncCall { funcName = Name n _ _ _, returns = r }) ] + -> n == "length2" && getIntB r (/= 3)) ] + + , checkLiquid "tests_lh/Liquid/MapReduceTest2.lhs" "mapReduce" 1500 [AtLeast 1] + + -- The below test generates a LiquidHaskell error with LiquidHaskell 8.2.2 version + -- , checkLiquid "tests_lh/Liquid/MeasErr.hs" "f" 1500 [Exactly 0] + + , checkAbsLiquid "tests_lh/Liquid/PropRep.hs" "prop_rep" 2000 + [ AtLeast 1 ] + + , checkAbsLiquid "tests_lh/Liquid/Replicate.hs" "replicate" 2000 + [ AtLeast 1 + , RExists (\_ _ [(FuncCall { funcName = Name n _ _ _ }) ] -> n == "foldl") ] + , checkAbsLiquid "tests_lh/Liquid/Replicate.hs" "r" 2000 + [ AtLeast 1 + , RExists (\_ _ [(FuncCall { funcName = Name n _ _ _ }) ] -> n == "foldl") ] + + , checkAbsLiquid "tests_lh/Liquid/AbsTypeClass.hs" "callF" 1000 + [ AtLeast 1 + , RExists (\_ _ [(FuncCall { funcName = Name n _ _ _ }) ] -> n == "f") ] + , checkAbsLiquid "tests_lh/Liquid/AbsTypeClassVerified.hs" "callF" 10000 [ Exactly 0 ] + + , checkLiquid "tests_lh/Liquid/Tree.hs" "sumPosTree" 1000 [AtLeast 1] + , checkLiquid "tests_lh/Liquid/Error4.hs" "extractRights" 1000 [AtLeast 1] + , checkLiquid "tests_lh/Liquid/PostFalse.hs" "f" 2000 [AtLeast 1] + + , checkLiquid "tests_lh/Liquid/TypeSym.hs" "f" 500 [] + + , checkLiquid "tests_lh/Liquid/CorrectDict.hs" "f" 2000 [AtLeast 1] + + , checkAbsLiquid "tests_lh/Liquid/ZipWith3.hs" "prop_zipWith" 400 [ AtLeast 3] + + , checkAbsLiquid "tests_lh/Liquid/Length.hs" "prop_size" 1000 + [ AtLeast 1 + , RForAll (\_ _ [ _ ] -> True)] + + , checkLiquidWithConfig "tests_lh/Liquid/NestedLength.hs" [("nested", 1000, [AtLeast 1])] + mkConfigTestIO + (return $ (mkLHConfigDirect [] M.empty) { add_tyvars = True }) + , checkLiquidWithConfig "tests_lh/Liquid/AddTyVars.hs" + [ ("f", 400, [AtLeast 1]) + , ("g", 400, [AtLeast 1]) + , ("h", 400, [AtLeast 1])] + mkConfigTestIO + (return $ (mkLHConfigDirect [] M.empty) { add_tyvars = True }) + + , checkLiquid "tests_lh/Liquid/Polymorphism/Poly1.hs" "f" 1000 [Exactly 0] + , checkLiquid "tests_lh/Liquid/Polymorphism/Poly2.hs" "f" 600 [Exactly 0] + + , checkLiquid "tests_lh/Liquid/Sets/Sets1.hs" "prop_union_assoc" 2000 [AtLeast 2] + , checkLiquid "tests_lh/Liquid/Sets/Sets1.hs" "prop_intersection_comm" 1000 [AtLeast 5] + , checkLiquid "tests_lh/Liquid/Sets/Sets2.hs" "badIdList" 1000 [AtLeast 1] + , checkLiquid "tests_lh/Liquid/Sets/Sets2.hs" "append" 1000 [AtLeast 1] + , checkLiquid "tests_lh/Liquid/Sets/Sets3.hs" "filter" 1800 [AtLeast 1] + , checkLiquid "tests_lh/Liquid/Sets/Sets4.hs" "isin" 1000 [AtLeast 1] + , checkLiquid "tests_lh/Liquid/Sets/Sets5.hs" "f" 1000 [AtLeast 1] + , checkLiquid "tests_lh/Liquid/Sets/Sets6.hs" "f" 2000 [AtLeast 1] + , checkLiquid "tests_lh/Liquid/Sets/Sets7.hs" "insertSort" 3000 [AtLeast 1] + + -- Higher Order Functions + , checkLiquid "tests_lh/Liquid/HigherOrder/IntFuncArg.hs" "caller" 1000 [AtLeast 1] + , checkLiquid "tests_lh/Liquid/HigherOrder/HigherOrderPre.hs" "test" 1000 [AtLeast 1] + , checkLiquid "tests_lh/Liquid/HigherOrder/HigherOrder2.hs" "f" 2000 [Exactly 0] + + -- IO + , checkLiquid "tests_lh/Liquid/IO/IO1.hs" "f" 1000 [Exactly 0] + , checkLiquid "tests_lh/Liquid/IO/IO2.hs" "f" 1000 [AtLeast 1] + , checkLiquid "tests_lh/Liquid/IO/IO3.hs" "f" 1400 [AtLeast 1] + + -- Abstract counterexamples + , checkAbsLiquid "tests_lh/Liquid/Polymorphism/Poly3.hs" "f" 800 + [ AtLeast 4 + , RForAll (\_ _ [ FuncCall { funcName = Name n _ _ _} ] -> n == "fil")] + , checkLiquid "tests_lh/Liquid/Polymorphism/Poly4.hs" "f" 600 [Exactly 0] + , checkAbsLiquid "tests_lh/Liquid/Polymorphism/Poly5.hs" "call" 600 [AtLeast 1] + , checkAbsLiquid "tests_lh/Liquid/Polymorphism/Poly6.hs" "f" 1000 + [ AtLeast 1 + , RForAll (\_ _ [ FuncCall { returns = r } ] -> + case r of { Prim Undefined _-> False; _ -> True}) + ] + , checkAbsLiquid "tests_lh/Liquid/Polymorphism/Poly7.hs" "prop_f" 2000 [AtLeast 1] + , checkAbsLiquid "tests_lh/Liquid/Polymorphism/Poly8.hs" "prop" 2000 + [ AtLeast 1 + , RForAll (\_ _ [ FuncCall { funcName = Name n _ _ _ } ] -> n == "func")] + , checkAbsLiquid "tests_lh/Liquid/Polymorphism/Poly9.hs" "prop" 2000 + [ AtLeast 1 + , RForAll (\_ _ [ FuncCall { funcName = Name n _ _ _ } ] -> n == "func")] + , checkAbsLiquid "tests_lh/Liquid/Polymorphism/Poly10.hs" "prop" 2000 + [ AtLeast 1 ] + , checkAbsLiquid "tests_lh/Liquid/Polymorphism/Poly11.hs" "call" 700 + [ AtLeast 1 + , RForAll (\_ _ [ FuncCall { funcName = Name n _ _ _ } ] -> n == "higher")] + , checkAbsLiquid "tests_lh/Liquid/Polymorphism/Poly12.hs" "prop" 3000 + [ AtLeast 1 + , RForAll (\_ _ [ FuncCall { funcName = Name n _ _ _ } ] -> n == "map")] + , checkAbsLiquid "tests_lh/Liquid/Polymorphism/Poly13.hs" "call" 1000 + [ AtLeast 1 + , RForAll (\_ _ [ FuncCall { funcName = Name n _ _ _ } ] -> n == "f")] + , checkAbsLiquid "tests_lh/Liquid/Polymorphism/Poly14.hs" "initCall" 1000 [ AtLeast 1] + , checkAbsLiquid "tests_lh/Liquid/Polymorphism/Poly15.hs" "call" 1000 [ AtLeast 1] + , checkAbsLiquid "tests_lh/Liquid/Polymorphism/Poly16.hs" "call" 1000 + [ AtLeast 1 + , RForAll (\ _ _ [ FuncCall { arguments = [_, _, ar] } ] -> case ar of Prim _ _ -> False; _ -> True )] + , checkAbsLiquid "tests_lh/Liquid/Polymorphism/Poly17.hs" "empty2" 1000 [ AtLeast 1] + , checkAbsLiquid "tests_lh/Liquid/Polymorphism/Poly18.hs" "f" 500 [ AtLeast 1] + ] + +posInfTests :: TestTree +posInfTests = testGroup "Tests" + [ posTestInference "tests_lh/test_files/Pos/HigherOrder.hs" + , posTestInference "tests_lh/test_files/Pos/HigherOrder2.hs" + -- , posTestInferenceWithTimeOut 240 5 "tests_lh/test_files/Pos/HigherOrder3.hs" + -- , posTestInference "tests_lh/test_files/Pos/HigherOrder4.hs" + + , posTestInference "tests_lh/test_files/Pos/Test1.hs" + , posTestInference "tests_lh/test_files/Pos/Test2.hs" + , posTestInference "tests_lh/test_files/Pos/Test3.hs" + , posTestInference "tests_lh/test_files/Pos/Test4.hs" + , posTestInference "tests_lh/test_files/Pos/Test5.hs" + , posTestInference "tests_lh/test_files/Pos/Test6.hs" + , posTestInference "tests_lh/test_files/Pos/Test7.hs" + , posTestInference "tests_lh/test_files/Pos/Test8.hs" + , posTestInference "tests_lh/test_files/Pos/Test9.hs" + , posTestInference "tests_lh/test_files/Pos/Test10.hs" + , posTestInference "tests_lh/test_files/Pos/Test11.hs" + , posTestInference "tests_lh/test_files/Pos/Test12.hs" + , posTestInference "tests_lh/test_files/Pos/Test13.hs" + , posTestInference "tests_lh/test_files/Pos/Test14.hs" + , posTestInference "tests_lh/test_files/Pos/Test15.hs" + , posTestInference "tests_lh/test_files/Pos/Test16.hs" + , posTestInference "tests_lh/test_files/Pos/Test17.hs" + , posTestInference "tests_lh/test_files/Pos/Test18.hs" + , posTestInference "tests_lh/test_files/Pos/Test19.hs" + , posTestInference "tests_lh/test_files/Pos/Test20.hs" + , posTestInference "tests_lh/test_files/Pos/Test21.hs" + , posTestInference "tests_lh/test_files/Pos/Test22.hs" + -- , posTestInference "tests_lh/test_files/Pos/Test23.hs" + , posTestInference "tests_lh/test_files/Pos/Test24.hs" + , posTestInference "tests_lh/test_files/Pos/Test25.hs" + , posTestInference "tests_lh/test_files/Pos/Test26.hs" + , posTestInference "tests_lh/test_files/Pos/Test27.hs" + , posTestInference "tests_lh/test_files/Pos/Test28.hs" + , posTestInference "tests_lh/test_files/Pos/Test29.hs" + , posTestInference "tests_lh/test_files/Pos/Test30.hs" + , posTestInference "tests_lh/test_files/Pos/Test31.hs" + , posTestInference "tests_lh/test_files/Pos/Test32.hs" + , posTestInference "tests_lh/test_files/Pos/Test33.hs" + , posTestInference "tests_lh/test_files/Pos/Test34.hs" + , posTestInference "tests_lh/test_files/Pos/Test35.hs" + , posTestInference "tests_lh/test_files/Pos/Test36.hs" + , posTestInference "tests_lh/test_files/Pos/Test37.hs" + -- , posTestInferenceWithTimeOut 240 15 "tests_lh/test_files/Pos/Test38.hs" + , posTestInference "tests_lh/test_files/Pos/Test39.hs" + , posTestInference "tests_lh/test_files/Pos/Test40.hs" + , posTestInference "tests_lh/test_files/Pos/Test41.hs" + , posTestInference "tests_lh/test_files/Pos/Test42.hs" + , posTestInference "tests_lh/test_files/Pos/Test43.hs" + , posTestInference "tests_lh/test_files/Pos/Test44.hs" + , posTestInference "tests_lh/test_files/Pos/Test45.hs" + , posTestInference "tests_lh/test_files/Pos/Test46.hs" + , posTestInference "tests_lh/test_files/Pos/Test47.hs" + , posTestInference "tests_lh/test_files/Pos/Test48.hs" + , posTestInference "tests_lh/test_files/Pos/Test49.hs" + , posTestInference "tests_lh/test_files/Pos/Test50.hs" + + , posTestInference "tests_lh/test_files/Pos/Sets1.hs" + , posTestInference "tests_lh/test_files/Pos/Sets2.hs" + , posTestInference "tests_lh/test_files/Pos/Sets3.hs" + , posTestInference "tests_lh/test_files/Pos/Sets4.hs" + , posTestInference "tests_lh/test_files/Pos/Sets5.hs" + , posTestInference "tests_lh/test_files/Pos/Sets6.hs" + , posTestInference "tests_lh/test_files/Pos/Sets7.hs" + , posTestInference "tests_lh/test_files/Pos/Sets8.hs" + , posTestInference "tests_lh/test_files/Pos/Sets9.hs" + -- , posTestInference "tests_lh/test_files/Pos/Sets10.hs" + + , posTestInference "tests_lh/test_files/Pos/MeasComp1.hs" + , posTestInference "tests_lh/test_files/Pos/MeasComp2.hs" + , posTestInference "tests_lh/test_files/Pos/MeasComp3.hs" ] + +negInfTests :: TestTree +negInfTests = testGroup "Tests" + [ negTestInference "tests_lh/test_files/Neg/Test1.hs" + , negTestInference "tests_lh/test_files/Neg/Test2.hs" + , negTestInference "tests_lh/test_files/Neg/Test3.hs" + , negTestInference "tests_lh/test_files/Neg/Test4.hs" + , negTestInference "tests_lh/test_files/Neg/Test5.hs" + , negTestInference "tests_lh/test_files/Neg/Test6.hs" ] + +cexInfTests :: TestTree +cexInfTests = testGroup "Tests" + [ cexTest "tests_lh/test_files/CEx/CEx1.hs" "zipWith" + , cexTest "tests_lh/test_files/CEx/CEx2.hs" "mapReduce" + , cexTest "tests_lh/test_files/CEx/CEx3.hs" "kmeans1" ] + +todoTests :: TestTree +todoTests = testGroup "To Do" + [ + checkLiquid "tests_lh/Liquid/TyApps.hs" "goodGet" 1000 [Exactly 0] + , checkLiquid "tests_lh/Liquid/TyApps.hs" "getPosInt" 1000 + [ AtLeast 1 + , RForAll (\[_, _, (App _ x), y] -> getIntB x $ \x' -> getIntB y $ \y' -> x' == y' && y' == 10)] + , checkLiquid "tests_lh/Liquid/TyApps.hs" "getPos" 1000 + [ AtLeast 1 + , RExists (\[_, _, (App _ x), y] -> getIntB x $ \x' -> getIntB y $ \y' -> x' == y' && y' == 10)] + , checkLiquid "tests_lh/Liquid/FoldrTests.hs" "max2" 1000 [Exactly 0] + , checkLiquid "tests_lh/Liquid/FoldrTests.hs" "max3" 1000 [Exactly 0] + , checkLiquid "tests_lh/Liquid/SimpleAnnot.hs" "simpleF" 1000 [Exactly 0] + , checkLiquid "tests_lh/Liquid/Ordering.hs" "lt" 1000 [AtLeast 1] + , checkLiquid "tests_lh/Liquid/Ordering.hs" "gt" 1000 [AtLeast 1] + , checkLiquid "tests_lh/Liquid/WhereFuncs2.hs" "hCalls" 1000 [AtLeast 1] + , checkLiquid "tests_lh/Liquid/WhereFuncs2.hs" "i" 1000 [AtLeast 1] + , checkAbsLiquid "tests_lh/Liquid/AddToEvenWhere.hs" "f" 2000 + [ AtLeast 1 + , RForAll (\[i] r [(FuncCall { funcName = Name n _ _ _, returns = r' }) ] + -> n == "g" && isInt i (\i' -> i' `mod` 2 == 0) && r == r' )] + , checkLiquid "tests_lh/Liquid/ListTests.lhs" "concat" 1000 [AtLeast 3] + , checkLiquid "tests_lh/Liquid/MapReduceTest.lhs" "mapReduce" 1500 + [Exactly 0] + , checkLiquid "tests_lh/Liquid/NearestTest.lhs" "nearest" 1500 [Exactly 1] + + , checkAbsLiquid "tests_lh/Liquid/ListTests2.lhs" "replicate" 2000 + [ AtLeast 3 + , RForAll (\[_, nA, aA] _ [(FuncCall { funcName = Name n _ _ _, arguments = [_, _, nA', aA'] }) ] + -> n == "replicate" && nA == nA' && aA == aA') ] + ] +------------------------------------------------- +-- CEx Gen tests +------------------------------------------------- + +checkLiquidWithNoCutOff :: FilePath -> [(String, Int, [Reqs ([Expr] -> Bool)])] -> TestTree +checkLiquidWithNoCutOff fp tests = do + let lhconfig = mkLHConfigDirect [] M.empty + checkLiquidWithConfig fp tests + mkConfigTestIO + (return lhconfig { cut_off = maximum $ map (\(_, stps, _) -> stps) tests }) + +checkLiquid :: FilePath -> String -> Int -> [Reqs ([Expr] -> Bool)] -> TestTree +checkLiquid fp entry stps req = do + let lhconfig = mkLHConfigDirect [] M.empty + checkLiquidWithConfig fp [(entry, stps, req)] + mkConfigTestIO + (return lhconfig) + +checkLiquids :: FilePath -> [(String, Int, [Reqs ([Expr] -> Bool)])] -> TestTree +checkLiquids fp tests = do + let lhconfig = mkLHConfigDirect [] M.empty + checkLiquidWithConfig fp tests + mkConfigTestIO + (return lhconfig) + + +checkLiquidWithSet :: FilePath -> [(String, Int, [Reqs ([Expr] -> Bool)])] -> TestTree +checkLiquidWithSet fp tests = do + let lhconfig = mkLHConfigDirect [] M.empty + checkLiquidWithConfig fp tests + mkConfigTestWithSetIO + (return lhconfig) + +checkLiquidWithCutOff :: FilePath -> String -> Int -> Int -> [Reqs ([Expr] -> Bool)] -> TestTree +checkLiquidWithCutOff fp entry stps co reqList = do + let lhconfig = mkLHConfigDirect [] M.empty + checkLiquidWithConfig fp [(entry, stps, reqList)] + mkConfigTestIO + (return lhconfig { cut_off = co }) + +checkLiquidWithMap :: FilePath -> [(String, Int, [Reqs ([Expr] -> Bool)])] -> TestTree +checkLiquidWithMap fp tests = do + let lhconfig = mkLHConfigDirect [] M.empty + checkLiquidWithConfig fp tests + mkConfigTestWithMapIO + (return lhconfig) + +checkLiquidWithConfig :: FilePath -> [(String, Int, [Reqs ([Expr] -> Bool)])] -> IO Config -> IO LHConfig -> TestTree +checkLiquidWithConfig fp tests config_f lhconfig_f = + withResource + (do + config <- config_f + g2_lh_config <- lhconfig_f + + lh_config <- getOpts [] + + let config' = config { mode = Liquid } + let proj = takeDirectory fp + + ghci <- try $ getGHCInfos lh_config [proj] [fp] :: IO (Either SomeException [GhcInfo]) + + let ghci' = case ghci of + Right g_c -> g_c + Left e -> error $ "ERROR OCCURRED IN LIQUIDHASKELL\n" ++ show e + + tgt_trans <- translateLoaded [proj] [fp] (simplTranslationConfig { simpl = False }) config' + + return (tgt_trans, ghci', config', g2_lh_config) + ) + (\_ -> return ()) + $ \loaded -> + testGroup + fp + $ map (\(entry, stps, reqList) -> + testCase (fp ++ " " ++ entry) (do + (tgt_trans, ghci, config, lh_config) <- loaded + let config' = config { steps = stps } + res <- doTimeout (timeLimit config) + $ (try (return . fst. fst =<< runLHCore (T.pack entry) tgt_trans ghci config' lh_config) + :: IO (Either SomeException [ExecRes AbstractedInfo])) + + let (ch, r) = case res of + Nothing -> (False, Right [Time]) + Just (Left e) -> (False, Left e) + Just (Right exprs) -> + let + r_ = checkExprGen + (map (\(ExecRes { conc_args = inp, conc_out = out}) -> inp ++ [out]) exprs) + reqList + in + (null r_, Right r_) + + assertBool ("Liquid test for file " ++ fp ++ + " with function " ++ entry ++ " failed.\n" ++ show r) ch + ) + ) tests + +checkAbsLiquid :: FilePath -> String -> Int -> [Reqs ([Expr] -> Expr -> [FuncCall] -> Bool)] -> TestTree +checkAbsLiquid fp entry stps reqList = do + let lhconfig = mkLHConfigDirect [] M.empty + checkAbsLiquidWithConfig fp entry reqList + (do config <- mkConfigTestIO + return $ config {steps = stps} ) + (return lhconfig) + +checkAbsLiquidWithConfig :: FilePath + -> String + -> [Reqs ([Expr] + -> Expr + -> [FuncCall] + -> Bool)] + -> IO Config + -> IO LHConfig + -> TestTree +checkAbsLiquidWithConfig fp entry reqList config_f lhconfig_f = do + testCase fp (do + config <- config_f + lhconfig <- lhconfig_f + res <- findCounterExamples' fp (T.pack entry) config lhconfig + + let (ch, r) = case res of + Nothing -> (False, Right []) + Just (Left e) -> (False, Left e) + Just (Right exprs) -> + let + te = checkAbsLHExprGen + (map (\(ExecRes { final_state = s, conc_args = inp, conc_out = out}) + -> (s, inp, out) + ) exprs + ) reqList + in + (null te, Right te) + + assertBool ("Liquid test for file " ++ fp ++ + " with function " ++ entry ++ " failed.\n" ++ show r) ch + ) + +findCounterExamples' :: FilePath + -> T.Text + -> Config + -> LHConfig + -> IO (Maybe (Either SomeException [ExecRes AbstractedInfo])) +findCounterExamples' fp entry config lhconfig = + let + proj = takeDirectory fp + in + doTimeout (timeLimit config) + $ try (return . fst. fst =<< findCounterExamples [proj] [fp] entry config lhconfig) + +------------------------------------------------- +-- Inference tests +------------------------------------------------- + +posTestInferenceWithTimeOut :: Int -> NominalDiffTime -> FilePath -> TestTree +posTestInferenceWithTimeOut to to_se fp = do + testCase ("Inference " ++ fp) (do + config <- G2.getConfigDirect + let infconfig = (mkInferenceConfigDirect []) { timeout_se = to_se } + let lhconfig = mkLHConfigDirect [] M.empty + res <- doTimeout to $ inferenceCheck infconfig config lhconfig [] [fp] + + assertBool ("Inference for " ++ fp ++ " failed.") $ maybe False (isRight . snd) res + ) + +posTestInference :: FilePath -> TestTree +posTestInference = posTestInferenceWithTimeOut 120 5 + +negTestInference :: FilePath -> TestTree +negTestInference fp = do + testCase ("Inference " ++ fp) (do + config <- G2.getConfigDirect + let infconfig = mkInferenceConfigDirect [] + let lhconfig = mkLHConfigDirect [] M.empty + res <- doTimeout 90 $ inferenceCheck infconfig config lhconfig [] [fp] + + assertBool ("Inference for " ++ fp ++ " failed.") $ maybe False (isLeft . snd) res + ) + +cexTest :: FilePath -> String -> TestTree +cexTest fp func = + testCase ("Inference " ++ fp) (do + config <- G2.getConfigDirect + let infconfig = (mkInferenceConfigDirect []) { timeout_se = 10 } + let lhconfig = mkLHConfigDirect [] M.empty + res <- doTimeout 25 $ runLHInferenceAll infconfig config lhconfig (T.pack func) [] [fp] + assertBool ("Counterexample generation for " ++ func ++ " in " ++ fp ++ " failed.") $ maybe False (not . null . fst) res + ) diff --git a/tests_lh/UnionPoly.hs b/tests_lh/UnionPoly.hs new file mode 100644 --- /dev/null +++ b/tests_lh/UnionPoly.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE OverloadedStrings #-} + +module UnionPoly (unionPolyTests) where + +import G2.Language +import qualified G2.Language.ExprEnv as E +import G2.Liquid.Inference.UnionPoly + +import qualified Data.Text as T + +import Test.Tasty +import Test.Tasty.HUnit + +unionPolyTests :: TestTree +unionPolyTests = + testGroup "UnionPoly" + [ + testCase "Let unification" $ assertBool "Polymorphic unification failed with lets" letTest + , testCase "Lambda unification 1" $ assertBool "Polymorphic unification failed with lambdas" lambdaTest1 + , testCase "Lambda unification 2" $ assertBool "Polymorphic unification failed with lambdas" lambdaTest2 + ] + +letTest :: Bool +letTest = + let + f = defName "f" + g = defName "g" + eenv = letExprEnv f g + + ut = sharedTyConsEE [f, g] eenv + in + case lookupUT g ut of + Just (TyFun t1@(TyVar _) t2) -> t1 == t2 + _ -> False + +letExprEnv :: Name -> Name -> ExprEnv +letExprEnv f g = + let + call = defName "call" + a = defName "a" + + a_id = Id a TYPE + a_ty = TyVar a_id + + int = defName "Int" + int_ty = TyCon int TYPE + + g_id = Id g (TyFun int_ty int_ty) + r_id = Id (defName "r") (TyFun int_ty int_ty) + call_id = Id call . TyForAll a_id $ TyFun (TyFun a_ty a_ty) a_ty + + f_e = Let [(r_id, Var g_id)] . App (App (Var call_id) (Type int_ty)) $ Var r_id + + x_id = Id (defName "x") int_ty + y_id = Id (defName "y") int_ty + g_e = Lam TermL x_id (Var y_id) + in + E.fromList [(f, f_e), (g, g_e)] + +lambdaTest1 :: Bool +lambdaTest1 = + let + f = defName "f" + g = defName "g" + h = defName "h" + eenv = lambdaExprEnv1 f g h + + ut = sharedTyConsEE [f, g, h] eenv + in + case lookupUT h ut of + Just (TyFun t1@(TyVar _) t2) -> t1 == t2 + _ -> False + +lambdaExprEnv1 :: Name -> Name -> Name -> ExprEnv +lambdaExprEnv1 f g h = + let + a = defName "a" + a_id = Id a TYPE + a_ty = TyVar a_id + + int = defName "Int" + int_ty = TyCon int TYPE + + g_id = Id g . TyForAll a_id $ TyFun (TyFun a_ty a_ty) a_ty + h_id = Id h $ TyFun int_ty int_ty + + j_id = Id (defName "j") (TyFun a_ty a_ty) + x_id = Id (defName "x") int_ty + + g_e = Lam TypeL a_id . Lam TermL j_id $ App (App (Var g_id) (Type a_ty)) (Var j_id) + h_e = Lam TermL x_id $ Var x_id + f_e = App (App (Var g_id) (Type int_ty)) . Lam TermL x_id $ App (Var h_id) (Var x_id) + in + E.fromList [(f, f_e), (g, g_e), (h, h_e)] + +lambdaTest2 :: Bool +lambdaTest2 = + let + f = defName "f" + g = defName "g" + h = defName "h" + eenv = lambdaExprEnv2 f g h + + ut = sharedTyConsEE [f, g, h] eenv + in + case lookupUT h ut of + Just (TyFun t1@(TyVar _) t2) -> t1 == t2 + _ -> False + +lambdaExprEnv2 :: Name -> Name -> Name -> ExprEnv +lambdaExprEnv2 f g h = + let + a = defName "a" + a_id = Id a TYPE + a_ty = TyVar a_id + + int = defName "Int" + int_ty = TyCon int TYPE + + g_id = Id g . TyForAll a_id . TyFun (TyFun int_ty int_ty) $ TyFun (TyFun a_ty a_ty) a_ty + h_id = Id h $ TyFun int_ty int_ty + + j_id = Id (defName "j") (TyFun int_ty int_ty) + k_id = Id (defName "k") (TyFun a_ty a_ty) + x_id = Id (defName "x") int_ty + y_id = Id (defName "y") a_ty + + bind_id = Id (defName "bind") (TyForAll a_id (TyFun a_ty a_ty)) + + g_e = Lam TypeL a_id + . Lam TermL j_id + . Lam TermL k_id $ App (App (App (Var g_id) (Type a_ty)) (Var j_id)) (Var k_id) + h_e = Lam TermL x_id $ Var x_id + f_e = Let [(bind_id, Lam TypeL a_id $ Lam TermL y_id (Var y_id))] + . App (App (App (Var g_id) (Type int_ty)) (App (Var bind_id) (Type int_ty))) $ Var h_id + in + E.fromList [(f, f_e), (g, g_e), (h, h_e)] + +defName :: T.Text -> Name +defName n = Name n Nothing 0 Nothing diff --git a/tests_nebula_plugin/Main.hs b/tests_nebula_plugin/Main.hs new file mode 100644 --- /dev/null +++ b/tests_nebula_plugin/Main.hs @@ -0,0 +1,77 @@ +module Main where + +import Test.Tasty +import Test.Tasty.HUnit + +import Control.Exception +import Data.List +import System.IO +import System.Process + +main :: IO () +main = do + defaultMainWithIngredients + defaultIngredients + tests + +tests :: TestTree +tests = testGroup "All Tests" + [ checkPackage "tests/RewriteVerify/PluginTests/Simple" ["add_assoc", "fg", "fg_toint"] ["f_one"]] + +checkPackage :: FilePath + -> [String] -- ^ Rules that should be verified + -> [String] -- ^ Rules that should have counterexamples + -> TestTree +checkPackage loc correct incorrect = + withResource + (buildPackage loc) + (\_ -> return ()) $ + \io_out -> + testGroup + loc + $ verifiedTests io_out correct ++ cexTests io_out incorrect + +verifiedTests :: IO String -> [String] -> [TestTree] +verifiedTests io_out correct = + map (\c -> testCase + c + (do + out <- io_out + assertBool ("Not verified") (isVerified c out && not (hasCEx c out))) + ) correct + +cexTests :: IO String -> [String] -> [TestTree] +cexTests io_out incorrect = + map (\i -> testCase + i + (do + out <- io_out + assertBool ("No counterexample") (not (isVerified i out) && hasCEx i out)) + ) incorrect + +buildPackage :: FilePath -> IO String +buildPackage loc = do + (Nothing, Nothing, Nothing, clean_ph) <- createProcess + $ (proc "cabal" ["clean"]) { cwd = Just loc + , std_out = Inherit } + waitForProcess clean_ph + (Nothing, Nothing, Nothing, build_g2_ph) <- createProcess + $ (proc "cabal" ["build", "g2"]) { cwd = Just loc } + waitForProcess build_g2_ph + (Nothing, Just stdout, Nothing, ph) <- createProcess + $ (proc "cabal" ["build"]) { cwd = Just loc + , std_out = CreatePipe } + waitForProcess ph + out <- hGetContents stdout + _ <- evaluate (length out) + hClose stdout + return out + +isVerified :: String -> String -> Bool +isVerified f = isSubstringOf (f ++ " - verified") + +hasCEx :: String -> String -> Bool +hasCEx f = isSubstringOf (f ++ " - counterexample found") + +isSubstringOf :: String -> String -> Bool +isSubstringOf = isInfixOf diff --git a/tests_quasiquote/Arithmetics/Interpreter.hs b/tests_quasiquote/Arithmetics/Interpreter.hs new file mode 100644 --- /dev/null +++ b/tests_quasiquote/Arithmetics/Interpreter.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +module Arithmetics.Interpreter where + +import Control.Monad +import Data.Data +import G2.QuasiQuotes.G2Rep + +type Ident = String +type Env = [(Ident, Int)] + +data AExpr = I Int | Var Ident + | Add AExpr AExpr | Mul AExpr AExpr + deriving (Eq, Show, Data) + +$(derivingG2Rep ''AExpr) + +data BExpr = Not BExpr | And BExpr BExpr | Or BExpr BExpr + | Lt AExpr AExpr | Eq AExpr AExpr + deriving (Eq, Show, Data) + +$(derivingG2Rep ''BExpr) + +type Stmts = [Stmt] +data Stmt = Assign Ident AExpr + | If BExpr Stmts Stmts + | While BExpr Stmts + | Assert BExpr + deriving (Eq, Show, Data) + +$(derivingG2Rep ''Stmt) + +type Bound = [Ident] +type Return = Ident +data Func = Func Bound Stmts Return + +$(derivingG2Rep ''Func) + +evalFunc :: [Int] -> Func -> Maybe Int +evalFunc is (Func b s r) = + lookup r =<< evalStmts (zip b is) s + +evalStmts :: Env -> Stmts -> Maybe Env +evalStmts = foldM evalStmt + +evalStmt :: Env -> Stmt -> Maybe Env +evalStmt env (Assign ident aexpr) = + Just $ (ident, evalA env aexpr):env +evalStmt env (If bexpr lhs rhs) = + if evalB env bexpr + then evalStmts env lhs + else evalStmts env rhs +evalStmt env (While bexpr loop) = + if evalB env bexpr + then evalStmts env (loop ++ [While bexpr loop]) + else Just env +evalStmt env (Assert bexpr) = + if evalB env bexpr + then Just env + else Nothing + +evalA :: Env -> AExpr -> Int +evalA _ (I int) = int +evalA env (Add lhs rhs) = + evalA env lhs + evalA env rhs +evalA env (Mul lhs rhs) = + evalA env lhs * evalA env rhs +evalA env (Var ident) = + case lookup ident env of + Just int -> int + _ -> error $ + "lookup with " ++ show (ident, env) + +evalB :: Env -> BExpr -> Bool +evalB env (Not bexpr) = not $ evalB env bexpr +evalB env (And lhs rhs) = + evalB env lhs && evalB env rhs +evalB env (Or lhs rhs) = + evalB env lhs || evalB env rhs +evalB env (Lt lhs rhs) = + evalA env lhs < evalA env rhs +evalB env (Eq lhs rhs) = + evalA env lhs == evalA env rhs + diff --git a/tests_quasiquote/Arithmetics/Test.hs b/tests_quasiquote/Arithmetics/Test.hs new file mode 100644 --- /dev/null +++ b/tests_quasiquote/Arithmetics/Test.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Arithmetics.Test where + +import Arithmetics.Interpreter +import G2.QuasiQuotes.QuasiQuotes + +badProg :: Stmts +badProg = + [ + Assign "k" (I 1), + Assign "i" (I 0), + -- Assign "j" (I 0), + Assign "n" (I 5), + While (Or (Lt (Var "i") (Var "n")) + (Eq (Var "i") (Var "n"))) + [ Assign "i" (Add (Var "i") (I 1)) + , Assign "j" (Add (Var "j") (Var "i")) + ], + Assign "z" (Add (Var "k") (Add (Var "i") (Var "j"))), + Assert (Lt (Mul (Var "n") (I 2)) (Var "z")) + ] + +productTest :: IO (Maybe (AExpr, AExpr)) +productTest = + [g2| \(a :: Int) -> ?(s1 :: AExpr) + ?(s2 :: AExpr) | + let env = [("x", 23), ("y", 59)] in + let lhs = Mul (Var "x") (Var "y") in + let rhs = Mul s1 s2 in + evalB env (Eq lhs rhs) |] 0 + +envTest :: BExpr -> IO (Maybe Env) +envTest = [g2|\(b :: BExpr) -> ?(env :: Env) | + evalB env b |] + +searchBadEnv :: Stmts -> IO (Maybe Env) +searchBadEnv = + [g2| \(stmts :: Stmts) -> ?(env :: Env) | + evalStmts env stmts == Nothing|] + +assertViolation :: Stmts -> IO (Maybe Env) +assertViolation = [g2|\(stmts :: Stmts) -> ?(env :: Env) | + evalStmts env stmts == Nothing|] + +productSumProg :: BExpr +productSumProg = + And + ((Eq + (Mul (Var "x") (Var "y")) + (Add (Var "x") (Var "y")))) + (Lt (I 0) (Var "x")) + + +productSumAssertTest :: IO (Maybe Env) +productSumAssertTest = assertViolation + [ If (Lt (I 0) (Var "x")) + [ Assert (Not + (Eq + (Mul (Var "x") (Var "y")) + (Add (Var "x") (Var "y")) + ) + ) + ] + [] + ] + +assertViolationTest1 :: IO (Maybe Env) +assertViolationTest1 = assertViolation + [ Assert (Lt (I 5) (I 3)) ] + +-- x^2 + y^2 + z^2 < (x + y + z)^2 +assertViolationTest2 :: IO (Maybe Env) +assertViolationTest2 = assertViolation + [ Assign "v1" (Add (Var "x") (Add (Var "y") (Var "z"))) + , Assign "v1" (Mul (Var "v1") (Var "v1")) + , Assign "v2" (Add (Mul (Var "x") (Var "x")) + (Add (Mul (Var "y") (Var "y")) + (Mul (Var "z") (Var "z")))) + , Assert (Lt (Var "v2") (Var "v1")) + ] + + +assertViolationTest3 :: IO (Maybe Env) +assertViolationTest3 = assertViolation + [ + Assign "k" (I 1), + Assign "i" (I 0), + Assign "j" (I 0), + Assign "n" (I 5), + While (Or (Lt (Var "i") (Var "n")) + (Eq (Var "i") (Var "n"))) + [ Assign "i" (Add (Var "i") (I 1)) + , Assign "j" (Add (Var "j") (Var "i")) + ], + Assign "z" (Add (Var "k") (Add (Var "i") (Var "j"))), + Assert (Lt (Mul (Var "n") (I 2)) (Var "z")) + ] + + +assertViolationTest4 :: IO (Maybe Env) +assertViolationTest4 = assertViolation + [ + Assign "k" (I 1), + Assign "i" (I 0), + -- Assign "j" (I 0), + Assign "n" (I 5), + While (Or (Lt (Var "i") (Var "n")) + (Eq (Var "i") (Var "n"))) + [ Assign "i" (Add (Var "i") (I 1)) + , Assign "j" (Add (Var "j") (Var "i")) + ], + Assign "z" (Add (Var "k") (Add (Var "i") (Var "j"))), + Assert (Lt (Mul (Var "n") (I 2)) (Var "z")) + ] + + diff --git a/tests_quasiquote/DeBruijn/Interpreter.hs b/tests_quasiquote/DeBruijn/Interpreter.hs new file mode 100644 --- /dev/null +++ b/tests_quasiquote/DeBruijn/Interpreter.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +module DeBruijn.Interpreter ( Expr (..) + , Ident + , eval + , app + , lams + , num) where + +import Data.Data +import G2.QuasiQuotes.G2Rep + +type Ident = Int + +data Expr = Var Ident + | Lam Expr + | App Expr Expr + deriving (Show, Read, Eq, Data) + +$(derivingG2Rep ''Expr) + +type Stack = [Expr] + +eval :: Expr -> Expr +eval = eval' [] + +eval' :: Stack -> Expr -> Expr +eval' (e:stck) (Lam e') = eval' stck (rep 1 e e') +eval' stck (App e1 e2) = eval' (e2:stck) e1 +eval' stck e = app $ e:stck + +rep :: Int -> Expr -> Expr -> Expr +rep i e v@(Var j) + | i == j = e + | otherwise = v +rep i e (Lam e') = Lam (rep (i + 1) e e') +rep i e (App e1 e2) = App (rep i e e1) (rep i e e2) + +app :: [Expr] -> Expr +app = foldl1 App + +lams :: Int -> Expr -> Expr +lams n e = iterate Lam e !! n + +num :: Int -> Expr +num n = Lam $ Lam $ foldr1 App (replicate n (Var 2) ++ [Var 1]) diff --git a/tests_quasiquote/DeBruijn/Test.hs b/tests_quasiquote/DeBruijn/Test.hs new file mode 100644 --- /dev/null +++ b/tests_quasiquote/DeBruijn/Test.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE QuasiQuotes #-} + +module DeBruijn.Test where + +import DeBruijn.Interpreter +import G2.QuasiQuotes.QuasiQuotes + +import RegEx.RegEx as R + +solveDeBruijn :: [([Expr], Expr)] -> IO (Maybe Expr) +solveDeBruijn = + [g2| \(es :: [([Expr], Expr)]) -> ?(func :: Expr) | + all (\e -> (eval (app (func:fst e))) == snd e) es |] + +appFunc :: [([Expr], Expr)] -> Expr -> Bool +appFunc es func = all (\e -> (eval (app (func:fst e))) == snd e) es + +idDeBruijn :: [([Expr], Expr)] +idDeBruijn = [ ([num 1], num 1) + , ([num 2], num 2) ] + +const2Example :: [([Expr], Expr)] +const2Example = + [ ([num 1, num 2], num 1) + , ([num 2, num 3], num 2) ] + +trueLam :: Expr +trueLam = Lam (Lam (Var 2)) + +falseLam :: Expr +falseLam = Lam (Lam (Var 1)) + +notExample :: [([Expr], Expr)] +notExample = + [ ([trueLam], falseLam) + , ([falseLam], trueLam) ] + +orExample :: [([Expr], Expr)] +orExample = + [ ([trueLam, trueLam], trueLam) + , ([falseLam, falseLam], falseLam) + , ([falseLam, trueLam], trueLam) + , ([trueLam, falseLam], trueLam )] + +andExample :: [([Expr], Expr)] +andExample = + [ ([trueLam, trueLam], trueLam) + , ([falseLam, falseLam], falseLam) + , ([falseLam, trueLam], falseLam) + , ([trueLam, falseLam], falseLam )] + + +-- runDeBruijnEval :: IO () +-- runDeBruijnEval = do +-- putStrLn "------------------------" +-- putStrLn "-- DeBruijn Eval -------" +-- timeIOActionPrint $ solveDeBruijn idDeBruijn +-- timeIOActionPrint $ solveDeBruijn const2Example +-- -- timeIOActionPrint $ solveDeBruijn notExample +-- timeIOActionPrint $ solveDeBruijn orExample +-- -- timeIOActionPrint $ solveDeBruijn andExample +-- putStrLn "" diff --git a/tests_quasiquote/Evaluations.hs b/tests_quasiquote/Evaluations.hs new file mode 100644 --- /dev/null +++ b/tests_quasiquote/Evaluations.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Evaluations where + +import G2.QuasiQuotes.QuasiQuotes + +import DeBruijn.Interpreter as D +import RegEx.RegEx as R + + +------------------------------------------- +------------------------------------------- +-- Section 5.2 (Lambda Calculus) + +solveDeBruijn :: [([Expr], Expr)] -> IO (Maybe Expr) +solveDeBruijn = + [g2| \(es :: [([Expr], Expr)]) -> ?(func :: Expr) | + all (\e -> (eval (app (func:fst e))) == snd e) es |] + +idDeBruijn :: [([D.Expr], D.Expr)] +idDeBruijn = [ ([num 1], num 1) + , ([num 2], num 2) ] + +const2Example :: [([D.Expr], D.Expr)] +const2Example = + [ ([num 1, num 2], num 1) + , ([num 2, num 3], num 2) ] + +trueLam :: D.Expr +trueLam = Lam (Lam (D.Var 2)) + +falseLam :: D.Expr +falseLam = Lam (Lam (D.Var 1)) + +notExample :: [([D.Expr], D.Expr)] +notExample = + [ ([trueLam], falseLam) + , ([falseLam], trueLam) ] + +orExample :: [([D.Expr], D.Expr)] +orExample = + [ ([trueLam, trueLam], trueLam) + , ([falseLam, falseLam], falseLam) + , ([falseLam, trueLam], trueLam) + , ([trueLam, falseLam], trueLam )] + +andExample :: [([D.Expr], D.Expr)] +andExample = + [ ([trueLam, trueLam], trueLam) + , ([falseLam, falseLam], falseLam) + , ([falseLam, trueLam], falseLam) + , ([trueLam, falseLam], falseLam )] + + + + +------------------------------------------- +------------------------------------------- + + diff --git a/tests_quasiquote/Lambda/Interpreter.hs b/tests_quasiquote/Lambda/Interpreter.hs new file mode 100644 --- /dev/null +++ b/tests_quasiquote/Lambda/Interpreter.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +module Lambda.Interpreter where + +import Data.Data +import Data.List +import G2.QuasiQuotes.QuasiQuotes +import G2.QuasiQuotes.G2Rep + +type Id = String + +data Prim = I Int | B Bool | Fun Id + deriving (Show, Eq, Data) + +$(derivingG2Rep ''Prim) + +data Expr + = Var Id + | Lam Id Expr + | App Expr Expr + | Const Prim + deriving (Show, Eq, Data) + +$(derivingG2Rep ''Expr) + +type Env = [(Id, Expr)] + +eval :: Env -> Expr -> Expr +eval env (Var id) = + case lookup id env of + Just expr -> eval env expr + Nothing -> Const (Fun id) +eval env (App (Lam i body) arg) = + eval ((i, arg) : env) body +eval env expr = expr + diff --git a/tests_quasiquote/Lambda/Test.hs b/tests_quasiquote/Lambda/Test.hs new file mode 100644 --- /dev/null +++ b/tests_quasiquote/Lambda/Test.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Lambda.Test where + +import Lambda.Interpreter +import G2.QuasiQuotes.QuasiQuotes + +lambdaTest1 :: IO (Maybe Expr) +lambdaTest1 = [g2| \(x :: Int ) -> ?(symExpr :: Expr) | + let env = [] in + let expr = App (Lam "b" (Var "b")) symExpr in + eval env expr == (Const (I 40)) |] 0 + + +lambdaTest2 :: IO (Maybe Expr) +lambdaTest2 = [g2| \(x :: Int ) -> ?(symExpr :: Expr) | + let env = [] in + let expr = symExpr in + eval env expr == (Const (I 43)) |] 0 diff --git a/tests_quasiquote/Main.hs b/tests_quasiquote/Main.hs new file mode 100644 --- /dev/null +++ b/tests_quasiquote/Main.hs @@ -0,0 +1,296 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Main where + +import Test.Tasty +import Test.Tasty.HUnit + +import DeBruijn.Test +import Arithmetics.Interpreter +import Arithmetics.Test +import Lambda.Test +import NQueens.Test +import RegEx.Test +import RegEx.RegEx +import Simple.SimpleTest1 + +import G2.Interface + +import qualified Evaluations as E + +tests :: TestTree +tests = testGroup "All Tests" + [ -- simpleTests + nqueensTests + , arithmeticsTests + -- , deBruijnTests + , regexTests ] + +simpleTests :: TestTree +simpleTests = testGroup "Simple" + [ qqTestCase "Simple 1" (sd ()) af ] + +nqueensTests :: TestTree +nqueensTests = testGroup "N Queens" + [ qqTestCase "4 Queens" (queensTestN 4) (allQueensSafe 4) + , qqTestCase "5 Queens" (queensTestN 5) (allQueensSafe 5) + , qqTestCase "6 Queens" (queensTestN 6) (allQueensSafe 6) + , qqTestCase "7 Queens" (queensTestN 7) (allQueensSafe 7) + , qqTestCase "8 Queens" (queensTestN 8) (allQueensSafe 8) ] + +arithmeticsTests :: TestTree +arithmeticsTests = testGroup "Arithmetic" + [ qqTestCase "Arithmetic 1" (searchBadEnv badProg) + (\env -> evalStmts env badProg == Nothing) + , qqTestCase "Arithmetic 2" (envTest productSumProg) (flip evalB productSumProg) + ] + +deBruijnTests :: TestTree +deBruijnTests = testGroup "DeBruijn" + [ qqTestCase "DeBruijn 1" (solveDeBruijn idDeBruijn) (appFunc idDeBruijn) + , qqTestCase "DeBruijn 2" (solveDeBruijn const2Example) (appFunc const2Example) + , qqTestCase "DeBruijn 3" (solveDeBruijn orExample) (appFunc orExample) + ] + + +regexTests :: TestTree +regexTests = testGroup "Regex" + [ qqTestCase "Regex 1" (stringSearch regex1) (match regex1) + , qqTestCase "Regex 2" (stringSearch regex2) (match regex2) + , qqTestCase "Regex 3" (stringSearch regex3) (match regex3) + , qqTestCase "Regex 4" (stringSearch regex4) (match regex4) + ] + +qqTestCase :: (Eq a, Show a) => TestName -> IO (Maybe a) -> (a -> Bool) -> TestTree +qqTestCase name io_val p = do + testCase name (do + val <- doTimeout 180 $ io_val + assertBool + ("Predicate not satisfied by " ++ show val) + (case val of + Just (Just val') -> p val' + _ -> False)) + +-- arithmeticsTests :: IO () +-- arithmeticsTests = do +-- putStrLn "---------------------" +-- putStrLn "arithmeticsTests ----" + +-- putStrLn "-- productTest" +-- timeIOActionPrint productTest +-- putStrLn "" + +-- putStrLn "-- productSumTest" +-- timeIOActionPrint productSumTest +-- putStrLn "" + +-- putStrLn "-- productSumAssertTest" +-- timeIOActionPrint productSumAssertTest +-- putStrLn "" + +-- putStrLn "-- assertViolationTest1" +-- timeIOActionPrint assertViolationTest1 +-- putStrLn "" + +-- -- Technically this is non-linear integer arithm so undecidable +-- -- putStrLn "-- assertViolationTest2" +-- -- timeIOActionPrint assertViolationTest2 +-- -- putStrLn "" + +-- -- About 6 secs +-- putStrLn "-- assertViolationTest3" +-- timeIOActionPrint assertViolationTest3 +-- putStrLn "" + +-- -- About 51 secs +-- putStrLn "-- assertViolationTest4" +-- timeIOActionPrint assertViolationTest4 +-- putStrLn "" + + + + +-- putStrLn "---------------------\n\n" + + +-- lambdaTests :: IO () +-- lambdaTests = do +-- putStrLn "---------------------" +-- putStrLn "lambdaTests ---------" + +-- putStrLn "-- lambdaTest1" +-- timeIOActionPrint lambdaTest1 +-- putStrLn "" + +-- putStrLn "-- lambdaTest2" +-- timeIOActionPrint lambdaTest2 +-- putStrLn "" + +-- putStrLn "---------------------\n\n" +-- return () + +-- debruijnTests :: IO () +-- debruijnTests = do +-- putStrLn "---------------------" +-- putStrLn "debruijnTests -------" + +-- putStrLn "-- solveDeBruijnI" -- identity +-- timeIOActionPrint $ solveDeBruijnI + +-- putStrLn "-- solveDeBruijnK" -- const +-- timeIOActionPrint $ solveDeBruijnK + +-- putStrLn "-- solveDeBruijnOr" +-- timeIOActionPrint $ solveDeBruijnOr + +-- -- putStrLn "-- solveDeBruijnAnd" +-- -- timeIOActionPrint $ solveDeBruijnAnd + +-- putStrLn "-- solveDeBruijnIte" +-- timeIOActionPrint $ solveDeBruijnIte + +-- putStrLn "---------------------\n\n" +-- return () + +-- regexTests :: IO () +-- regexTests = do +-- putStrLn "---------------------" +-- putStrLn "regexTests ----------" + +-- putStrLn "-- regexTest1" +-- timeIOActionPrint regexTest1 +-- putStrLn "" + +-- putStrLn "-- regexTest2" +-- timeIOActionPrint regexTest2 +-- putStrLn "" + +-- putStrLn "---------------------\n\n" +-- return () + + +main :: IO () +main = do + defaultMainWithIngredients + defaultIngredients + tests + +{- +main :: IO () +main = do + putStrLn "main: compiles!" + + -- arithmeticsTests + -- lambdaTests + -- nqueensTests + -- debruijnTests + -- regexTests + + nqueensTests + runArithmeticsEval + runDeBruijnEval + runRegExEval + + + + putStrLn "main: done" +-} + + -- print =<< queensTestN 6 + -- print =<< solveDeBruijnI + -- print =<< solveDeBruijnK + -- print =<< lambdaTest2 + + -- putStrLn "-- Basic Test --" + -- r <- f 8 10 + -- print r + + -- r2 <- g 7 + -- print r2 + + -- r3 <- h 11 + -- print r3 + + -- putStrLn "\n-- Bool Test --" + -- print =<< boolTest 2 + -- print =<< boolTest 4 + + -- putStrLn "\n-- maybeOrdering Test --" + -- print =<< maybeOrderingTest (Just LT) + + -- putStrLn "\n-- Rearrange Tuples Test --" + -- print =<< rearrangeTuples (4, 5) (-6, -4) + + -- putStrLn "\n-- Float Test --" + -- print =<< floatTest (6.7) (9.5) + + -- putStrLn "\n-- Double Test --" + -- print =<< doubleTest (2.2) (4.9) + + -- putStrLn "\n-- String Test --" + -- print =<< stringTest "hiiiiiiiiiiiiiiiit!" + + -- putStrLn "\n-- Import Test --" + -- print =<< importTest 5 + + -- putStrLn "\n-- Infinite Test --" + -- print =<< infiniteTest [5..] + + -- putStrLn "\n-- Infinite Test 2 --" + -- print =<< infiniteTest2 [5..] 3 + + -- putStrLn "\n-- Infinite Return --" + -- ir <- infiniteReturn 8 + -- print $ fmap (headInf . tailInf) ir + +-- fBad1 :: Float -> Int -> IO (Maybe Int) +-- fBad1 = [g2|(\y z -> \x ? x + 2 == y + z) :: Int -> Int -> Int -> Bool|] + +-- fBad2 :: Int -> Int -> IO (Maybe Float) +-- fBad2 = [g2|(\y z -> \x ? x + 2 == y + z) :: Int -> Int -> Int -> Bool|] + +-- f :: Int -> Int -> IO (Maybe Int) +-- f = [g2|\(y :: Int) (z :: Int) -> ?(x :: Int) | x + 2 == y + z|] + +-- g :: Int -> IO (Maybe (Int, Int)) +-- g = [g2|\(a :: Int) -> ?(x :: Int) ?(y :: Int) | x < a && a < y && y - x > 10|] + +-- h :: Int -> IO (Maybe [Int]) +-- h = [g2|\(total :: Int) -> ?(lst :: [Int]) | sum lst == total && length lst >= 2|] + +-- boolTest :: Int -> IO (Maybe Bool) +-- boolTest = [g2|\(i ::Int) -> ?(b :: Bool) | (i == 4) == b|] + +-- maybeOrderingTest :: Maybe Ordering -> IO (Maybe (Maybe Ordering)) +-- maybeOrderingTest = [g2|\(m1 :: Maybe Ordering) -> ?(m2 :: Maybe Ordering) | (fmap succ m1 == m2)|] + +-- rearrangeTuples :: (Int, Int) -> (Int, Int) -> IO (Maybe (Int, Int)) +-- rearrangeTuples = [g2|\(ux :: (Int, Int)) (yz :: (Int, Int)) -> ?(ab :: (Int, Int)) | +-- let +-- (u, x) = ux +-- (y, z) = yz +-- (a, b) = ab +-- in +-- (a == u || a == y) +-- && (b == x || b == z) && (a + b == 0 )|] + +-- floatTest :: Float -> Float -> IO (Maybe Float) +-- floatTest = [g2|\(f1 :: Float) (f2 :: Float) -> ?(f3 :: Float) | f1 < f3 && f3 < f2|] + +-- doubleTest :: Double -> Double -> IO (Maybe Double) +-- doubleTest = [g2|\(d1 :: Double) (d2 :: Double) -> ?(d3 :: Double) | d1 <= d3 && d3 <= d2|] + +-- stringTest :: String -> IO (Maybe String) +-- stringTest = [g2|\(str1 :: String) -> ?(str2 :: String) | str1 == str2 ++ "!"|] + +-- importTest :: Int -> IO (Maybe Int) +-- importTest = [g2|\(x :: Int) -> ?(ans :: Int) | addTwo x == ans|] + +-- infiniteTest :: [Int] -> IO (Maybe Int) +-- infiniteTest = [g2|\(xs :: [Int]) -> ?(x :: Int) | x == head xs|] + +-- infiniteTest2 :: [Int] -> Int -> IO (Maybe [Int]) +-- infiniteTest2 = [g2|\(xs :: [Int]) (t :: Int) -> ?(ys :: [Int]) | ys == take t xs|] + +-- infiniteReturn :: Int -> IO (Maybe (InfList Int)) +-- infiniteReturn = [g2|\(t :: Int) -> ?(ys :: InfList Int) | headInf ys == t |] diff --git a/tests_quasiquote/NQueens/Encoding.hs b/tests_quasiquote/NQueens/Encoding.hs new file mode 100644 --- /dev/null +++ b/tests_quasiquote/NQueens/Encoding.hs @@ -0,0 +1,62 @@ +module NQueens.Encoding where + +import Data.List + +type Queen = Int + +indexPairs :: Int -> [(Int,Int)] +indexPairs n = [(i, j) | i <- [0..n-1], j <- [i+1..n-1]] + +legal :: Int -> Queen -> Bool +legal n qs = 1 <= qs && qs <= n + +queenPairSafe :: Int -> [Queen] -> (Int, Int) -> Bool +queenPairSafe n qs (i, j) = + let qs_i = qs !! i + qs_j = qs !! j + in (qs_i /= qs_j) + -- && (abs (qs_j - qs_i) /= (j - i)) + && qs_j - qs_i /= j - i + && qs_j - qs_i /= i - j + +allQueensSafe :: Int -> [Queen] -> Bool +allQueensSafe n qs = + (n == length qs) + && all (legal n) qs + && (all (queenPairSafe n qs) (indexPairs n)) + +solveListCompN :: Int -> [Int] +solveListCompN n = + head . filter (allQueensSafe n) $ [x | x <- mapM (const [1..n]) [1..n]] + +{- +-- Gets all pairs of unique positions +pairs :: Ord a => [a] -> [(a, a)] +pairs xs = [(a, b) | a <- xs, b <- xs, a < b] + +-- Checks if all elements of list are unique +allUnique :: Ord a => [a] -> Bool +allUnique xs = length xs == length (nub xs) + +-- Check if two positions are safe +pairSafe :: (Queen, Queen) -> Bool +pairSafe ((x1, y1), (x2, y2)) = + -- No same x and y value + (x1 /= x2) && (y1 /= y2) + -- Not on the same diagonal + && (abs (x1 - x2) /= abs (y1 - y2)) + +-- Check that all queens in a list are safe +allSafe :: [Queen] -> Bool +allSafe queens = all pairSafe $ pairs queens + +-- Valid Queens on an n x n board +legalQueens :: Int -> [Queen] -> Bool +legalQueens n queens = + (length queens == n) + && (n == length (nub queens)) + && all (\(x, y) -> 1 <= x && x <= n && 1 <= y && y <= n) queens + -- && all (\p -> (1, 1) <= p && p <= (n, n)) queens + +-} + diff --git a/tests_quasiquote/NQueens/Test.hs b/tests_quasiquote/NQueens/Test.hs new file mode 100644 --- /dev/null +++ b/tests_quasiquote/NQueens/Test.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE QuasiQuotes #-} + +module NQueens.Test (queensTestN, allQueensSafe) where + +import NQueens.Encoding +import G2.QuasiQuotes.QuasiQuotes + +{- +queensTestN :: Int -> IO (Maybe [Queen]) +queensTestN n = [g2| \(n :: Int) -> ?(queens :: [Queen]) | + legalQueens n queens + && allSafe queens |] n +-} + +queensTestN :: Int -> IO (Maybe [Queen]) +queensTestN num = [g2| \(n :: Int) -> ?(qs :: [Queen]) | + allQueensSafe n qs |] num + + diff --git a/tests_quasiquote/RegEx/RegEx.hs b/tests_quasiquote/RegEx/RegEx.hs new file mode 100644 --- /dev/null +++ b/tests_quasiquote/RegEx/RegEx.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +module RegEx.RegEx where + +import Data.Data +import G2.QuasiQuotes.G2Rep + + +data RegEx = Empty | Epsilon | Atom Char + | Star RegEx | Concat RegEx RegEx | Or RegEx RegEx + deriving (Show, Eq, Data) + +$(derivingG2Rep ''RegEx) + +match :: RegEx -> String -> Bool +match Empty _ = False +match Epsilon s = null s +match (Atom x) s = s == [x] +match (Star _) [] = True +match r@(Star x) s = any (match2 x r) + (splits [1..length s] s) +match (Concat a b) s = any (match2 a b) + (splits [0..length s] s) +match (Or a b) s = match a s || match b s + +match2 :: RegEx -> RegEx -> (String, String) -> Bool +match2 a b (sa, sb) = match a sa && match b sb + +splits :: [Int] -> [a] -> [([a], [a])] +splits ns x = map (\n -> splitAt n x) ns + + + + diff --git a/tests_quasiquote/RegEx/Test.hs b/tests_quasiquote/RegEx/Test.hs new file mode 100644 --- /dev/null +++ b/tests_quasiquote/RegEx/Test.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE QuasiQuotes #-} + +module RegEx.Test where + +import RegEx.RegEx +import G2.QuasiQuotes.QuasiQuotes + +stringSearch :: RegEx -> IO (Maybe String) +stringSearch = [g2| \(r :: RegEx) -> ?(str :: String) | + match r str |] + + +-- (a + b)* c (d + (e f)*) +regex1 :: RegEx +regex1 = + Concat (Star (Or (Atom 'a') (Atom 'b'))) + (Concat (Atom 'c') + (Or (Atom 'd') + (Concat (Atom 'e') + (Atom 'f')))) + +regex2 :: RegEx +regex2 = Concat (Atom 'a') + (Concat (Atom 'b') + (Concat (Atom 'c') + (Concat (Atom 'd') + (Concat (Atom 'e') + ((Atom 'f')))))) + +regex3 :: RegEx +regex3 = Or (Atom 'a') + (Or (Atom 'b') + (Or (Atom 'c') + (Or (Atom 'd') + (Or (Atom 'e') + ((Atom 'f')))))) + +regex4 :: RegEx +regex4 = Concat (Star (Atom 'a')) + (Concat (Star (Atom 'b')) + (Concat (Star (Atom 'c')) + (Concat (Star (Atom 'd')) + (Concat (Star (Atom 'e')) + ((Star (Atom 'f'))))))) diff --git a/tests_quasiquote/Simple/Simple1.hs b/tests_quasiquote/Simple/Simple1.hs new file mode 100644 --- /dev/null +++ b/tests_quasiquote/Simple/Simple1.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +module Simple.Simple1 ( Expr (..) + , eval + , num1) where + +import Data.Data +import G2.QuasiQuotes.G2Rep + +data Expr = Var Int + | Lam Expr + | App Expr Expr + deriving (Show, Read, Eq, Data) + +$(derivingG2Rep ''Expr) + +type Stack = [Expr] + + +eval :: Stack -> Expr -> Expr +eval (e:stck) (Lam e') = eval stck (rep e e') +eval stck (App e1 e2) = eval (e2:stck) e1 +eval stck e@(Var _) = foldl1 App (e:stck) + +rep :: Expr -> Expr -> Expr +rep e (Var _) = e +rep e (Lam e') = Lam (rep e e') +rep e (App e1 e2) = App (rep e e1) (rep e e2) + +num1 :: Expr +num1 = Lam (Var 1) diff --git a/tests_quasiquote/Simple/SimpleTest1.hs b/tests_quasiquote/Simple/SimpleTest1.hs new file mode 100644 --- /dev/null +++ b/tests_quasiquote/Simple/SimpleTest1.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Simple.SimpleTest1 where + +import Simple.Simple1 +import G2.QuasiQuotes.QuasiQuotes + +import RegEx.RegEx as R + +sd :: () -> IO (Maybe Expr) +sd = + [g2| \(e :: ()) -> ?(func :: Expr) | eval [] (App func num1) == num1 |] + +af :: Expr -> Bool +af func = (eval [] (App func num1)) == num1