copilot-theorem-4.3/0000755000000000000000000000000014762717277012704 5ustar0000000000000000copilot-theorem-4.3/README.md0000644000000000000000000005671514762717277014201 0ustar0000000000000000[![Build Status](https://travis-ci.com/Copilot-Language/copilot.svg?branch=master)](https://app.travis-ci.com/github/Copilot-Language/copilot) # Copilot Theorem Highly automated proof techniques are a necessary step for the widespread adoption of formal methods in the software industry. Moreover, it could provide a partial answer to one of its main issues, which is scalability. *copilot-theorem* is a Copilot library aimed at checking automatically some safety properties on Copilot programs. It includes: * A general interface for *provers* and a *proof scheme* mechanism aimed at splitting the task of proving a complex property into checking a sequence of smaller lemmas. * A prover implementing basic **k-induction** model checking [1], useful for proving basic k-inductive properties and for pedagogical purposes. * A prover producing native inputs for the *Kind2* model checker, developed at the University of Iowa. The latter uses both the *k-induction algorithm* extended with *path compression* and *structural abstraction* [2] and the **IC3 algorithm** with counterexample generalization based on *approximate quantifier elimination* [3]. ## A Tutorial ### Installation instructions *copilot-theorem* needs the following dependencies to be installed: * The *copilot-core* and *copilot-prettyprinter* Haskell libraries * The *Yices2* SMT-solver: `yices-smt2` must be in your `$PATH` * The *Z3* SMT-solver: `z3` must be in your `$PATH` * The *Kind2* model checker: `kind2` must be in your `$PATH` To build it, just install the Copilot library as described in the top-level README. ### First steps *copilot-theorem* is aimed at checking **safety properties** on Copilot programs. Intuitively, a safety property is a property that expresses the idea that *nothing bad can happen*. In particular, any invalid safety property can be disproved by a finite execution trace of the program called a **counterexample**. Safety properties are often opposed to **liveness** properties, which express the idea that *something good will eventually happen*. The latter is out of the scope of *copilot-theorem*. Safety properties are simply expressed with standard boolean streams. In addition to triggers and observers declarations, it is possible to bind a boolean stream to a property name with the `prop` construct in the specification. For instance, here is a straightforward specification declaring one property: ```haskell spec :: Spec spec = do void $ prop "gt0" (forAll $ x > 0) where x = [1] ++ (1 + x) ``` Let's say we want to check that `gt0` holds. For this, we use the `prove :: Copilot.Core.Spec.Spec -> String -> UProof -> IO Bool` function exported by `Copilot.Theorem`. This function takes three arguments: * A reified Copilot.Language.Spec. * The name of the proposition we want to check. * A strategy to prove the proposition. In this case, the proposition is simple enough so that we can check it directly by k-induction using `kind2Prover`. Therefore we can just write: ```haskell main = do spec' <- reify spec prove spec' "gt0" (tell [Check $ kind2Prover def]) ``` where `kind2Prover def` stands for the *Kind2 prover* with the default configuration. #### The Kind2 prover The *Kind2* prover uses the model checker with the same name, from the University of Iowa. It translates the Copilot specification into a *modular transition system* (the Kind2 native format) and then calls the `kind2` executable. It is provided by the `Copilot.Theorem.Kind2` module, which exports a `kind2Prover :: Options -> Prover` where the `Options` type is defined as ```haskell data Options = Options { bmcMax :: Int } ``` and where `bmcMax` corresponds to the `--bmc_max` option of *kind2* and is equivalent to the `maxK` option of the K-Induction prover. Its default value is 0, which stands for infinity. ### Some examples Some examples are in the *examples* folder, including: * `Incr.hs` : a straightforward example in the style of the previous one. * `Grey.hs` : an example where two different implementations of a periodical counter are shown to be equivalent. * `BoyerMoore.hs` : a certified version of the majority vote algorithm introduced in the Copilot tutorial. * `SerialBoyerMoore.hs` : a *serial* version of the first step of the *Boyer Moore algorithm*, where a new element is added to the list and the majority candidate is updated at each clock tick. See the section *Limitations related to the SMT solvers* for an analysis of this example. ## Technical details ### An introduction to SMT-based model checking An introduction to the model-checking techniques used by *copilot-theorem* can be found in the `doc` folder of this repository. It consists of a self-sufficient set of slides. You can find some additional readings in the *References* section. ### Architecture of copilot-theorem #### An overview of the proving process Each prover first translates the Copilot specification into an intermediate representation best suited for model checking. Two representations are available: * The **IL** format: a Copilot program is translated into a list of quantifier-free equations over integer sequences, implicitly universally quantified by a free variable *n*. Each sequence roughly corresponds to a stream. This format is the one used in G. Hagen's thesis [4]. Several provers work with this format. * The **TransSys** format: a Copilot program is *flattened* and translated into a *state transition system* [1]. Moreover, in order to keep some structure in this representation, the variables of this system are grouped by *nodes*, each node exporting and importing variables. The *Kind2 prover* uses this format, which can be easily translated into the native format. For each of these formats, there is a folder in `src/Copilot/Theorem` which contains at least * `Spec.hs` where the format is defined * `PrettyPrint.hs` for pretty printing (useful for debugging) * `Translate.hs` where the translation process from `Core.Spec` is defined. ##### An example The following program: ```haskell spec = do void $ prop "pos" (forAll $ fib > 0) where fib :: Stream Word64 fib = [1, 1] ++ (fib + drop 1 fib) ``` can be translated into this IL specification: ``` SEQUENCES s0 : Int MODEL INIT s0[0] = 1 s0[1] = 1 MODEL REC s0[n + 2] = s0[n] + s0[n + 1] PROPERTIES 'pos' : s0[n] > 0 ``` or this modular transition system: ``` NODE 's0' DEPENDS ON [] DEFINES out : Int = 1 -> pre out.1 out.1 : Int = 1 -> pre out.2 out.2 : Int = (out) + (out.1) NODE 'prop-pos' DEPENDS ON [s0] IMPORTS (s0 : out) as 's0.out' (s0 : out.1) as 's0.out.1' (s0 : out.2) as 's0.out.2' DEFINES out : Bool = (s0.out) > (0) NODE 'top' DEPENDS ON [prop-pos, s0] IMPORTS (prop-pos : out) as 'pos' (s0 : out) as 's0.out' (s0 : out.1) as 's0.out.1' (s0 : out.2) as 's0.out.2' PROPS 'pos' is (top : pos) ``` Note that the names of the streams are lost in the Copilot *reification process* [7] and so we have no way to keep them. #### Types In these three formats, GADTs are used to statically ensure a part of the type-correctness of the specification, in the same spirit as in other Copilot libraries. *copilot-theorem* works with only three types, `Integer`, `Real` and `Bool`, all of which SMT-Lib can handle. *copilot-theorem* works with *pure* reals and integers. Thus, it is unsafe in the sense it ignores integer overflow problems and the loss of precision due to floating point arithmetic. #### The Kind2 prover The *Kind2 prover* first translates the Copilot specification into a *modular transition system*. Then, a chain of transformations is applied to this system (for instance, in order to remove dependency cycles among nodes). After this, the system is translated into the *Kind2 native format* and the `kind2` executable is launched. The following sections will bring more details about this process. ##### Modular transition systems Let's look at the definition of a *modular transition system*, in the `TransSys.Spec` module: ```haskell type NodeId = String type PropId = String data Spec = Spec { specNodes :: [Node] , specTopNodeId :: NodeId , specProps :: Map PropId ExtVar } data Node = Node { nodeId :: NodeId , nodeDependencies :: [NodeId] , nodeLocalVars :: Map Var LVarDescr , nodeImportedVars :: Bimap Var ExtVar , nodeConstrs :: [Expr Bool] } data Var = Var {varName :: String} deriving (Eq, Show, Ord) data ExtVar = ExtVar {extVarNode :: NodeId, extVarLocalPart :: Var } deriving (Eq, Ord) data VarDescr = forall t . VarDescr { varType :: Type t , varDef :: VarDef t } data VarDef t = Pre t Var | Expr (Expr t) | Constrs [Expr Bool] data Expr t where Const :: Type t -> t -> Expr t Ite :: Type t -> Expr Bool -> Expr t -> Expr t -> Expr t Op1 :: Type t -> Op1 x t -> Expr x -> Expr t Op2 :: Type t -> Op2 x y t -> Expr x -> Expr y -> Expr t VarE :: Type t -> Var -> Expr t ``` A transition system (`Spec` type) is mostly made of a list of nodes. A *node* is just a set of variables living in a local namespace and corresponding to the `Var` type. The `ExtVar` type is used to identify a variable in the global namespace by specifying both a node name and a variable. A node contains two types of variables: * Some variables imported from other nodes. The structure `nodeImportedVars` binds each imported variable to its local name. The set of nodes from which a node imports some variables is stored in the `nodeDependencies` field. * Some locally defined variables contained in the `nodeLocalVars` field. Such a variable can be - Defined as the previous value of another variable (`Pre` constructor of `VarDef`) - Defined by an expression involving other variables (`Expr` constructor) - Defined implicitly by a set of constraints (`Constrs` constructor) ##### The translation process First, a Copilot specification is translated into a modular transition system. This process is defined in the `TransSys.Translate` module. Each stream is associated with a node. The most significant task of this translation process is to *flatten* the Copilot specification so the value of all streams at time *n* only depends on the values of all the streams at time *n - 1*, which is not the case in the `Fib` example shown earlier. This is done by a simple program transformation which turns this: ```haskell fib = [1, 1] ++ (fib + drop 1 fib) ``` into this: ```haskell fib0 = [1] ++ fib1 fib1 = [1] ++ (fib1 + fib0) ``` and then into the node ``` NODE 'fib' DEPENDS ON [] DEFINES out : Int = 1 -> pre out.1 out.1 : Int = 1 -> pre out.2 out.2 : Int = (out) + (out.1) ``` Once again, this flattening process is made easier by the fact that the `++` operator only occurs leftmost in a stream definition after the reification process. ##### Some transformations over modular transition systems The transition system obtained by the `TransSys.Translate` module is perfectly consistent. However, it can't be directly translated into the *Kind2 native file format*. Indeed, it is natural to bind each node to a predicate but the Kind2 file format requires that each predicate only uses previously defined predicates. However, some nodes in our transition system could be mutually recursive. Therefore, the goal of the `removeCycles :: Spec -> Spec` function, defined in `TransSys.Transform`, is to remove such dependency cycles. This function relies on the `mergeNodes :: [NodeId] -> Spec -> Spec` function, whose signature is self-explicit. The latter solves name conflicts by using the `Misc.Renaming` monad. Some code complexity has been added so variable names remain as clear as possible after merging two nodes. The function `removeCycles` computes the strongly connected components of the dependency graph and merge each one into a single node. The complexity of this process is high in the worst case (the square of the total size of the system times the size of the biggest node) but good in practice as few nodes are to be merged in most practical cases. After the cycles have been removed, it is useful to apply another transformation which makes the translation from `TransSys.Spec` to `Kind2.AST` easier. This transformation is implemented in the `complete` function. In a nutshell, it transforms a system such that: * If a node depends on another, it imports *all* its variables. * The dependency graph is transitive, that is if *A* depends of *B* which depends of *C* then *A* depends on *C*. After this transformation, the translation from `TransSys.Spec` to `Kind2.AST` is almost only a matter of syntax. ###### Bonus track Thanks to the `mergeNodes` function, we can get for free the function ```haskell inline :: Spec -> Spec inline spec = mergeNodes [nodeId n | n <- specNodes spec] spec ``` which discards all the structure of a *modular transition system* and turns it into a *non-modular transition system* with only one node. In fact, when translating a Copilot specification to a Kind2 file, two styles are available: the `Kind2.toKind2` function takes a `Style` argument which can take the value `Inlined` or `Modular`. The only difference is that in the first case, a call to `removeCycles` is replaced by a call to `inline`. ### Limitations of copilot-theorem Now, we will discuss some limitations of the *copilot-theorem* tool. These limitations are split into two categories: limitations related to the Copilot language itself and its implementation, and limitations related to the model-checking techniques we are using. #### Limitations related to Copilot implementation The reification process used to build the `Core.Spec` object loses information about the structure of the original Copilot program. In fact, a stream is kept in the reified program only if it is recursively defined. Otherwise, all its occurrences will be inlined. Moreover, let's look at the `intCounter` function defined in the example `Grey.hs`: ```haskell intCounter :: Stream Bool -> Stream Word64 intCounter reset = time where time = if reset then 0 else [0] ++ if time == 3 then 0 else time + 1 ``` If *n* counters are created with this function, the same code will be inlined *n* times and the structure of the original code will be lost. There are many problems with this: * It makes some optimizations of the model-checking based on a static analysis of the program more difficult (for instance *structural abstraction* - see [2]). * It makes the inputs given to the SMT solvers larger and repetitive. We can't rewrite the Copilot reification process in order to avoid these inconveniences as this information is lost by GHC itself before it occurs. The only solution we can see would be to use *Template Haskell* to generate automatically some structural annotations, which might not be worth the dirt introduced. #### Limitations related to the model-checking techniques used ##### Limitations of the IC3 algorithm The IC3 algorithm was shown to be a very powerful tool for hardware certification. However, the problems encountered when verifying software are much more complex. For now, very few non-inductive properties can be proved by *Kind2* when basic integer arithmetic is involved. The critical point of the IC3 algorithm is the counterexample generalization and the lemma tightening parts of it. When encountering a *counterexample to the inductiveness* (CTI) for a property, these techniques are used to find a lemma discarding it which is general enough so that all CTIs can be discarded in a finite number of steps. The lemmas found by the current version of *Kind2* are often too weak. Some suggestions to enhance this are presented in [1]. We hope some progress will be made in this area in the near future. A workaround to this problem would be to write an interactive mode where the user is invited to provide some additional lemmas when automatic techniques fail. Another solution would be to make the properties being checked quasi-inductive by hand. In this case, *copilot-theorem* is still a useful tool (especially for finding bugs) but the verification of a program can be long and requires a high level of technical knowledge. ##### Limitations related to the SMT solvers The use of SMT solvers introduces two kinds of limitations: 1. We are limited by the computing power needed by the SMT solvers 2. SMT solvers can't handle quantifiers efficiently Let's consider the first point. SMT solving is costly and its performances are sometimes unpredictable. For instance, when running the `SerialBoyerMoore` example with the *k-induction prover*, Yices2 does not terminate. However, the *Z3* SMT solver used by *Kind2* solves the problem instantaneously. Note that this performance gap is not due to the use of the IC3 algorithm because the property to check is inductive. It could be related to the fact the SMT problem produced by the *k-induction prover* uses uninterpreted functions for encoding streams instead of simple integer variables, which is the case when the Copilot program is translated into a transition system. However, this wouldn't explain why the *k-induction prover* still terminates instantaneously on the `BoyerMoore` example, which seems not simpler by far. The second point keeps you from expressing or proving some properties universally quantified over a stream or a constant. Sometimes, this is still possible. For instance, in the `Grey` example, as we check a property like `intCounter reset == greyCounter reset` with `reset` an external stream (therefore totally unconstrained), we kind of show a universally quantified property. This fact could be used to enhance the proof scheme system (see the *Future work* section). However, this trick is not always possible. For instance, in the `SerialBoyerMoore` example, the property being checked should be quantified over all integer constants. Here, we can't just introduce an arbitrary constant stream because it is the quantified property that is inductive and not the property specialized for a given constant stream. That's why we have no other solution than replacing universal quantification with *bounded* universal quantification, assuming all the elements of the input stream are in the finite list `allowed` and using the function `forAllCst`: ```haskell conj :: [Stream Bool] -> Stream Bool conj = foldl (&&) true forAllCst ::(Typed a) => [a] -> (Stream a -> Stream Bool) -> Stream Bool forAllCst l f = conj $ map (f . constant) l ``` However, this solution isn't completely satisfying because the size of the property generated is proportional to the length of `allowed`. #### Some scalability issues A standard way to prove large programs is to rely on their logical structure, by writing a specification for each of their functions. This very natural approach is hard to follow in our case due to: * The difficulty to deal with universal quantification. * The lack of *true* functions in Copilot: the latter offers metaprogramming facilities but no concept of functions like *Lustre* does with its *nodes*). * The inlining policy of the reification process. This point is related to the previous one. Once again, *copilot-theorem* is still a very useful tool, especially for debugging purposes. However, we don't think it is adapted to write and check a complete specification for large-scale programs. ## Future work ### Missing features in the Kind2 prover These features are not currently provided due to the lack of important features in the Kind2 SMT solver. #### Displaying counterexamples Counterexamples are not displayed with the Kind2 prover because Kind2 doesn't support XML output of counterexamples. If the last feature is provided, it should be easy to implement displaying of counterexamples in *copilot-theorem*. For this, we recommend keeping some information about *observers* in `TransSys.Spec` and to add one variable per observer in the Kind2 output file. #### Bad handling of non-linear operators and external functions Non-linear Copilot operators and external functions are poorly handled because of the lack of support for uninterpreted functions in the Kind2 native format. A good way to handle these would be to use uninterpreted functions. With this solution, properties like ```haskell 2 * sin x + 1 <= 3 ``` with `x` any stream can't be proven but at least the following can be proved ```haskell let y = x in sin x == sin y ``` Currently, the *Kind2 prover* fails with the last example, as the results of unknown functions are turned into fresh unconstrained variables. ### Simple extensions The following extensions would be really simple to implement given the current architecture of Kind2. + If inductive proving of a property fails, giving the user a concrete CTI (*Counterexample To The Inductiveness*, see [1]). + Use Template Haskell to declare automatically some observers with the same names used in the original program. ### More advanced enhancements + Enhance the proof scheme system such that when proving a property depending on an arbitrary stream, it is possible to assume some specialized versions of this property for given values of the arbitrary stream. In other words, implementing a basic way to deal with universal quantification. + It could be useful to extend the Copilot language in a way it is possible to use annotations inside the Copilot code. For instance, we could - Declare assumptions and invariants next to the associated code instead of gathering all properties in a single place. - Declare a frequent code pattern that can be factorized in the transition problem (see the section about Copilot limitations) ## FAQ ### Why does the code related to transition systems look so complex? It is true that the code of `TransSys` is quite complex. In fact, it would be really straightforward to produce a flattened transition system and then a Kind2 file with just a single *top* predicate. In fact, It would be as easy as producing an *IL* specification. To be honest, I'm not sure producing a modular *Kind2* output is worth the complexity added. It's especially true at the time I write this in the sense that: * Each predicate introduced is used only one time (which is true because Copilot doesn't handle functions or parameterized streams like Lustre does and everything is inlined during the reification process). * A similar form of structure could be obtained from a flattened Kind2 native input file with some basic static analysis by producing a dependency graph between variables. * For now, the *Kind2* model-checker ignores these structures. However, the current code offers some nice transformation tools (node merging, `Renaming` monad...) which could be useful if you intend to write a tool for simplifying or factorizing transition systems. Moreover, it becomes easier to write local transformations on transition systems as name conflicts can be avoided more easily when introducing more variables, as there is one namespace per node. ## References 1. *An insight into SMT-based model checking techniques for formal software verification of synchronous dataflow programs*, talk, Jonathan Laurent (see the `doc` folder of this repository) 2. *Scaling up the formal verification of Lustre programs with SMT-based techniques*, G. Hagen, C. Tinelli 3. *SMT-based Unbounded Model Checking with IC3 and Approximate Quantifier Elimination*, C. Sticksel, C. Tinelli 4. *Verifying safety properties of Lustre programs: an SMT-based approach*, PhD thesis, G. Hagen 5. *Understanding IC3*, Aaron R. Bradley 6. *IC3: Where Monolithic and Incremental Meet*, F. Somenzi, A.R. Bradley 7. *Copilot: Monitoring Embedded Systems*, L. Pike, N. Wegmann, S. Niller copilot-theorem-4.3/LICENSE0000644000000000000000000000263614762717277013720 0ustar00000000000000002009 BSD3 License terms Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. Neither the name of the developers nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. copilot-theorem-4.3/Setup.hs0000644000000000000000000000005614762717277014341 0ustar0000000000000000import Distribution.Simple main = defaultMain copilot-theorem-4.3/CHANGELOG0000644000000000000000000000705714762717277014127 0ustar00000000000000002025-03-07 * Version bump (4.3). (#604) * Fix multiple typos in README. (#560) * Fix typo in documentation. (#587) * Add function to produce counterexamples for invalid properties. (#589) * Reject existentially quantified properties in What4 backend. (#254) 2025-01-07 * Version bump (4.2). (#577) * Remove uses of Copilot.Core.Expr.UExpr.uExprType,uExprExpr. (#565) * Bump upper constraint on containers, data-default. (#570) 2024-11-07 * Version bump (4.1). (#561) * Standardize changelog format. (#550) 2024-09-07 * Version bump (4.0). (#532) * Add support for struct updates in Copilot.Theorem.What4. (#524) * Add support for array updates in Copilot.Theorem.What4. (#36) 2024-07-07 * Version bump (3.20). (#522) * What4 upper-bound dependency version bump. (#514) 2024-05-07 * Version bump (3.19.1). (#512) * Fix handling of unsatisfiable properties with Kind2. (#495) * Remove outdated details from README. (#452) 2024-03-07 * Version bump (3.19). (#504) 2024-01-07 * Version bump (3.18.1). (#493) * Adjust to work with GHC 9.6. (#491) 2024-01-07 * Version bump (3.18). (#487) * Introduce testing infrastructure for Copilot.Theorem.What4. (#474) * Replace uses of forall with forAll. (#470) 2023-11-07 * Version bump (3.17). (#466) * Relax version constraint on what4. (#461) * Replace uses of deprecated functions. (#457) 2023-09-07 * Version bump (3.16.1). (#455) 2023-07-07 * Version bump (3.16). (#448) 2023-05-07 * Version bump (3.15). (#438) 2023-03-07 * Version bump (3.14). (#422) * Adjust contraints on version of what4. (#423) 2023-01-07 * Version bump (3.13). (#406) 2022-11-07 * Version bump (3.12). (#389) * Add functionality for bisimulation proofs of Copilot specifications. (#363) * Use pretty-printer from copilot-prettyprinter. (#383) * Replace uses of Copilot.Core.Type.Equality with definitions from base:Data.Type.Equality. (#379) 2022-09-07 * Version bump (3.11). (#376) 2022-07-07 * Version bump (3.10). (#356) * Remove comment from cabal file. (#325) * Remove unnecessary dependencies from Cabal package. (#326) * Remove duplicated compiler option. (#328) * Relax version bounds of dependencies. (#335) * Include repo info in cabal file. (#333) 2022-05-06 * Version bump (3.9). (#320) * Compliance with style guide (partial). (#316) 2022-03-07 * Version bump (3.8). (#298) * Mark package as uncurated to avoid modification. (#288) 2022-01-07 * Version bump (3.7). (#287) * Relax version contraints on what4. (#277) 2021-11-07 * Version bump (3.6). (#264) * Fix outdated/broken links. (#252) 2021-08-19 * Version bump (3.5). (#247) * Update travis domain in README. (#222) * Remove unused type U2. (#91) * Update official maintainer. (#236, #245) 2021-07-07 * Version bump (3.4). (#231) 2021-05-07 * Version bump (3.3). (#217) * Adjust contraints on version of what4. (#90) 2021-03-07 * Version bump (3.2.1). (#92) * Completed the documentation. (#95, #93) 2020-12-06 * Version bump (3.2). (#65) * Update description, bug-reports and homepage field in cabal file. (#97) 2019-11-22 * Version bump (3.1). (#46) * Remove ExternFun. (#99) copilot-theorem-4.3/copilot-theorem.cabal0000644000000000000000000001216714762717277017011 0ustar0000000000000000cabal-version : >= 1.10 name : copilot-theorem synopsis: k-induction for Copilot. description: Some tools to prove properties on Copilot programs with k-induction model checking. . Copilot is a stream (i.e., infinite lists) domain-specific language (DSL) in Haskell that compiles into embedded C. Copilot contains an interpreter, multiple back-end compilers, and other verification tools. . A tutorial, examples, and other information are available at . version : 4.3 license : BSD3 license-file : LICENSE maintainer : Ivan Perez homepage : https://copilot-language.github.io bug-reports : https://github.com/Copilot-Language/copilot/issues stability : Experimental category : Language, Embedded build-type : Simple extra-source-files : README.md , CHANGELOG author : Jonathan Laurent x-curation: uncurated source-repository head type: git location: https://github.com/Copilot-Language/copilot.git subdir: copilot-theorem library default-language : Haskell2010 hs-source-dirs : src ghc-options : -Wall -fno-warn-name-shadowing -fno-warn-unused-binds -fno-warn-missing-signatures -fcontext-stack=100 build-depends : base >= 4.9 && < 5 , bimap (>= 0.3 && < 0.4) || (>= 0.5 && < 0.6) , bv-sized >= 1.0.2 && < 1.1 , containers >= 0.4 && < 0.8 , data-default >= 0.7 && < 0.9 , directory >= 1.3 && < 1.4 , libBF >= 0.6.2 && < 0.7 , mtl >= 2.0 && < 2.4 , panic >= 0.4.0 && < 0.5 , parsec >= 2.0 && < 3.2 , parameterized-utils >= 2.1.1 && < 2.2 , pretty >= 1.0 && < 1.2 , process >= 1.6 && < 1.7 , random >= 1.1 && < 1.3 , transformers >= 0.5 && < 0.7 , xml >= 1.3 && < 1.4 , what4 >= 1.3 && < 1.7 , copilot-core >= 4.3 && < 4.4 , copilot-prettyprinter >= 4.3 && < 4.4 exposed-modules : Copilot.Theorem , Copilot.Theorem.Prove , Copilot.Theorem.Kind2 , Copilot.Theorem.Prover.SMT -- , Copilot.Theorem.Prover.Z3 , Copilot.Theorem.Kind2.Prover , Copilot.Theorem.What4 other-modules : Copilot.Theorem.Tactics , Copilot.Theorem.IL , Copilot.Theorem.IL.PrettyPrint , Copilot.Theorem.IL.Spec , Copilot.Theorem.IL.Translate , Copilot.Theorem.IL.Transform , Copilot.Theorem.Kind2.AST , Copilot.Theorem.Kind2.Output , Copilot.Theorem.Kind2.PrettyPrint , Copilot.Theorem.Kind2.Translate , Copilot.Theorem.Prover.SMTIO , Copilot.Theorem.Prover.SMTLib , Copilot.Theorem.Prover.TPTP , Copilot.Theorem.Prover.Backend , Copilot.Theorem.Misc.Error , Copilot.Theorem.Misc.SExpr , Copilot.Theorem.Misc.Utils , Copilot.Theorem.TransSys , Copilot.Theorem.TransSys.Cast , Copilot.Theorem.TransSys.PrettyPrint , Copilot.Theorem.TransSys.Renaming , Copilot.Theorem.TransSys.Spec , Copilot.Theorem.TransSys.Transform , Copilot.Theorem.TransSys.Translate , Copilot.Theorem.TransSys.Invariants , Copilot.Theorem.TransSys.Operators , Copilot.Theorem.TransSys.Type , Copilot.Theorem.What4.Translate test-suite unit-tests type: exitcode-stdio-1.0 main-is: Main.hs other-modules: Test.Copilot.Theorem.What4 build-depends: base , HUnit , QuickCheck , test-framework , test-framework-quickcheck2 , copilot-core , copilot-theorem hs-source-dirs: tests default-language: Haskell2010 ghc-options: -Wall copilot-theorem-4.3/tests/0000755000000000000000000000000014762717277014046 5ustar0000000000000000copilot-theorem-4.3/tests/Main.hs0000644000000000000000000000057214762717277015272 0ustar0000000000000000-- | Test copilot-theorem. module Main where -- External imports import Test.Framework (Test, defaultMain) -- Internal imports import qualified Test.Copilot.Theorem.What4 -- | Run all unit tests on copilot-theorem. main :: IO () main = defaultMain tests -- | All unit tests in copilot-theorem. tests :: [Test.Framework.Test] tests = [ Test.Copilot.Theorem.What4.tests ] copilot-theorem-4.3/tests/Test/0000755000000000000000000000000014762717277014765 5ustar0000000000000000copilot-theorem-4.3/tests/Test/Copilot/0000755000000000000000000000000014762717277016376 5ustar0000000000000000copilot-theorem-4.3/tests/Test/Copilot/Theorem/0000755000000000000000000000000014762717277020001 5ustar0000000000000000copilot-theorem-4.3/tests/Test/Copilot/Theorem/What4.hs0000644000000000000000000002520114762717277021324 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -- The following warning is disabled due to a necessary instance of SatResult -- defined in this module. {-# OPTIONS_GHC -fno-warn-orphans #-} -- | Test copilot-theorem:Copilot.Theorem.What4. module Test.Copilot.Theorem.What4 where -- External imports import Control.Exception (Exception, try) import Data.Int (Int8) import Data.Proxy (Proxy (..)) import Data.Typeable (typeRep) import Data.Word (Word32) import Test.Framework (Test, testGroup) import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.HUnit (Assertion, assertBool, assertFailure) import Test.QuickCheck (Arbitrary (arbitrary), Property, arbitrary, forAll) import Test.QuickCheck.Monadic (monadicIO, run) -- External imports: Copilot import Copilot.Core.Expr (Expr (Const, Drop, Op1, Op2), Id) import Copilot.Core.Operators (Op1 (..), Op2 (..)) import Copilot.Core.Spec (Spec (..), Stream (..)) import qualified Copilot.Core.Spec as Copilot import Copilot.Core.Type (Field (..), Struct (toValues, typeName), Type (Struct), Typed (typeOf), Value (..)) -- Internal imports: Modules being tested import Copilot.Theorem.What4 (CounterExample (..), ProveException (..), SatResult (..), SatResultCex (..), Solver (..), prove, proveWithCounterExample) -- * Constants -- | Unit tests for copilot-theorem:Copilot.Theorem.What4. tests :: Test.Framework.Test tests = testGroup "Copilot.Theorem.What4" [ testProperty "Prove via Z3 that true is valid" testProveZ3True , testProperty "Prove via Z3 that false is invalid" testProveZ3False , testProperty "Prove via Z3 that x == x is valid" testProveZ3EqConst , testProperty "Prove via Z3 that a struct update is valid" testProveZ3StructUpdate , testProperty "Counterexample with invalid base case" testCounterExampleBaseCase , testProperty "Counterexample with invalid induction step" testCounterExampleInductionStep , testProperty "Check that the What4 backend rejects existential quantification" testWhat4ExistsException ] -- * Individual tests -- | Test that Z3 is able to prove the following expression valid: -- @ -- constant True -- @ testProveZ3True :: Property testProveZ3True = monadicIO $ run $ checkResult Z3 propName spec Valid where propName :: String propName = "prop" spec :: Spec spec = forallPropSpec propName [] $ Const typeOf True -- | Test that Z3 is able to prove the following expression invalid: -- @ -- constant False -- @ testProveZ3False :: Property testProveZ3False = monadicIO $ run $ checkResult Z3 propName spec Invalid where propName :: String propName = "prop" spec :: Spec spec = forallPropSpec propName [] $ Const typeOf False -- | Test that Z3 is able to prove the following expresion valid: -- @ -- for all (x :: Int8), constant x == constant x -- @ testProveZ3EqConst :: Property testProveZ3EqConst = forAll arbitrary $ \x -> monadicIO $ run $ checkResult Z3 propName (spec x) Valid where propName :: String propName = "prop" spec :: Int8 -> Spec spec x = forallPropSpec propName [] $ Op2 (Eq typeOf) (Const typeOf x) (Const typeOf x) -- | Test that Z3 is able to prove the following expresion valid: -- @ -- for all (s :: MyStruct), -- ((s ## testField =$ (+1)) # testField) == ((s # testField) + 1) -- @ testProveZ3StructUpdate :: Property testProveZ3StructUpdate = forAll arbitrary $ \x -> monadicIO $ run $ checkResult Z3 propName (spec x) Valid where propName :: String propName = "prop" spec :: TestStruct -> Spec spec s = forallPropSpec propName [] $ Op2 (Eq typeOf) (getField (Op2 (UpdateField typeOf typeOf testField) sExpr (add1 (getField sExpr)))) (add1 (getField sExpr)) where sExpr :: Expr TestStruct sExpr = Const typeOf s getField :: Expr TestStruct -> Expr Word32 getField = Op1 (GetField typeOf typeOf testField) add1 :: Expr Word32 -> Expr Word32 add1 x = Op2 (Add typeOf) x (Const typeOf 1) -- | Test that Z3 is able to produce a counterexample to the following property, -- where the base case is proved invalid: -- -- @ -- let s :: Stream Bool -- s = [False] ++ constant True -- in forAll s -- @ testCounterExampleBaseCase :: Property testCounterExampleBaseCase = monadicIO $ run $ checkCounterExample Z3 propName spec $ \cex -> pure $ not $ and $ baseCases cex where propName :: String propName = "prop" -- s = [False] ++ constant True s :: Stream s = Stream { streamId = sId , streamBuffer = [False] , streamExpr = Const typeOf True , streamExprType = typeOf } sId :: Id sId = 0 spec :: Spec spec = forallPropSpec propName [s] $ Drop typeOf 0 sId -- | Test that Z3 is able to produce a counterexample to the following property, -- where the induction step is proved invalid: -- -- @ -- let s :: Stream Bool -- s = [True] ++ constant False -- in forAll s -- @ testCounterExampleInductionStep :: Property testCounterExampleInductionStep = monadicIO $ run $ checkCounterExample Z3 propName spec $ \cex -> pure $ not $ inductionStep cex where propName :: String propName = "prop" -- s = [True] ++ constant False s :: Stream s = Stream { streamId = sId , streamBuffer = [True] , streamExpr = Const typeOf False , streamExprType = typeOf } sId :: Id sId = 0 spec :: Spec spec = forallPropSpec propName [s] $ Drop typeOf 0 sId -- | Test that @copilot-theorem@'s @what4@ backend will throw an exception if it -- attempts to prove an existentially quantified proposition. testWhat4ExistsException :: Property testWhat4ExistsException = monadicIO $ run $ checkException (prove Z3 spec) isUnexpectedExistentialProposition where isUnexpectedExistentialProposition :: ProveException -> Bool isUnexpectedExistentialProposition UnexpectedExistentialProposition = True propName :: String propName = "prop" spec :: Spec spec = existsPropSpec propName [] $ Const typeOf True -- | A simple data type with a 'Struct' instance and a 'Field'. This is only -- used as part of 'testProveZ3StructUpdate'. newtype TestStruct = TestStruct { testField :: Field "testField" Word32 } instance Arbitrary TestStruct where arbitrary = do w32 <- arbitrary return (TestStruct (Field w32)) instance Struct TestStruct where typeName _ = "testStruct" toValues s = [Value typeOf (testField s)] instance Typed TestStruct where typeOf = Struct (TestStruct (Field 0)) -- | Check that the solver's satisfiability result for the given property in -- the given spec matches the expectation. checkResult :: Solver -> String -> Spec -> SatResult -> IO Bool checkResult solver propName spec expectation = do results <- prove solver spec -- Find the satisfiability result for propName. let propResult = lookup propName results -- The following check also works for the case in which the property name -- does not exist in the results, in which case the lookup returns 'Nothing'. return $ propResult == Just expectation -- | Check that the solver produces an invalid result for the given property and -- that the resulting 'CounterExample' satifies the given predicate. checkCounterExample :: Solver -> String -> Spec -> (CounterExample -> IO Bool) -> IO Bool checkCounterExample solver propName spec cexPred = do results <- proveWithCounterExample solver spec -- Find the satisfiability result for propName. If the property name does not -- exist in the results, raise an assertion failure. propResult <- case lookup propName results of Just propResult -> pure propResult Nothing -> assertFailure $ "Could not find property in results: " ++ propName -- Assert that the solver returned an invalid result and pass the -- counterexample to the predicate. If the result is anything other than -- invalid, raise an assertion failure. case propResult of InvalidCex cex -> cexPred cex ValidCex {} -> assertFailure "Expected invalid result, but result was valid" UnknownCex {} -> assertFailure "Expected invalid result, but result was unknown" -- | Check that the given 'IO' action throws a particular exception. This is -- largely taken from the implementation of @shouldThrow@ in -- @hspec-expectations@ (note that this test suite uses @test-framework@ instead -- of @hspec@). checkException :: forall e a. Exception e => IO a -> (e -> Bool) -> Assertion checkException action p = do r <- try action case r of Right _ -> assertFailure $ "did not get expected exception: " ++ exceptionType Left e -> assertBool ("predicate failed on expected exception: " ++ exceptionType ++ "\n" ++ show e) (p e) where -- String representation of the expected exception's type exceptionType = show $ typeRep $ Proxy @e -- * Auxiliary -- | Build a 'Spec' that contains one property with the given name, which -- contains the given streams, and is defined by the given boolean expression, -- which is universally quantified. forallPropSpec :: String -> [Stream] -> Expr Bool -> Spec forallPropSpec propName propStreams propExpr = Spec propStreams [] [] [Copilot.Property propName (Copilot.Forall propExpr)] -- | Build a 'Spec' that contains one property with the given name, which -- contains the given streams, and is defined by the given boolean expression, -- which is existentially quantified. existsPropSpec :: String -> [Stream] -> Expr Bool -> Spec existsPropSpec propName propStreams propExpr = Spec propStreams [] [] [Copilot.Property propName (Copilot.Exists propExpr)] -- | Equality for 'SatResult'. -- -- This is an orphan instance, so we suppress the warning that GHC would -- normally produce with a GHC option at the top. instance Eq SatResult where Valid == Valid = True Invalid == Invalid = True Unknown == Unknown = True _ == _ = False copilot-theorem-4.3/src/0000755000000000000000000000000014762717277013473 5ustar0000000000000000copilot-theorem-4.3/src/Copilot/0000755000000000000000000000000014762717277015104 5ustar0000000000000000copilot-theorem-4.3/src/Copilot/Theorem.hs0000644000000000000000000000127514762717277017050 0ustar0000000000000000{-# LANGUAGE Safe #-} -- | Highly automated proof techniques are a necessary step for the widespread -- adoption of formal methods in the software industry. Moreover, it could -- provide a partial answer to one of its main issue which is scalability. -- -- Copilot-theorem is a Copilot library aimed at checking automatically some -- safety properties on Copilot programs. It includes: -- -- * A prover producing native inputs for the Kind2 model checker. -- -- * A What4 backend that uses SMT solvers to prove safety properties. module Copilot.Theorem ( module X , Proof , PropId, PropRef , Universal, Existential ) where import Copilot.Theorem.Tactics as X import Copilot.Theorem.Prove copilot-theorem-4.3/src/Copilot/Theorem/0000755000000000000000000000000014762717277016507 5ustar0000000000000000copilot-theorem-4.3/src/Copilot/Theorem/IL.hs0000644000000000000000000000120714762717277017347 0ustar0000000000000000{-# LANGUAGE Safe #-} -- | Each prover first translates the Copilot specification into an -- intermediate representation best suited for model checking. -- -- This module and the ones in the same namespace implement the IL format. A -- Copilot program is translated into a list of quantifier-free equations over -- integer sequences, implicitly universally quantified by a free variable n. -- Each sequence roughly corresponds to a stream. module Copilot.Theorem.IL (module X) where import Copilot.Theorem.IL.Spec as X import Copilot.Theorem.IL.Translate as X import Copilot.Theorem.IL.Transform as X import Copilot.Theorem.IL.PrettyPrint as X copilot-theorem-4.3/src/Copilot/Theorem/Prove.hs0000644000000000000000000001476314762717277020151 0ustar0000000000000000{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE Safe #-} {-# LANGUAGE ViewPatterns #-} -- | Connection to theorem provers. module Copilot.Theorem.Prove ( Output (..) , Status (..) , Prover (..) , PropId, PropRef (..) , Proof, UProof, ProofScheme (..) , Action (..) , Universal, Existential , check , prove , combine ) where import qualified Copilot.Core as Core import Data.List (intercalate) import Control.Applicative (liftA2) import Control.Monad (ap, liftM) import Control.Monad.Writer -- | Output produced by a prover, containing the 'Status' of the proof and -- additional information. data Output = Output Status [String] -- | Status returned by a prover when given a specification and a property to -- prove. data Status = Sat | Valid | Invalid | Unknown | Error -- | A connection to a prover able to check the satisfiability of -- specifications. -- -- The most important is `askProver`, which takes 3 arguments : -- -- * The prover descriptor -- -- * A list of properties names which are assumptions -- -- * A properties that have to be deduced from these assumptions data Prover = forall r . Prover { proverName :: String , startProver :: Core.Spec -> IO r , askProver :: r -> [PropId] -> [PropId] -> IO Output , closeProver :: r -> IO () } -- | A unique property identifier type PropId = String -- | Reference to a property. data PropRef a where PropRef :: PropId -> PropRef a -- | Empty datatype to mark proofs of universally quantified predicates. data Universal -- | Empty datatype to mark proofs of existentially quantified predicates. data Existential -- | A proof scheme with unit result. type Proof a = ProofScheme a () -- | A sequence of computations that generate a trace of required prover -- 'Action's. type UProof = Writer [Action] () -- | A proof scheme is a sequence of computations that compute a result and -- generate a trace of required prover 'Action's. data ProofScheme a b where Proof :: Writer [Action] b -> ProofScheme a b instance Functor (ProofScheme a) where fmap = liftM instance Applicative (ProofScheme a) where pure = return (<*>) = ap instance Monad (ProofScheme a) where (Proof p) >>= f = Proof $ p >>= (\a -> case f a of Proof p' -> p') return a = Proof (return a) -- | Prover actions. data Action where Check :: Prover -> Action Assume :: PropId -> Action Admit :: Action -- | Record a requirement for satisfiability checking. check :: Prover -> Proof a check prover = Proof $ tell [Check prover] -- | Try to prove a property in a specification with a given proof scheme. -- -- Return 'True' if a proof of satisfiability or validity is found, false -- otherwise. prove :: Core.Spec -> PropId -> UProof -> IO Bool prove spec propId (execWriter -> actions) = do thms <- processActions [] actions putStr $ "Finished: " ++ propId ++ ": proof " if (elem propId thms) then (putStrLn "checked successfully") else (putStrLn "failed") return $ elem propId thms where processActions context [] = return context processActions context (action:nextActions) = case action of Check (Prover { startProver, askProver, closeProver }) -> do prover <- startProver spec (Output status infos) <- askProver prover context [propId] closeProver prover case status of Sat -> do putStrLn $ propId ++ ": sat " ++ "(" ++ intercalate ", " infos ++ ")" processActions (propId : context) nextActions Valid -> do putStrLn $ propId ++ ": valid " ++ "(" ++ intercalate ", " infos ++ ")" processActions (propId : context) nextActions Invalid -> do putStrLn $ propId ++ ": invalid " ++ "(" ++ intercalate ", " infos ++ ")" processActions context nextActions Error -> do putStrLn $ propId ++ ": error " ++ "(" ++ intercalate ", " infos ++ ")" processActions context nextActions Unknown -> do putStrLn $ propId ++ ": unknown " ++ "(" ++ intercalate ", " infos ++ ")" processActions context nextActions Assume propId' -> do putStrLn $ propId' ++ ": assumption" processActions (propId' : context) nextActions Admit -> do putStrLn $ propId ++ ": admitted" processActions (propId : context) nextActions -- | Combine two provers producing a new prover that will run both provers in -- parallel and combine their outputs. -- -- The results produced by the provers must be consistent. For example, if one -- of the provers indicates that a property is 'Valid' while another indicates -- that it is 'Invalid', the combination of both provers will return an -- 'Error'. combine :: Prover -> Prover -> Prover combine (Prover { proverName = proverNameL , startProver = startProverL , askProver = askProverL , closeProver = closeProverL }) (Prover { proverName = proverNameR , startProver = startProverR , askProver = askProverR , closeProver = closeProverR }) = Prover { proverName = proverNameL ++ "_" ++ proverNameR , startProver = \spec -> do proverL <- startProverL spec proverR <- startProverR spec return (proverL, proverR) , askProver = \(stL, stR) assumptions toCheck -> liftA2 (combineOutputs proverNameL proverNameR) (askProverL stL assumptions toCheck) (askProverR stR assumptions toCheck) , closeProver = \(stL, stR) -> do closeProverL stL closeProverR stR } combineOutputs :: [Char] -> [Char] -> Output -> Output -> Output combineOutputs nameL nameR (Output stL msgL) (Output stR msgR) = Output (combineSt stL stR) infos where combineSt Error _ = Error combineSt _ Error = Error combineSt Valid Invalid = Error combineSt Invalid Valid = Error combineSt Invalid _ = Invalid combineSt _ Invalid = Invalid combineSt Valid _ = Valid combineSt _ Valid = Valid combineSt Sat _ = Sat combineSt _ Sat = Sat combineSt Unknown Unknown = Unknown prefixMsg = case (stL, stR) of (Valid, Invalid) -> ["The two provers don't agree"] _ -> [] decoName s = "<" ++ s ++ ">" infos = prefixMsg ++ [decoName nameL] ++ msgL ++ [decoName nameR] ++ msgR copilot-theorem-4.3/src/Copilot/Theorem/Tactics.hs0000644000000000000000000000110714762717277020434 0ustar0000000000000000{-# LANGUAGE Safe #-} -- | Utility functions to help write proof tactics. module Copilot.Theorem.Tactics ( instantiate, assume, admit ) where import Copilot.Theorem.Prove import Control.Monad.Writer -- | Instantiate a universal proof into an existential proof. instantiate :: Proof Universal -> Proof Existential instantiate (Proof p) = Proof p -- | Assume that a property, given by reference, holds. assume :: PropRef Universal -> Proof a assume (PropRef p) = Proof $ tell [Assume p] -- | Assume that the current goal holds. admit :: Proof a admit = Proof $ tell [Admit] copilot-theorem-4.3/src/Copilot/Theorem/TransSys.hs0000644000000000000000000000146314762717277020635 0ustar0000000000000000{-# LANGUAGE Safe #-} -- | Each prover first translates the Copilot specification into an -- intermediate representation best suited for model checking. -- -- This module and the ones in the same namespace implement the TransSys -- format. A Copilot program is /flattened/ and translated into a /state/ -- /transition system/. In order to keep some structure in this -- representation, the variables of this system are grouped by /nodes/, each -- node exporting and importing variables. The /Kind2 prover/ uses this format, -- which can be easily translated into the native format. module Copilot.Theorem.TransSys (module X) where import Copilot.Theorem.TransSys.Spec as X import Copilot.Theorem.TransSys.PrettyPrint as X import Copilot.Theorem.TransSys.Translate as X import Copilot.Theorem.TransSys.Transform as X copilot-theorem-4.3/src/Copilot/Theorem/What4.hs0000644000000000000000000007565014762717277020047 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} -- | -- Module : Copilot.Theorem.What4 -- Description : Prove spec properties using What4. -- Copyright : (c) Ben Selfridge, 2020 -- Maintainer : benselfridge@galois.com -- Stability : experimental -- Portability : POSIX -- -- Spec properties are translated into the language of SMT solvers using -- @What4@. A backend solver is then used to prove the property is true. The -- technique is sound, but incomplete. If a property is proved true by this -- technique, then it can be guaranteed to be true. However, if a property is -- not proved true, that does not mean it isn't true; the proof may fail because -- the given property is not inductive. -- -- We perform @k@-induction on all the properties in a given specification where -- @k@ is chosen to be the maximum amount of delay on any of the involved -- streams. This is a heuristic choice, but often effective. -- -- The functions in this module are only designed to prove universally -- quantified propositions (i.e., propositions that use @forAll@). Attempting to -- prove an existentially quantified proposition (i.e., propositions that use -- @exists@) will cause a 'UnexpectedExistentialProposition' exception to be -- thrown. module Copilot.Theorem.What4 ( -- * Proving properties about Copilot specifications prove , Solver(..) , SatResult(..) , proveWithCounterExample , SatResultCex(..) , CounterExample(..) , ProveException(..) -- * Bisimulation proofs about @copilot-c99@ code , computeBisimulationProofBundle , BisimulationProofBundle(..) , BisimulationProofState(..) -- * What4 representations of Copilot expressions , XExpr(..) , CopilotValue(..) , StreamOffset(..) ) where import qualified Copilot.Core.Expr as CE import qualified Copilot.Core.Spec as CS import qualified Copilot.Core.Type as CT import qualified Copilot.Core.Type.Array as CTA import qualified What4.Config as WC import qualified What4.Expr.Builder as WB import qualified What4.Expr.GroundEval as WG import qualified What4.Interface as WI import qualified What4.InterpretedFloatingPoint as WFP import qualified What4.Solver as WS import qualified What4.Solver.DReal as WS import Control.Exception (Exception, throw) import Control.Monad (forM) import Control.Monad.State import qualified Data.BitVector.Sized as BV import Data.Foldable (foldrM) import Data.List (genericLength) import qualified Data.Map as Map import Data.Parameterized.Classes (ShowF) import Data.Parameterized.NatRepr import Data.Parameterized.Nonce import Data.Parameterized.Some import qualified Data.Parameterized.Vector as V import GHC.Float (castWord32ToFloat, castWord64ToDouble) import LibBF (BigFloat, bfToDouble, pattern NearEven) import qualified Panic as Panic import Copilot.Theorem.What4.Translate -- 'prove' function -- -- To prove properties of a spec, we translate them into What4 using the TransM -- monad (transformer on top of IO), then negate each property and ask a backend -- solver to produce a model for the negation. -- | No builder state needed. data BuilderState a = EmptyState -- | The solvers supported by the what4 backend. data Solver = CVC4 | DReal | Yices | Z3 -- | The 'prove' function returns results of this form for each property in a -- spec. data SatResult = Valid | Invalid | Unknown deriving Show -- | The 'proveWithCounterExample' function returns results of this form for -- each property in a spec. This is largely the same as 'SatResult', except that -- 'InvalidCex' also records a 'CounterExample'. data SatResultCex = ValidCex | InvalidCex CounterExample | UnknownCex deriving Show -- | Concrete values that cause a property in a Copilot specification to be -- invalid. As a simple example, consider the following spec: -- -- @ -- spec :: Spec -- spec = do -- let s :: Stream Bool -- s = [False] ++ constant True -- void $ prop "should be invalid" (forAll s) -- @ -- -- This defines a stream @s@ where the first value is @False@, but all -- subsequent values are @True@'. This is used in a property that asserts that -- the values in @s@ will be @True@ at all possible time steps. This is clearly -- not true, given that @s@'s first value is @False@. As such, we would expect -- that proving this property would yield an 'InvalidCex' result, where one of -- the base cases would state that the @s@ stream contains a @False@ value. -- -- We can use the 'proveWithCounterExample' function to query an SMT solver to -- compute a counterexample: -- -- @ -- CounterExample -- { 'baseCases' = -- [False] -- , 'inductionStep' = -- True -- , 'concreteExternVars' = -- fromList [] -- , 'concreteStreamValues' = -- fromList -- [ ( (0, 'AbsoluteOffset' 0), False ) -- , ( (0, 'RelativeOffset' 0), False ) -- , ( (0, 'RelativeOffset' 1), True ) -- ] -- } -- @ -- -- Let's go over what this counterexample is saying: -- -- * The 'inductionStep' of the proof is 'True', so that part of the proof was -- successful. On the other hand, the 'baseCases' contain a 'False', so the -- proof was falsified when proving the base cases. (In this case, the list -- has only one element, so there is only a single base case.) -- -- * 'concreteStreamValues' reports the SMT solver's concrete values for each -- stream during relevant parts of the proof as a 'Map.Map'. -- -- The keys of the map are pairs. The first element of the pair is the stream -- 'CE.Id', and in this example, the only 'CE.Id' is @0@, corresponding to the -- stream @s@. The second element is the time offset. An 'AbsoluteOffset' -- indicates an offset starting from the initial time step, and a -- 'RelativeOffset' indicates an offset from an arbitrary point in time. -- 'AbsoluteOffset's are used in the base cases of the proof, and -- 'RelativeOffset's are used in the induction step of the proof. -- -- The part of the map that is most interesting to us is the -- @( (0, 'AbsoluteOffset' 0), False )@ entry, which represents a base case -- where there is a value of @False@ in the stream @s@ during the initial time -- step. Sure enough, this is enough to falsify the property @forAll s@. -- -- * There are no extern streams in this example, so 'concreteExternVars' is -- empty. -- -- We can also see an example of where a proof succeeds in the base cases, but -- fails during the induction step: -- -- @ -- spec :: Spec -- spec = do -- let t :: Stream Bool -- t = [True] ++ constant False -- void $ prop "should also be invalid" (forAll t) -- @ -- -- With the @t@ stream above, the base cases will succeed -- ('proveWithCounterExample' uses @k@-induction with a value of @k == 1@ in -- this example, so there will only be a single base case). On the other hand, -- the induction step will fail, as later values in the stream will be @False@. -- If we try to 'proveWithCounterExample' this property, then it will fail with: -- -- @ -- CounterExample -- { 'baseCases' = -- [True] -- , 'inductionStep' = -- False -- , 'concreteExternVars' = -- fromList [] -- , 'concreteStreamValues' = -- fromList -- [ ( (0, 'AbsoluteOffset' 0), True ) -- , ( (0, 'RelativeOffset' 0), True ) -- , ( (0, 'RelativeOffset' 1), False ) -- ] -- } -- @ -- -- This time, the 'inductionStep' is 'False'. If we look at the -- 'concreteStreamValues', we see the values at @'RelativeOffset' 0@ and -- @'RelativeOffset' 1@ (which are relevant to the induction step) are @True@ -- and @False@, respectively. Since this is a proof by @k@-induction where -- @k == 1@, the fact that the value at @'RelativeOffset 1@ is @False@ indicates -- that the induction step was falsified. -- -- Note that this proof does not say /when/ exactly the time steps at -- @'RelativeOffset' 0@ or @'RelativeOffset' 1@ occur, only that that will occur -- relative to some arbitrary point in time. In this example, they occur -- relative to the initial time step, so @'RelativeOffset' 1@ would occur at the -- second time step overall. In general, however, these time steps may occur far -- in the future, so it is possible that one would need to step through the -- execution of the streams for quite some time before finding the -- counterexample. -- -- Be aware that counterexamples involving struct values are not currently -- supported. data CounterExample = CounterExample { -- | A list of base cases in the proof, where each entry in the list -- corresponds to a particular time step. For instance, the first element -- in the list corresponds to the initial time step, the second element -- in the list corresponds to the second time step, and so on. A 'False' -- entry anywhere in this list will cause the overall proof to be -- 'InvalidCex'. -- -- Because the proof uses @k@-induction, the number of base cases (i.e., -- the number of entries in this list) is equal to the value of @k@, -- which is chosen using heuristics. baseCases :: [Bool] -- | Whether the induction step of the proof was valid or not. That is, -- given an arbitrary time step @n@, if the property is assumed to hold -- at time steps @n@, @n+1@, ..., @n+k@, then this will be @True@ is the -- property can the be proven to hold at time step @n+k+1@ (and 'False' -- otherwise). If this is 'False', then the overall proof will be -- 'InvalidCex'. , inductionStep :: Bool -- | The concrete values in the Copilot specification's extern streams -- that lead to the property being invalid. -- -- Each key in the 'Map.Map' is the 'CE.Name' of an extern stream paired -- with a 'StreamOffset' representing the time step. The key's -- corresponding value is the concrete value of the extern stream at that -- time step. , concreteExternValues :: Map.Map (CE.Name, StreamOffset) (Some CopilotValue) -- | The concrete values in the Copilot specification's streams -- (excluding extern streams) that lead to the property being invalid. -- -- Each key in the 'Map.Map' is the 'CE.Id' of a stream paired with a -- 'StreamOffset' representing the time step. The key's corresponding -- value is the concrete value of the extern stream at that time step. , concreteStreamValues :: Map.Map (CE.Id, StreamOffset) (Some CopilotValue) } deriving Show -- | Exceptions that can arise when attempting a proof. data ProveException = UnexpectedExistentialProposition -- ^ The functions in "Copilot.Theorem.What4" can only prove properties with -- universally quantified propositions. The functions in -- "Copilot.Theorem.What4" will throw this exception if they encounter an -- existentially quantified proposition. deriving Show instance Exception ProveException -- | Attempt to prove all of the properties in a spec via an SMT solver (which -- must be installed locally on the host). Return an association list mapping -- the names of each property to the result returned by the solver. -- -- PRE: All of the properties in the 'CS.Spec' use universally quantified -- propositions. Attempting to supply an existentially quantified proposition -- will cause a 'UnexpectedExistentialProposition' exception to be thrown. prove :: Solver -- ^ Solver to use -> CS.Spec -- ^ Spec -> IO [(CE.Name, SatResult)] prove solver spec = proveInternal solver spec $ \_ _ _ satRes -> case satRes of WS.Sat _ -> pure Invalid WS.Unsat _ -> pure Valid WS.Unknown -> pure Unknown -- | Attempt to prove all of the properties in a spec via an SMT solver (which -- must be installed locally on the host). Return an association list mapping -- the names of each property to the result returned by the solver. -- -- Unlike 'prove', 'proveWithCounterExample' returns a 'SatResultCex'. This -- means that if a result is invalid, then it will include a 'CounterExample' -- which describes the circumstances under which the property was falsified. See -- the Haddocks for 'CounterExample' for more details. -- -- Note that this function does not currently support creating counterexamples -- involving struct values, so attempting to call 'proveWithCounterExample' on a -- specification that uses structs will raise an error. proveWithCounterExample :: Solver -- ^ Solver to use -> CS.Spec -- ^ Spec -> IO [(CE.Name, SatResultCex)] proveWithCounterExample solver spec = proveInternal solver spec $ \baseCases indStep st satRes -> case satRes of WS.Sat ge -> do gBaseCases <- traverse (WG.groundEval ge) baseCases gIndStep <- WG.groundEval ge indStep gExternValues <- traverse (valFromExpr ge) (externVars st) gStreamValues <- traverse (valFromExpr ge) (streamValues st) let cex = CounterExample { baseCases = gBaseCases , inductionStep = gIndStep , concreteExternValues = gExternValues , concreteStreamValues = gStreamValues } pure (InvalidCex cex) WS.Unsat _ -> pure ValidCex WS.Unknown -> pure UnknownCex -- | Attempt to prove all of the properties in a spec via an SMT solver (which -- must be installed locally on the host). For each 'WS.SatResult' returned by -- the solver, pass it to a continuation along with the relevant parts of the -- proof-related state. -- -- This is an internal-only function that is used to power 'prove' and -- 'proveWithCounterExample'. proveInternal :: Solver -- ^ Solver to use -> CS.Spec -- ^ Spec -> (forall sym t st fm . ( sym ~ WB.ExprBuilder t st (WB.Flags fm) , WI.KnownRepr WB.FloatModeRepr fm ) => [WI.Pred sym] -- The proof's base cases -> WI.Pred sym -- The proof's induction step -> TransState sym -- The proof state -> WS.SatResult (WG.GroundEvalFn t) () -- The overall result of the proof -> IO a) -- ^ Continuation to call on each solver result -> IO [(CE.Name, a)] proveInternal solver spec k = do -- Setup symbolic backend Some ng <- newIONonceGenerator sym <- WB.newExprBuilder WB.FloatIEEERepr EmptyState ng -- Solver-specific options case solver of CVC4 -> WC.extendConfig WS.cvc4Options (WI.getConfiguration sym) DReal -> WC.extendConfig WS.drealOptions (WI.getConfiguration sym) Yices -> WC.extendConfig WS.yicesOptions (WI.getConfiguration sym) Z3 -> WC.extendConfig WS.z3Options (WI.getConfiguration sym) -- Compute the maximum amount of delay for any stream in this spec let bufLen (CS.Stream _ buf _ _) = genericLength buf maxBufLen = maximum (0 : (bufLen <$> CS.specStreams spec)) -- This process performs k-induction where we use @k = maxBufLen@. -- The choice for @k@ is heuristic, but often effective. let proveProperties = forM (CS.specProperties spec) $ \pr -> do -- This function only supports universally quantified propositions, so -- throw an exception if we encounter an existentially quantified -- proposition. let prop = case CS.propertyProp pr of CS.Forall p -> p CS.Exists {} -> throw UnexpectedExistentialProposition -- State the base cases for k induction. base_cases <- forM [0 .. maxBufLen - 1] $ \i -> do xe <- translateExpr sym mempty prop (AbsoluteOffset i) case xe of XBool p -> return p _ -> expectedBool "Property" xe -- Translate the induction hypothesis for all values up to maxBufLen in -- the past ind_hyps <- forM [0 .. maxBufLen-1] $ \i -> do xe <- translateExpr sym mempty prop (RelativeOffset i) case xe of XBool hyp -> return hyp _ -> expectedBool "Property" xe -- Translate the predicate for the "current" value ind_goal <- do xe <- translateExpr sym mempty prop (RelativeOffset maxBufLen) case xe of XBool p -> return p _ -> expectedBool "Property" xe -- Compute the predicate (ind_hyps ==> p) ind_case <- liftIO $ foldrM (WI.impliesPred sym) ind_goal ind_hyps -- Compute the conjunction of the base and inductive cases p <- liftIO $ foldrM (WI.andPred sym) ind_case base_cases -- Negate the goals for for SAT search not_p <- liftIO $ WI.notPred sym p let clauses = [not_p] st <- get let k' = k base_cases ind_case st satRes <- case solver of CVC4 -> liftIO $ WS.runCVC4InOverride sym WS.defaultLogData clauses $ \case WS.Sat (ge, _) -> k' (WS.Sat ge) WS.Unsat x -> k' (WS.Unsat x) WS.Unknown -> k' WS.Unknown DReal -> liftIO $ WS.runDRealInOverride sym WS.defaultLogData clauses $ \case WS.Sat (c, m) -> do ge <- WS.getAvgBindings c m k' (WS.Sat ge) WS.Unsat x -> k' (WS.Unsat x) WS.Unknown -> k' WS.Unknown Yices -> liftIO $ WS.runYicesInOverride sym WS.defaultLogData clauses $ \case WS.Sat ge -> k' (WS.Sat ge) WS.Unsat x -> k' (WS.Unsat x) WS.Unknown -> k' WS.Unknown Z3 -> liftIO $ WS.runZ3InOverride sym WS.defaultLogData clauses $ \case WS.Sat (ge, _) -> k' (WS.Sat ge) WS.Unsat x -> k' (WS.Unsat x) WS.Unknown -> k' WS.Unknown pure (CS.propertyName pr, satRes) -- Execute the action and return the results for each property runTransM spec proveProperties -- Bisimulation proofs -- | Given a Copilot specification, compute all of the symbolic states necessary -- to carry out a bisimulation proof that establishes a correspondence between -- the states of the Copilot stream program and the C code that @copilot-c99@ -- would generate for that Copilot program. -- -- PRE: All of the properties in the 'CS.Spec' use universally quantified -- propositions. Attempting to supply an existentially quantified proposition -- will cause a 'UnexpectedExistentialProposition' exception to be thrown. computeBisimulationProofBundle :: WFP.IsInterpretedFloatSymExprBuilder sym => sym -> [String] -- ^ Names of properties to assume during verification -> CS.Spec -- ^ The input Copilot specification -> IO (BisimulationProofBundle sym) computeBisimulationProofBundle sym properties spec = do iss <- computeInitialStreamState sym spec runTransM spec $ do prestate <- computePrestate sym spec poststate <- computePoststate sym spec triggers <- computeTriggerState sym spec assms <- computeAssumptions sym properties spec externs <- computeExternalInputs sym sideCnds <- gets sidePreds return BisimulationProofBundle { initialStreamState = iss , preStreamState = prestate , postStreamState = poststate , externalInputs = externs , triggerState = triggers , assumptions = assms , sideConds = sideCnds } -- | A collection of all of the symbolic states necessary to carry out a -- bisimulation proof. data BisimulationProofBundle sym = BisimulationProofBundle { initialStreamState :: BisimulationProofState sym -- ^ The state of the global variables at program startup , preStreamState :: BisimulationProofState sym -- ^ The stream state prior to invoking the step function , postStreamState :: BisimulationProofState sym -- ^ The stream state after invoking the step function , externalInputs :: [(CE.Name, Some CT.Type, XExpr sym)] -- ^ A list of external streams, where each tuple contains: -- -- 1. The name of the stream -- -- 2. The type of the stream -- -- 3. The value of the stream represented as a fresh constant , triggerState :: [(CE.Name, WI.Pred sym, [(Some CT.Type, XExpr sym)])] -- ^ A list of trigger functions, where each tuple contains: -- -- 1. The name of the function -- -- 2. A formula representing the guarded condition -- -- 3. The arguments to the function, where each argument is represented as -- a type-value pair , assumptions :: [WI.Pred sym] -- ^ User-provided property assumptions , sideConds :: [WI.Pred sym] -- ^ Side conditions related to partial operations } -- | The state of a bisimulation proof at a particular step. newtype BisimulationProofState sym = BisimulationProofState { streamState :: [(CE.Id, Some CT.Type, [XExpr sym])] -- ^ A list of tuples containing: -- -- 1. The name of a stream -- -- 2. The type of the stream -- -- 3. The list of values in the stream description } -- | Compute the initial state of the global variables at the start of a Copilot -- program. computeInitialStreamState :: WFP.IsInterpretedFloatSymExprBuilder sym => sym -> CS.Spec -- ^ The input Copilot specification -> IO (BisimulationProofState sym) computeInitialStreamState sym spec = do xs <- forM (CS.specStreams spec) $ \CS.Stream { CS.streamId = nm, CS.streamExprType = tp , CS.streamBuffer = buf } -> do vs <- mapM (translateConstExpr sym tp) buf return (nm, Some tp, vs) return (BisimulationProofState xs) -- | Compute the stream state of a Copilot program prior to invoking the step -- function. computePrestate :: WFP.IsInterpretedFloatSymExprBuilder sym => sym -> CS.Spec -- ^ The input Copilot specification -> TransM sym (BisimulationProofState sym) computePrestate sym spec = do xs <- forM (CS.specStreams spec) $ \CS.Stream { CS.streamId = nm, CS.streamExprType = tp , CS.streamBuffer = buf } -> do let buflen = genericLength buf let idxes = RelativeOffset <$> [0 .. buflen-1] vs <- mapM (getStreamValue sym nm) idxes return (nm, Some tp, vs) return (BisimulationProofState xs) -- | Compute ehe stream state of a Copilot program after invoking the step -- function. computePoststate :: WFP.IsInterpretedFloatSymExprBuilder sym => sym -> CS.Spec -- ^ The input Copilot specification -> TransM sym (BisimulationProofState sym) computePoststate sym spec = do xs <- forM (CS.specStreams spec) $ \CS.Stream { CS.streamId = nm, CS.streamExprType = tp , CS.streamBuffer = buf } -> do let buflen = genericLength buf let idxes = RelativeOffset <$> [1 .. buflen] vs <- mapM (getStreamValue sym nm) idxes return (nm, Some tp, vs) return (BisimulationProofState xs) -- | Compute the trigger functions in a Copilot program. computeTriggerState :: WFP.IsInterpretedFloatSymExprBuilder sym => sym -> CS.Spec -- ^ The input Copilot specification -> TransM sym [(CE.Name, WI.Pred sym, [(Some CT.Type, XExpr sym)])] computeTriggerState sym spec = forM (CS.specTriggers spec) $ \(CS.Trigger { CS.triggerName = nm, CS.triggerGuard = guard , CS.triggerArgs = args }) -> do xguard <- translateExpr sym mempty guard (RelativeOffset 0) guard' <- case xguard of XBool guard' -> return guard' _ -> expectedBool "Trigger guard" xguard args' <- mapM computeArg args return (nm, guard', args') where computeArg (CE.UExpr tp ex) = do v <- translateExpr sym mempty ex (RelativeOffset 0) return (Some tp, v) -- | Compute the values of the external streams in a Copilot program, where each -- external stream is represented as a fresh constant. computeExternalInputs :: WFP.IsInterpretedFloatSymExprBuilder sym => sym -> TransM sym [(CE.Name, Some CT.Type, XExpr sym)] computeExternalInputs sym = do exts <- Map.toList <$> gets mentionedExternals forM exts $ \(nm, Some tp) -> do v <- getExternConstant sym tp nm (RelativeOffset 0) return (nm, Some tp, v) -- | Compute the user-provided property assumptions in a Copilot program. -- -- PRE: All of the properties in the 'CS.Spec' use universally quantified -- propositions. Attempting to supply an existentially quantified proposition -- will cause a 'UnexpectedExistentialProposition' exception to be thrown. computeAssumptions :: forall sym. WFP.IsInterpretedFloatSymExprBuilder sym => sym -> [String] -- ^ Names of properties to assume during verification -> CS.Spec -- ^ The input Copilot specification -> TransM sym [WI.Pred sym] computeAssumptions sym properties spec = concat <$> forM specPropertyExprs computeAssumption where bufLen (CS.Stream _ buf _ _) = genericLength buf maxBufLen = maximum (0 : (bufLen <$> CS.specStreams spec)) -- Retrieve the boolean-values Copilot expressions corresponding to the -- user-provided property assumptions. specPropertyExprs :: [CE.Expr Bool] specPropertyExprs = [ CS.extractProp (CS.propertyProp p) | p <- CS.specProperties spec , elem (CS.propertyName p) properties , let prop = case CS.propertyProp p of CS.Forall pr -> pr CS.Exists {} -> throw UnexpectedExistentialProposition ] -- Compute all of the what4 predicates corresponding to each user-provided -- property assumption. computeAssumption :: CE.Expr Bool -> TransM sym [WI.Pred sym] computeAssumption e = forM [0 .. maxBufLen] $ \i -> do xe <- translateExpr sym mempty e (RelativeOffset i) case xe of XBool b -> return b _ -> expectedBool "Property" xe -- * Auxiliary functions -- | A catch-all 'panic' to use when an 'XExpr' is is expected to uphold the -- invariant that it is an 'XBool', but the invariant is violated. expectedBool :: forall m sym a. (Panic.HasCallStack, MonadIO m, WI.IsExprBuilder sym) => String -- ^ What the 'XExpr' represents -> XExpr sym -> m a expectedBool what xe = panic [what ++ " expected to have boolean result", show xe] -- | A Copilot value paired with its 'CT.Type'. data CopilotValue a where CopilotValue :: CT.Typed a => CT.Type a -> a -> CopilotValue a instance Show (CopilotValue a) where showsPrec p (CopilotValue ty val) = case ty of CT.Bool -> showsPrec p val CT.Int8 -> showsPrec p val CT.Int16 -> showsPrec p val CT.Int32 -> showsPrec p val CT.Int64 -> showsPrec p val CT.Word8 -> showsPrec p val CT.Word16 -> showsPrec p val CT.Word32 -> showsPrec p val CT.Word64 -> showsPrec p val CT.Float -> showsPrec p val CT.Double -> showsPrec p val CT.Array {} -> showsPrec p val CT.Struct {} -> showsPrec p val instance ShowF CopilotValue -- | Convert a symbolic 'XExpr' into a concrete 'CopilotValue'. -- -- Struct values are not currently supported, so attempting to convert an -- 'XStruct' value will raise an error. valFromExpr :: forall sym t st fm. ( sym ~ WB.ExprBuilder t st (WB.Flags fm) , WI.KnownRepr WB.FloatModeRepr fm ) => WG.GroundEvalFn t -> XExpr sym -> IO (Some CopilotValue) valFromExpr ge xe = case xe of XBool e -> Some . CopilotValue CT.Bool <$> WG.groundEval ge e XInt8 e -> Some . CopilotValue CT.Int8 . fromBV <$> WG.groundEval ge e XInt16 e -> Some . CopilotValue CT.Int16 . fromBV <$> WG.groundEval ge e XInt32 e -> Some . CopilotValue CT.Int32 . fromBV <$> WG.groundEval ge e XInt64 e -> Some . CopilotValue CT.Int64 . fromBV <$> WG.groundEval ge e XWord8 e -> Some . CopilotValue CT.Word8 . fromBV <$> WG.groundEval ge e XWord16 e -> Some . CopilotValue CT.Word16 . fromBV <$> WG.groundEval ge e XWord32 e -> Some . CopilotValue CT.Word32 . fromBV <$> WG.groundEval ge e XWord64 e -> Some . CopilotValue CT.Word64 . fromBV <$> WG.groundEval ge e XFloat e -> Some . CopilotValue CT.Float <$> iFloatGroundEval WFP.SingleFloatRepr e (realToFrac . fst . bfToDouble NearEven) fromRational (castWord32ToFloat . fromInteger . BV.asUnsigned) XDouble e -> Some . CopilotValue CT.Double <$> iFloatGroundEval WFP.DoubleFloatRepr e (fst . bfToDouble NearEven) fromRational (castWord64ToDouble . fromInteger . BV.asUnsigned) XEmptyArray tp -> pure $ Some $ CopilotValue (CT.Array @0 tp) (CTA.array []) XArray es -> do (someCVs :: V.Vector n (Some CopilotValue)) <- traverse (valFromExpr ge) es (Some (CopilotValue headTp _headVal), _) <- pure $ V.uncons someCVs cvs <- traverse (\(Some (CopilotValue tp val)) -> case tp `testEquality` headTp of Just Refl -> pure val Nothing -> panic [ "XArray with mismatched element types" , show tp , show headTp ]) someCVs pure $ Some $ CopilotValue (CT.Array @n headTp) (CTA.array (V.toList cvs)) XStruct _ -> error "valFromExpr: Structs not currently handled" where fromBV :: forall a w . Num a => BV.BV w -> a fromBV = fromInteger . BV.asUnsigned -- Evaluate a (possibly symbolic) floating-point value to a concrete result. -- Depending on which @what4@ floating-point mode is in use, the result will -- be passed to one of three different continuation arguments. iFloatGroundEval :: forall fi r. WFP.FloatInfoRepr fi -> WI.SymExpr sym (WFP.SymInterpretedFloatType sym fi) -> (BigFloat -> r) -> -- ^ Continuation to use if the IEEE floating-point mode is in use. (Rational -> r) -> -- ^ Continuation to use if the real floating-point mode is in use. (forall w. BV.BV w -> r) -> -- ^ Continuation to use if the uninterpreted floating-point mode is in -- use. IO r iFloatGroundEval _ e ieeeK realK uninterpK = case WI.knownRepr :: WB.FloatModeRepr fm of WB.FloatIEEERepr -> ieeeK <$> WG.groundEval ge e WB.FloatRealRepr -> realK <$> WG.groundEval ge e WB.FloatUninterpretedRepr -> uninterpK <$> WG.groundEval ge e copilot-theorem-4.3/src/Copilot/Theorem/Kind2.hs0000644000000000000000000000052414762717277020013 0ustar0000000000000000{-# LANGUAGE Safe #-} -- | Copilot backend for the SMT -- based model checker. module Copilot.Theorem.Kind2 (module X) where import Copilot.Theorem.Kind2.AST as X import Copilot.Theorem.Kind2.Translate as X import Copilot.Theorem.Kind2.PrettyPrint as X import Copilot.Theorem.Kind2.Prover as X copilot-theorem-4.3/src/Copilot/Theorem/TransSys/0000755000000000000000000000000014762717277020275 5ustar0000000000000000copilot-theorem-4.3/src/Copilot/Theorem/TransSys/Transform.hs0000644000000000000000000002245514762717277022614 0ustar0000000000000000{-# LANGUAGE RankNTypes #-} {-# LANGUAGE Safe #-} -- | Helper module to manipulate and simplify TransSys graphs. module Copilot.Theorem.TransSys.Transform ( mergeNodes , inline , removeCycles , complete ) where import Copilot.Theorem.TransSys.Spec import Copilot.Theorem.TransSys.Renaming import Copilot.Theorem.Misc.Utils import Control.Monad (foldM, forM_, forM, guard) import Data.List (sort, (\\), intercalate, partition) import Control.Exception.Base (assert) import Data.Map (Map, (!)) import Data.Set (member) import Data.Bimap (Bimap) import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.Graph as Graph import qualified Data.Bimap as Bimap prefix :: String -> Var -> Var prefix s1 (Var s2) = Var $ s1 ++ "." ++ s2 ncNodeIdSep = "-" -- | Merge all the given nodes, replacing all references to the given node Ids -- with a reference to a fresh node id (unless the nodes given as argument -- contain the top node), in which case its ID is chosen instead. mergeNodes :: [NodeId] -> TransSys -> TransSys mergeNodes toMergeIds spec = spec { specNodes = newNode : map (updateOtherNode newNodeId toMergeIds renamingExtF) otherNodes , specProps = Map.map renamingExtF (specProps spec) } where nodes = specNodes spec (toMerge, otherNodes) = partition ((`elem` toMergeIds) . nodeId) nodes -- Choosing the new node ID. If the top node is merged, -- its name is kept newNodeId | specTopNodeId spec `elem` toMergeIds = specTopNodeId spec | otherwise = intercalate ncNodeIdSep (sort toMergeIds) newNode = Node { nodeId = newNodeId , nodeDependencies = dependencies , nodeImportedVars = importedVars , nodeLocalVars = localVars , nodeConstrs = constrs } -- Computing the dependencies of the new node dependencies = nub' [ id | n <- toMerge , id <- nodeDependencies n , id `notElem` toMergeIds ] -- All the work of renaming is done in the 'Misc.Renaming' monad. Some code -- complexity has been added so the variable names remains as clear as -- possible after merging two nodes. (importedVars, renamingF) = runRenaming $ do renameLocalVars toMerge redirectLocalImports toMerge selectImportedVars toMerge otherNodes dependencies -- Converting the variables descriptors localVars = mergeVarsDescrs toMerge renamingF -- Computing the global renaming function renamingExtF (gv@(ExtVar nId _)) | nId `elem` toMergeIds = ExtVar newNodeId (renamingF gv) | otherwise = gv constrs = mergeConstrs toMerge renamingF updateOtherNode :: NodeId -> [NodeId] -> (ExtVar -> ExtVar) -> Node -> Node updateOtherNode newNodeId mergedNodesIds renamingF n = n { nodeDependencies = let ds = nodeDependencies n ds' = ds \\ mergedNodesIds in if length ds' < length ds then newNodeId : ds' else ds , nodeImportedVars = Bimap.fromList [ (lv, renamingF gv) | (lv, gv) <- Bimap.toList $ nodeImportedVars n ] } updateExpr :: NodeId -> (ExtVar -> Var) -> Expr t -> Expr t updateExpr nId renamingF = transformExpr aux where aux :: forall t. Expr t -> Expr t aux (VarE t v) = VarE t (renamingF (ExtVar nId v)) aux e = e mergeVarsDescrs :: [Node] -> (ExtVar -> Var) -> Map Var VarDescr mergeVarsDescrs toMerge renamingF = Map.fromList $ do n <- toMerge let nId = nodeId n (v, VarDescr t def) <- Map.toList $ nodeLocalVars n let d' = case def of Pre val v' -> VarDescr t $ Pre val $ renamingF (ExtVar nId v') Expr e -> VarDescr t $ Expr $ updateExpr nId renamingF e Constrs cs -> VarDescr t $ Constrs $ map (updateExpr nId renamingF) cs return (renamingF $ ExtVar nId v, d') mergeConstrs :: [Node] -> (ExtVar -> Var) -> [Expr Bool] mergeConstrs toMerge renamingF = [ updateExpr (nodeId n) renamingF c | n <- toMerge, c <- nodeConstrs n ] renameLocalVars :: [Node] -> Renaming () renameLocalVars toMerge = forM_ niVars $ \(n, v) -> do v' <- getFreshName [n `prefix` v] rename n v v' where niVars = [ (nodeId n, v) | n <- toMerge, (v, _) <- Map.toList (nodeLocalVars n) ] selectImportedVars :: [Node] -> [Node] -> [NodeId] -> Renaming (Bimap Var ExtVar) selectImportedVars toMerge otherNodes dependencies = foldM checkImport Bimap.empty depsVars where otherNodesMap = Map.fromList [(nodeId n, n) | n <- otherNodes] depsVars = [ (nId, v) | nId <- dependencies, let n = otherNodesMap ! nId , v <- Map.keys (nodeLocalVars n)] checkImport acc (nId, v) = do v' <- getFreshName [nId `prefix` v] bmap <- forM toMerge $ \n' -> case Bimap.lookupR (ExtVar nId v) (nodeImportedVars n') of Just lv -> rename (nodeId n') lv v' >> return True Nothing -> return False return $ if True `elem` bmap then Bimap.insert v' (ExtVar nId v) acc else acc redirectLocalImports :: [Node] -> Renaming () redirectLocalImports toMerge = do renamingF <- getRenamingF forM_ x $ \(n, alias, n', v) -> rename n alias (renamingF (ExtVar n' v)) where mergedNodesSet = Set.fromList [nodeId n | n <- toMerge] x = do n <- toMerge let nId = nodeId n (alias, ExtVar n' v) <- Bimap.toList (nodeImportedVars n) guard $ n' `member` mergedNodesSet return (nId, alias, n', v) -- | Discard all the structure of a /modular transition system/ and turn it -- into a /non-modular transition system/ with only one node. inline :: TransSys -> TransSys inline spec = mergeNodes [nodeId n | n <- specNodes spec] spec -- | Remove cycles by merging nodes participating in strongly connected -- components. -- -- The transition system obtained by the 'TransSys.Translate' module is -- perfectly consistent. However, it can't be directly translated into the -- /Kind2 native file format/. Indeed, it is natural to bind each node to a -- predicate but the Kind2 file format requires that each predicate only uses -- previously defined predicates. However, some nodes in our transition system -- could be mutually recursive. Therefore, the goal of 'removeCycles' is to -- remove such dependency cycles. -- -- The function 'removeCycles' computes the strongly connected components of -- the dependency graph and merge each one into a single node using -- 'mergeNodes'. The complexity of this process is high in the worst case (the -- square of the total size of the system times the size of the biggest node) -- but good in practice as few nodes are to be merged in most practical cases. removeCycles :: TransSys -> TransSys removeCycles spec = topoSort $ foldr mergeComp spec (buildScc nodeId $ specNodes spec) where mergeComp (Graph.AcyclicSCC _) s = s mergeComp (Graph.CyclicSCC ids) s = mergeNodes ids s buildScc nrep ns = let depGraph = map (\n -> (nrep n, nodeId n, nodeDependencies n)) ns in Graph.stronglyConnComp depGraph topoSort s = s { specNodes = map (\(Graph.AcyclicSCC n) -> n) $ buildScc id (specNodes s) } -- | Completes each node of a specification with imported variables such that -- each node contains a copy of all its dependencies. -- -- The given specification should have its node sorted by topological order. -- -- The top nodes should have all the other nodes as its dependencies. complete :: TransSys -> TransSys complete spec = assert (isTopologicallySorted spec) $ spec { specNodes = specNodes' } where specNodes' = reverse . foldl completeNode [] . specNodes . completeTopNodeDeps $ spec completeTopNodeDeps spec = spec { specNodes = map aux nodes } where nodes = specNodes spec aux n | nodeId n == specTopNodeId spec = n { nodeDependencies = map nodeId nodes \\ [nodeId n] } | otherwise = n -- Takes a list of nodes 'ns', 'n' whose dependencies are in 'ns', and -- returns 'n2:ns' where 'n2' is 'n' completed completeNode :: [Node] -> Node -> [Node] completeNode ns n = (n { nodeDependencies = dependencies' , nodeImportedVars = importedVars' }) : ns where nsMap = Map.fromList [(nodeId n, n) | n <- ns] dependencies' = let newDeps = do dId <- nodeDependencies n let d = nsMap ! dId nodeDependencies d in nub' $ nodeDependencies n ++ newDeps importedVars' = fst . runRenaming $ do forM_ (Set.toList $ nodeVarsSet n) addReservedName let toImportVars = nub' [ ExtVar nId v | nId <- dependencies' , let n' = nsMap ! nId , v <- Map.keys (nodeLocalVars n') ] tryImport acc ev@(ExtVar n' v) = do -- To get readable names, we don't prefix variables -- which come from merged nodes as they are already -- decorated let preferedName | head ncNodeIdSep `elem` n' = v | otherwise = n' `prefix` v alias <- getFreshName [preferedName, n' `prefix` v] return $ Bimap.tryInsert alias ev acc foldM tryImport (nodeImportedVars n) toImportVars copilot-theorem-4.3/src/Copilot/Theorem/TransSys/PrettyPrint.hs0000644000000000000000000000573714762717277023151 0ustar0000000000000000{-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE Safe #-} -- | Pretty print a TransSys specification as a Kind2/Lustre specification. module Copilot.Theorem.TransSys.PrettyPrint ( prettyPrint ) where import Copilot.Theorem.TransSys.Spec import Text.PrettyPrint.HughesPJ import qualified Data.Map as Map import qualified Data.Bimap as Bimap import Prelude hiding ((<>)) indent = nest 4 emptyLine = text "" -- | Pretty print a TransSys specification as a Kind2/Lustre specification. prettyPrint :: TransSys -> String prettyPrint = render . pSpec pSpec :: TransSys -> Doc pSpec spec = items $$ props where items = foldr (($$) . pNode) empty (specNodes spec) props = text "PROPS" $$ Map.foldrWithKey (\k -> ($$) . pProp k) empty (specProps spec) pProp pId extvar = quotes (text pId) <+> text "is" <+> pExtVar extvar pType :: Type t -> Doc pType = text . show pList :: (t -> Doc) -> [t] -> Doc pList f l = brackets (hcat . punctuate (comma <> space) $ map f l) pNode :: Node -> Doc pNode n = header $$ imported $$ local $$ constrs $$ emptyLine where header = text "NODE" <+> quotes (text $ nodeId n) <+> text "DEPENDS ON" <+> pList text (nodeDependencies n) imported | Bimap.null (nodeImportedVars n) = empty | otherwise = text "IMPORTS" $$ indent (Map.foldrWithKey (\k -> ($$) . pIVar k) empty (Bimap.toMap $ nodeImportedVars n)) local | Map.null (nodeLocalVars n) = empty | otherwise = text "DEFINES" $$ indent (Map.foldrWithKey (\k -> ($$) . pLVar k) empty (nodeLocalVars n)) constrs = case nodeConstrs n of [] -> empty l -> text "WITH CONSTRAINTS" $$ foldr (($$) . pExpr) empty l pConst :: Type t -> t -> Doc pConst Integer v = text $ show v pConst Real v = text $ show v pConst Bool v = text $ show v pExtVar :: ExtVar -> Doc pExtVar (ExtVar n v) = parens (text n <+> text ":" <+> text (varName v)) pIVar :: Var -> ExtVar -> Doc pIVar v ev = pExtVar ev <+> text "as" <+> quotes (text (varName v)) pLVar :: Var -> VarDescr -> Doc pLVar l (VarDescr {varType, varDef}) = header $$ indent body where header = text (varName l) <+> text ":" <+> pType varType <+> text "=" body = case varDef of Pre val var -> pConst varType val <+> text "->" <+> text "pre" <+> text (varName var) Expr e -> pExpr e Constrs cs -> text "{" <+> (hsep . punctuate (space <> text ";" <> space)) (map pExpr cs) <+> text "}" pExpr :: Expr t -> Doc pExpr (Const t v) = pConst t v pExpr (Ite _ c e1 e2) = text "if" <+> pExpr c <+> text "then" <+> pExpr e1 <+> text "else" <+> pExpr e2 pExpr (Op1 _ op e) = pOp1 op <+> parens (pExpr e) pExpr (Op2 _ op e1 e2) = parens (pExpr e1) <+> pOp2 op <+> parens (pExpr e2) pExpr (VarE _ v) = text (varName v) pOp1 :: Op1 a -> Doc pOp1 = text . show pOp2 :: Op2 a b -> Doc pOp2 = text . show copilot-theorem-4.3/src/Copilot/Theorem/TransSys/Translate.hs0000644000000000000000000002041514762717277022570 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE Safe #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} -- | Translate Copilot specifications into a modular transition system. -- -- Each stream is associated to a node. The most significant task of this -- translation process is to /flatten/ the copilot specification so the value -- of all streams at time @n@ only depends on the values of all the streams at -- time @n - 1@. For example, for the following Fibonacci implementation in -- Copilot: -- -- @ -- fib = [1, 1] ++ (fib + drop 1 fib) -- @ -- -- the translation, converts it into: -- -- @ -- fib0 = [1] ++ fib1 -- fib1 = [1] ++ (fib1 + fib0) -- @ -- -- and then into the node: -- -- @ -- NODE 'fib' DEPENDS ON [] -- DEFINES -- out : Int = -- 1 -> pre out.1 -- out.1 : Int = -- 1 -> pre out.2 -- out.2 : Int = -- (out) + (out.1) -- @ -- -- This flattening process is made easier by the fact that the @++@ Copilot -- operator only occurs leftmost in a stream definition after the reification -- process. module Copilot.Theorem.TransSys.Translate ( translate ) where import Copilot.Theorem.TransSys.Spec import Copilot.Theorem.TransSys.Cast import Copilot.Theorem.Misc.Utils import Control.Monad (liftM, liftM2, unless) import Control.Monad.State.Lazy import Data.Char (isNumber) import Data.Function (on) import Data.Map (Map) import Data.Bimap (Bimap) import qualified Copilot.Core as C import qualified Data.Map as Map import qualified Data.Bimap as Bimap -- Naming conventions -- These are important in order to avoid name conflicts ncSep = "." ncMain = "out" ncNode i = "s" ++ show i ncPropNode s = "prop-" ++ s ncTopNode = "top" ncAnonInput = "in" ncLocal s = "l" ++ dropWhile (not . isNumber) s ncExternVarNode name = "ext-" ++ name ncImported :: NodeId -> String -> String ncImported n s = n ++ ncSep ++ s ncTimeAnnot :: String -> Int -> String ncTimeAnnot s d | d == 0 = s | otherwise = s ++ ncSep ++ show d -- | Translate Copilot specifications into a modular transition system. translate :: C.Spec -> TransSys translate cspec = TransSys { specNodes = [topNode] ++ modelNodes ++ propNodes ++ extVarNodes , specTopNodeId = topNodeId , specProps = propBindings } where topNodeId = ncTopNode cprops :: [C.Property] cprops = C.specProperties cspec propBindings :: Map PropId ExtVar propBindings = Map.fromList $ do pid <- map C.propertyName cprops return (pid, mkExtVar topNodeId pid) ((modelNodes, propNodes), extvarNodesNames) = runTrans $ liftM2 (,) (mapM stream (C.specStreams cspec)) (mkPropNodes cprops) topNode = mkTopNode topNodeId (map nodeId propNodes) cprops extVarNodes = map mkExtVarNode extvarNodesNames mkTopNode :: String -> [NodeId] -> [C.Property] -> Node mkTopNode topNodeId dependencies cprops = Node { nodeId = topNodeId , nodeDependencies = dependencies , nodeLocalVars = Map.empty , nodeImportedVars = importedVars , nodeConstrs = []} where importedVars = Bimap.fromList [ (Var cp, mkExtVar (ncPropNode cp) ncMain) | cp <- C.propertyName <$> cprops ] mkExtVarNode (name, U t) = Node { nodeId = name , nodeDependencies = [] , nodeLocalVars = Map.singleton (Var ncMain) (VarDescr t $ Constrs []) , nodeImportedVars = Bimap.empty , nodeConstrs = []} mkPropNodes :: [C.Property] -> Trans [Node] mkPropNodes = mapM propNode where propNode p = do s <- stream (streamOfProp p) return $ s {nodeId = ncPropNode (C.propertyName p)} -- A dummy ID is given to this stream, which is not a problem -- because this ID will never be used streamOfProp :: C.Property -> C.Stream streamOfProp prop = C.Stream { C.streamId = 42 , C.streamBuffer = [] , C.streamExpr = C.extractProp (C.propertyProp prop) , C.streamExprType = C.Bool } stream :: C.Stream -> Trans Node stream (C.Stream { C.streamId , C.streamBuffer , C.streamExpr , C.streamExprType }) = casting streamExprType $ \t -> do let nodeId = ncNode streamId outvar i = Var (ncMain `ncTimeAnnot` i) buf = map (cast t . toDyn) streamBuffer (e, nodeAuxVars, nodeImportedVars, nodeDependencies) <- runExprTrans t nodeId streamExpr let outputLocals = let from i [] = Map.singleton (outvar i) (VarDescr t $ Expr e) from i (b : bs) = Map.insert (outvar i) (VarDescr t $ Pre b $ outvar (i + 1)) $ from (i + 1) bs in from 0 buf nodeLocalVars = Map.union nodeAuxVars outputLocals nodeOutputs = map outvar [0 .. length buf - 1] return Node { nodeId, nodeDependencies, nodeLocalVars , nodeImportedVars, nodeConstrs = [] } expr :: Type t -> C.Expr t' -> Trans (Expr t) expr t (C.Const _ v) = return $ Const t (cast t $ toDyn v) expr t (C.Drop _ (fromIntegral -> k :: Int) id) = do let node = ncNode id selfRef <- (== node) <$> curNode let varName = ncMain `ncTimeAnnot` k let var = Var $ if selfRef then varName else ncImported node varName unless selfRef $ do newDep node newImportedVar var (mkExtVar node varName) return $ VarE t var expr t (C.Label _ _ e) = expr t e expr t (C.Local tl _tr id l e) = casting tl $ \tl' -> do l' <- expr tl' l newLocal (Var $ ncLocal id) $ VarDescr tl' $ Expr l' expr t e expr t (C.Var _t' id) = return $ VarE t (Var $ ncLocal id) expr t (C.Op3 (C.Mux _) cond e1 e2) = do cond' <- expr Bool cond e1' <- expr t e1 e2' <- expr t e2 return $ Ite t cond' e1' e2' expr t (C.ExternVar _ name _) = do let nodeName = ncExternVarNode name let localAlias = Var nodeName newExtVarNode nodeName (U t) newDep nodeName newImportedVar localAlias (ExtVar nodeName (Var ncMain)) return $ VarE t localAlias expr t (C.Op1 op e) = handleOp1 t (op, e) expr notHandled Op1 where notHandled (UnhandledOp1 _opName _ta _tb) = newUnconstrainedVar t expr t (C.Op2 op e1 e2) = handleOp2 t (op, e1, e2) expr notHandled Op2 (Op1 Bool Not) where notHandled (UnhandledOp2 _opName _ta _tb _tc) = newUnconstrainedVar t newUnconstrainedVar :: Type t -> Trans (Expr t) newUnconstrainedVar t = do newNode <- getFreshNodeName newLocal (Var newNode) $ VarDescr t $ Constrs [] newDep newNode return $ VarE t (Var newNode) runTrans :: Trans a -> (a, [(NodeId, U Type)]) runTrans mx = (x, nubBy' (compare `on` fst) $ _extVarsNodes st) where (x, st) = runState mx initState initState = TransSt { _lvars = Map.empty , _importedVars = Bimap.empty , _dependencies = [] , _extVarsNodes = [] , _curNode = "" , _nextUid = 0 } runExprTrans :: Type t -> NodeId -> C.Expr a -> Trans (Expr t, Map Var VarDescr, Bimap Var ExtVar, [NodeId]) runExprTrans t curNode e = do modify $ \st -> st { _curNode = curNode } modify $ \st -> st { _nextUid = 0 } e' <- expr t e (lvs, ivs, dps) <- popLocalInfos return (e', lvs, ivs, dps) data TransSt = TransSt { _lvars :: Map Var VarDescr , _importedVars :: Bimap Var ExtVar , _dependencies :: [NodeId] , _extVarsNodes :: [(NodeId, U Type)] , _curNode :: NodeId , _nextUid :: Int } type Trans a = State TransSt a newDep d = modify $ \s -> s { _dependencies = d : _dependencies s } popLocalInfos :: State TransSt (Map Var VarDescr, Bimap Var ExtVar, [NodeId]) popLocalInfos = do lvs <- _lvars <$> get ivs <- _importedVars <$> get dps <- _dependencies <$> get modify $ \st -> st { _lvars = Map.empty , _importedVars = Bimap.empty , _dependencies = [] } return (lvs, ivs, nub' dps) getUid :: Trans Int getUid = do uid <- _nextUid <$> get modify $ \st -> st { _nextUid = uid + 1 } return uid getFreshNodeName :: Trans NodeId getFreshNodeName = liftM (("_" ++) . show) getUid newImportedVar l g = modify $ \s -> s { _importedVars = Bimap.insert l g (_importedVars s) } newLocal l d = modify $ \s -> s { _lvars = Map.insert l d $ _lvars s } curNode = _curNode <$> get newExtVarNode id t = modify $ \st -> st { _extVarsNodes = (id, t) : _extVarsNodes st } copilot-theorem-4.3/src/Copilot/Theorem/TransSys/Operators.hs0000644000000000000000000002100014762717277022600 0ustar0000000000000000{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE Safe #-} {-# LANGUAGE ScopedTypeVariables #-} -- | Operators in modular transition systems and their translation. module Copilot.Theorem.TransSys.Operators where import qualified Copilot.Core as C import Copilot.Theorem.TransSys.Cast import Copilot.Theorem.TransSys.Type import Copilot.Theorem.Misc.Error as Err -- | Unary operators. data Op1 a where Not :: Op1 Bool Neg :: Op1 a Abs :: Op1 a Exp :: Op1 a Sqrt :: Op1 a Log :: Op1 a Sin :: Op1 a Tan :: Op1 a Cos :: Op1 a Asin :: Op1 a Atan :: Op1 a Acos :: Op1 a Sinh :: Op1 a Tanh :: Op1 a Cosh :: Op1 a Asinh :: Op1 a Atanh :: Op1 a Acosh :: Op1 a -- | Binary operators. data Op2 a b where Eq :: Op2 a Bool And :: Op2 Bool Bool Or :: Op2 Bool Bool Le :: (Num a) => Op2 a Bool Lt :: (Num a) => Op2 a Bool Ge :: (Num a) => Op2 a Bool Gt :: (Num a) => Op2 a Bool Add :: (Num a) => Op2 a a Sub :: (Num a) => Op2 a a Mul :: (Num a) => Op2 a a Mod :: (Num a) => Op2 a a Fdiv :: (Num a) => Op2 a a Pow :: (Num a) => Op2 a a instance Show (Op1 a) where show op = case op of Neg -> "-" Not -> "not" Abs -> "abs" Exp -> "exp" Sqrt -> "sqrt" Log -> "log" Sin -> "sin" Tan -> "tan" Cos -> "cos" Asin -> "asin" Atan -> "atan" Acos -> "acos" Sinh -> "sinh" Tanh -> "tanh" Cosh -> "cosh" Asinh -> "asinh" Atanh -> "atanh" Acosh -> "acosh" instance Show (Op2 a b) where show op = case op of Eq -> "=" Le -> "<=" Lt -> "<" Ge -> ">=" Gt -> ">" And -> "and" Or -> "or" Add -> "+" Sub -> "-" Mul -> "*" Mod -> "mod" Fdiv -> "/" Pow -> "^" -- | Unhandled unary operator. -- -- Unhandled operators are monomorphic, and their names are labeled so that -- each name corresponds to a unique uninterpreted function with a -- monomorphic type. data UnhandledOp1 = forall a b . UnhandledOp1 String (Type a) (Type b) -- | Unhandled binary operator. -- -- Unhandled operators are monomorphic, and their names are labeled so that -- each name corresponds to a unique uninterpreted function with a -- monomorphic type. data UnhandledOp2 = forall a b c . UnhandledOp2 String (Type a) (Type b) (Type c) -- | Translate an Op1. -- -- This function is parameterized so that it can be used to translate -- in different contexts and with different targets. -- -- 'm' is the monad in which the computation is made -- -- 'resT' is the desired return type of the expression being translated handleOp1 :: forall m expr _a _b resT. (Functor m) => Type resT -- ^ The desired return type -> (C.Op1 _a _b, C.Expr _a) -- ^ The unary operator encountered and its argument -> (forall t t'. Type t -> C.Expr t' -> m (expr t)) -- ^ The monadic function to translate an expression -> (UnhandledOp1 -> m (expr resT)) -- ^ A function to deal with a operators not handled -> (forall t . Type t -> Op1 t -> expr t -> expr t) -- ^ The Op1 constructor of the 'expr' type -> m (expr resT) handleOp1 resT (op, e) handleExpr notHandledF mkOp = case op of C.Not -> boolOp Not (handleExpr Bool e) -- Numeric operators C.Abs _ -> numOp Abs C.Sign ta -> notHandled ta "sign" -- Fractional operators C.Recip ta -> notHandled ta "recip" -- Floating operators C.Exp _ -> numOp Exp C.Sqrt _ -> numOp Sqrt C.Log _ -> numOp Log C.Sin _ -> numOp Sin C.Tan _ -> numOp Tan C.Cos _ -> numOp Cos C.Asin _ -> numOp Asin C.Atan _ -> numOp Atan C.Acos _ -> numOp Acos C.Sinh _ -> numOp Sinh C.Tanh _ -> numOp Tanh C.Cosh _ -> numOp Cosh C.Asinh _ -> numOp Asinh C.Atanh _ -> numOp Atanh C.Acosh _ -> numOp Acosh -- Bitwise operators. C.BwNot ta -> notHandled ta "bwnot" -- Casting operator. C.Cast _ tb -> castTo tb where boolOp :: Op1 Bool -> m (expr Bool) -> m (expr resT) boolOp op e = case resT of Bool -> (mkOp resT op) <$> e _ -> Err.impossible typeErrMsg numOp :: Op1 resT -> m (expr resT) numOp op = (mkOp resT op) <$> (handleExpr resT e) -- Casting from Integer (Only possible solution) castTo :: C.Type ctb -> m (expr resT) castTo tb = casting tb $ \tb' -> case (tb', resT) of (Integer, Integer) -> handleExpr Integer e (Real, Real) -> handleExpr Real e _ -> Err.impossible typeErrMsg notHandled :: C.Type a -> String -> m (expr resT) notHandled ta s = casting ta $ \ta' -> notHandledF $ UnhandledOp1 s ta' resT -- | Translate an Op2. -- -- This function is parameterized so that it can be used to translate -- in different contexts and with different targets. -- -- 'm' is the monad in which the computation is made -- -- 'resT' is the desired return type of the expression being translated handleOp2 :: forall m expr _a _b _c resT . (Monad m) => Type resT -- ^ The desired return type -> (C.Op2 _a _b _c, C.Expr _a, C.Expr _b) -- ^ The binary operator encountered and its arguments -> (forall t t'. Type t -> C.Expr t' -> m (expr t)) -- ^ The monadic function to translate an expression -> (UnhandledOp2 -> m (expr resT)) -- ^ A function to deal with a operators not handled -> (forall t a . Type t -> Op2 a t -> expr a -> expr a -> expr t) -- ^ The Op2 constructor of the 'expr' type -> (expr Bool -> expr Bool) -- ^ The Op1 for boolean negation -> m (expr resT) handleOp2 resT (op, e1, e2) handleExpr notHandledF mkOp notOp = case op of C.And -> boolConnector And C.Or -> boolConnector Or -- Numeric operators C.Add _ -> numOp Add C.Sub _ -> numOp Sub C.Mul _ -> numOp Mul -- Integral operators. C.Mod _ -> numOp Mod C.Div ta -> notHandled ta "div" -- Fractional operators. C.Fdiv _ -> numOp Fdiv -- Floating operators. C.Pow _ -> numOp Pow C.Logb ta -> notHandled ta "logb" -- Equality operators. C.Eq ta -> eqOp ta C.Ne ta -> neqOp ta -- Relational operators. C.Le ta -> numComp ta Le C.Ge ta -> numComp ta Ge C.Lt ta -> numComp ta Lt C.Gt ta -> numComp ta Gt -- Bitwise operators. C.BwAnd ta -> notHandled ta "bwand" C.BwOr ta -> notHandled ta "bwor" C.BwXor ta -> notHandled ta "bwxor" -- In fact, '_tb' is ignored caused it can only -- be casted to 'Integer', like 'ta' C.BwShiftL ta _tb -> notHandled ta "bwshiftl" C.BwShiftR ta _tb -> notHandled ta "bwshiftr" where boolOp :: Op2 a Bool -> expr a -> expr a -> expr resT boolOp op e1' e2' = case resT of Bool -> mkOp resT op e1' e2' _ -> Err.impossible typeErrMsg boolConnector :: Op2 Bool Bool -> m (expr resT) boolConnector op = do e1' <- handleExpr Bool e1 e2' <- handleExpr Bool e2 return $ boolOp op e1' e2' eqOp :: C.Type cta -> m (expr resT) eqOp ta = casting ta $ \ta' -> do e1' <- handleExpr ta' e1 e2' <- handleExpr ta' e2 return $ boolOp Eq e1' e2' neqOp :: C.Type cta -> m (expr resT) neqOp ta = case resT of Bool -> do e <- eqOp ta return $ notOp e _ -> Err.impossible typeErrMsg numOp :: (forall num . (Num num) => Op2 num num) -> m (expr resT) numOp op = case resT of Integer -> do e1' <- handleExpr Integer e1 e2' <- handleExpr Integer e2 return $ mkOp resT op e1' e2' Real -> do e1' <- handleExpr Real e1 e2' <- handleExpr Real e2 return $ mkOp resT op e1' e2' _ -> Err.impossible typeErrMsg numComp :: C.Type cta -> (forall num . (Num num) => Op2 num Bool) -> m (expr resT) numComp ta op = casting ta $ \case Integer -> do e1' <- handleExpr Integer e1 e2' <- handleExpr Integer e2 return $ boolOp op e1' e2' Real -> do e1' <- handleExpr Real e1 e2' <- handleExpr Real e2 return $ boolOp op e1' e2' _ -> Err.impossible typeErrMsg notHandled :: forall a . C.Type a -> String -> m (expr resT) notHandled ta s = casting ta $ \ta' -> notHandledF (UnhandledOp2 s ta' ta' ta') -- | Error message for unexpected behavior / internal errors. typeErrMsg :: String typeErrMsg = "Unexpected type error in 'Misc.CoreOperators'" copilot-theorem-4.3/src/Copilot/Theorem/TransSys/Type.hs0000644000000000000000000000163714762717277021561 0ustar0000000000000000{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE Safe #-} -- | Types suported by the modular transition systems. module Copilot.Theorem.TransSys.Type ( Type (..) , U (..) ) where import Data.Type.Equality -- | A type at both value and type level. -- -- Real numbers are mapped to 'Double's. data Type a where Bool :: Type Bool Integer :: Type Integer Real :: Type Double -- | Proofs of type equality. instance TestEquality Type where testEquality Bool Bool = Just Refl testEquality Integer Integer = Just Refl testEquality Real Real = Just Refl testEquality _ _ = Nothing -- | Unknown types. -- -- For instance, 'U Expr' is the type of an expression of unknown type data U f = forall t . U (f t) instance Show (Type t) where show Integer = "Int" show Bool = "Bool" show Real = "Real" copilot-theorem-4.3/src/Copilot/Theorem/TransSys/Invariants.hs0000644000000000000000000000073114762717277022750 0ustar0000000000000000{-# OPTIONS_GHC -O0 #-} {-# LANGUAGE Safe #-} -- | Augment types with invariants. module Copilot.Theorem.TransSys.Invariants ( HasInvariants (..) , prop ) where -- | Type class for types with additional invariants or contraints. class HasInvariants a where invariants :: a -> [(String, Bool)] checkInvs :: a -> Bool checkInvs obj = all snd $ invariants obj -- | Creates an invariant with a description. prop :: String -> Bool -> (String, Bool) prop = (,) copilot-theorem-4.3/src/Copilot/Theorem/TransSys/Renaming.hs0000644000000000000000000000505514762717277022376 0ustar0000000000000000{-# LANGUAGE Safe #-} -- | A monad capable of keeping track of variable renames and of providing -- fresh names for variables. module Copilot.Theorem.TransSys.Renaming ( Renaming , addReservedName , rename , getFreshName , runRenaming , getRenamingF ) where import Copilot.Theorem.TransSys.Spec import Control.Monad.State.Lazy import Data.Maybe (fromMaybe) import Data.Map (Map) import Data.Set (Set, member) import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.List as List -- | A monad capable of keeping track of variable renames and of providing -- fresh names for variables. type Renaming = State RenamingST -- | State needed to keep track of variable renames and reserved names. data RenamingST = RenamingST { _reservedNames :: Set Var , _renaming :: Map ExtVar Var } -- | Register a name as reserved or used. addReservedName :: Var -> Renaming () addReservedName v = modify $ \st -> st {_reservedNames = Set.insert v (_reservedNames st)} -- | Produce a fresh new name based on the variable names provided. -- -- This function will try to pick a name from the given list and, if not, will -- use one of the names in the list as a basis for new names. -- -- PRE: the given list cannot be empty. getFreshName :: [Var] -> Renaming Var getFreshName vs = do usedNames <- _reservedNames <$> get let varAppend (Var s) = Var $ s ++ "_" applicants = vs ++ List.iterate varAppend (head vs) v = case dropWhile (`member` usedNames) applicants of v:_ -> v [] -> error "No more names available" addReservedName v return v -- | Map a name in the global namespace to a new variable name. rename :: NodeId -- ^ A node Id -> Var -- ^ A variable within that node -> Var -- ^ A new name for the variable -> Renaming () rename n v v' = modify $ \st -> st {_renaming = Map.insert (ExtVar n v) v' (_renaming st)} -- | Return a function that maps variables in the global namespace to their new -- names if any renaming has been registered. getRenamingF :: Renaming (ExtVar -> Var) getRenamingF = do mapping <- _renaming <$> get return $ \extv -> fromMaybe (extVarLocalPart extv) (Map.lookup extv mapping) -- | Run a computation in the 'Renaming' monad, providing a result and the -- renaming function that maps variables in the global namespace to their new -- local names. runRenaming :: Renaming a -> (a, ExtVar -> Var) runRenaming m = evalState st' (RenamingST Set.empty Map.empty) where st' = do r <- m f <- getRenamingF return (r, f) copilot-theorem-4.3/src/Copilot/Theorem/TransSys/Cast.hs0000644000000000000000000000501514762717277021524 0ustar0000000000000000{-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE Safe #-} {-# LANGUAGE ScopedTypeVariables #-} -- | Casting of values with dynamic types and translating from Copilot core -- types to Copilot theorem types. module Copilot.Theorem.TransSys.Cast ( Dyn , toDyn , cast , castedType , casting ) where import Copilot.Core as C import Data.Dynamic (Dynamic(..), fromDynamic, toDyn) import GHC.Float import qualified Copilot.Theorem.TransSys.Type as K -- | Synonym for a dynamic type in Copilot core. type Dyn = Dynamic -- | Translation of a Copilot type into Copilot theorem's internal -- representation. castedType :: Type t -> K.U K.Type castedType t = case t of Bool -> K.U K.Bool Int8 -> K.U K.Integer Int16 -> K.U K.Integer Int32 -> K.U K.Integer Int64 -> K.U K.Integer Word8 -> K.U K.Integer Word16 -> K.U K.Integer Word32 -> K.U K.Integer Word64 -> K.U K.Integer Float -> K.U K.Real Double -> K.U K.Real -- | Cast a dynamic value to a given type. cast :: K.Type t -> Dyn -> t cast t v | K.Integer <- t, Just (vi :: Integer) <- _cast v = vi | K.Bool <- t, Just (vb :: Bool) <- _cast v = vb | K.Real <- t, Just (vr :: Double) <- _cast v = vr | otherwise = error "Bad type cast" -- | Apply function to a corresponding type in Copilot theorem's internal -- representation. casting :: Type t -> (forall t' . K.Type t' -> a) -> a casting t f = case castedType t of K.U K.Bool -> f K.Bool K.U K.Integer -> f K.Integer K.U K.Real -> f K.Real class Casted b where _cast :: Dyn -> Maybe b instance Casted Integer where _cast d | Just (v :: Int8) <- fromDynamic d = Just $ toInteger v | Just (v :: Int16) <- fromDynamic d = Just $ toInteger v | Just (v :: Int32) <- fromDynamic d = Just $ toInteger v | Just (v :: Int64) <- fromDynamic d = Just $ toInteger v | Just (v :: Word8) <- fromDynamic d = Just $ toInteger v | Just (v :: Word16) <- fromDynamic d = Just $ toInteger v | Just (v :: Word32) <- fromDynamic d = Just $ toInteger v | Just (v :: Word64) <- fromDynamic d = Just $ toInteger v | otherwise = Nothing instance Casted Bool where _cast d | Just (v :: Bool) <- fromDynamic d = Just v | otherwise = Nothing instance Casted Double where _cast d | Just (v :: Float) <- fromDynamic d = Just $ float2Double v | Just (v :: Double) <- fromDynamic d = Just v | otherwise = Nothing copilot-theorem-4.3/src/Copilot/Theorem/TransSys/Spec.hs0000644000000000000000000001660414762717277021532 0ustar0000000000000000{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE Safe #-} -- | Specification of Copilot streams as modular transition systems. module Copilot.Theorem.TransSys.Spec ( module Copilot.Theorem.TransSys.Operators , module Copilot.Theorem.TransSys.Type , module Copilot.Theorem.TransSys.Invariants , TransSys (..) , Node (..) , PropId , NodeId , Var (..) , ExtVar (..) , VarDef (..) , VarDescr (..) , Expr (..) , mkExtVar , transformExpr , isTopologicallySorted , nodeVarsSet , specDependenciesGraph , specTopNode ) where import Copilot.Theorem.TransSys.Type import Copilot.Theorem.TransSys.Operators import Copilot.Theorem.TransSys.Invariants import Copilot.Theorem.Misc.Utils import Control.Applicative (liftA2) import Control.Monad (foldM, guard) import Data.Maybe import Data.Monoid ((<>)) import Data.Map (Map) import Data.Set (Set, isSubsetOf, member) import Data.Bimap (Bimap) import qualified Data.List as List import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.Bimap as Bimap -- | Unique name that identifies a node. type NodeId = String -- | Unique name that identifies a property. type PropId = String -- | A modular transition system is defined by a graph of nodes and a series -- of properties, each mapped to a variable. data TransSys = TransSys { specNodes :: [Node] , specTopNodeId :: NodeId , specProps :: Map PropId ExtVar } -- | A node is a set of variables living in a local namespace and corresponding -- to the 'Var' type. data Node = Node { nodeId :: NodeId , nodeDependencies :: [NodeId] -- ^ Nodes from which variables are -- imported. , nodeLocalVars :: Map Var VarDescr -- ^ Locally defined variables, -- either as the previous value of -- another variable (using 'Pre'), -- an expression involving -- variables (using 'Expr') or a -- set of constraints (using -- 'Constrs'). , nodeImportedVars :: Bimap Var ExtVar -- ^ Binds each imported variable to -- its local name. , nodeConstrs :: [Expr Bool] } -- | Identifer of a variable in the local (within one node) namespace. data Var = Var {varName :: String} deriving (Eq, Show, Ord) -- | Identifer of a variable in the global namespace by specifying both a node -- name and a variable. data ExtVar = ExtVar {extVarNode :: NodeId, extVarLocalPart :: Var } deriving (Eq, Ord) -- | A description of a variable together with its type. data VarDescr = forall t . VarDescr { varType :: Type t , varDef :: VarDef t } -- | A variable definition either as a delay, an operation on variables, or -- a constraint. data VarDef t = Pre t Var | Expr (Expr t) | Constrs [Expr Bool] -- | A point-wise (time-wise) expression. data Expr t where Const :: Type t -> t -> Expr t Ite :: Type t -> Expr Bool -> Expr t -> Expr t -> Expr t Op1 :: Type t -> Op1 t -> Expr t -> Expr t Op2 :: Type t -> Op2 a t -> Expr a -> Expr a -> Expr t VarE :: Type t -> Var -> Expr t -- | Constructor for variables identifiers in the global namespace. mkExtVar node name = ExtVar node (Var name) foldExpr :: (Monoid m) => (forall t . Expr t -> m) -> Expr a -> m foldExpr f expr = f expr <> fargs where fargs = case expr of (Ite _ c e1 e2) -> foldExpr f c <> foldExpr f e1 <> foldExpr f e2 (Op1 _ _ e) -> foldExpr f e (Op2 _ _ e1 e2) -> foldExpr f e1 <> foldExpr f e2 _ -> mempty foldUExpr :: (Monoid m) => (forall t . Expr t -> m) -> U Expr -> m foldUExpr f (U e) = foldExpr f e -- | Apply an arbitrary transformation to the leafs of an expression. transformExpr :: (forall a . Expr a -> Expr a) -> Expr t -> Expr t transformExpr f = tre where tre :: forall t . Expr t -> Expr t tre (Ite t c e1 e2) = f (Ite t (tre c) (tre e1) (tre e2)) tre (Op1 t op e) = f (Op1 t op (tre e)) tre (Op2 t op e1 e2) = f (Op2 t op (tre e1) (tre e2)) tre e = f e -- | The set of variables related to a node (union of the local variables and -- the imported variables after deferencing them). nodeVarsSet :: Node -> Set Var nodeVarsSet = liftA2 Set.union nodeLocalVarsSet (Map.keysSet . Bimap.toMap . nodeImportedVars) nodeLocalVarsSet :: Node -> Set Var nodeLocalVarsSet = Map.keysSet . nodeLocalVars nodeRhsVarsSet :: Node -> Set Var nodeRhsVarsSet n = let varOcc (VarE _ v) = Set.singleton v varOcc _ = Set.empty descrRhsVars (VarDescr _ (Expr e)) = foldExpr varOcc e descrRhsVars (VarDescr _ (Pre _ v)) = Set.singleton v descrRhsVars (VarDescr _ (Constrs cs)) = mconcat (map (foldExpr varOcc) cs) in Map.foldr (Set.union . descrRhsVars) Set.empty (nodeLocalVars n) nodeImportedExtVarsSet :: Node -> Set ExtVar nodeImportedExtVarsSet = Map.keysSet . Bimap.toMapR . nodeImportedVars nodeExportedExtVarsSet :: Node -> Set ExtVar nodeExportedExtVarsSet n = Set.map (ExtVar $ nodeId n) (nodeLocalVarsSet n) instance HasInvariants Node where invariants n = [ prop "The dependencies declaration doesn't lie" $ (map extVarNode . Bimap.elems $ nodeImportedVars n) `isSublistOf` nodeDependencies n , prop "All local variables are declared" $ nodeRhsVarsSet n `isSubsetOf` nodeVarsSet n , prop "Never apply 'pre' to an imported var" $ let preVars = Set.fromList [v | (VarDescr _ (Pre _ v)) <- Map.elems $ nodeLocalVars n] in preVars `isSubsetOf` nodeLocalVarsSet n ] specNodesIds :: TransSys -> Set NodeId specNodesIds s = Set.fromList . map nodeId $ specNodes s -- | Given a modular transition system, produce a map from each node to its -- dependencies. specDependenciesGraph :: TransSys -> Map NodeId [NodeId] specDependenciesGraph s = Map.fromList [ (nodeId n, nodeDependencies n) | n <- specNodes s ] -- | Return the top node of a modular transition system. specTopNode :: TransSys -> Node specTopNode spec = fromJust $ List.find ((== specTopNodeId spec) . nodeId) (specNodes spec) instance HasInvariants TransSys where invariants s = [ prop "All mentioned nodes are declared" $ specTopNodeId s `member` specNodesIds s && Set.fromList [nId | n <- specNodes s, nId <- nodeDependencies n] `isSubsetOf` specNodesIds s , prop "The imported vars are not broken" $ mconcat (map nodeImportedExtVarsSet $ specNodes s) `isSubsetOf` mconcat (map nodeExportedExtVarsSet $ specNodes s) , prop "The nodes invariants hold" $ all checkInvs (specNodes s) ] -- | True if the graph is topologically sorted (i.e., if the dependencies of a -- node appear in the list of 'specNodes' before the node that depends on -- them). isTopologicallySorted :: TransSys -> Bool isTopologicallySorted spec = isJust $ foldM inspect Set.empty (specNodes spec) where inspect acc n = do guard $ Set.fromList (nodeDependencies n) `isSubsetOf` acc return . Set.insert (nodeId n) $ acc -- For debugging purposes instance Show ExtVar where show (ExtVar n v) = "(" ++ n ++ " : " ++ show v ++ ")" copilot-theorem-4.3/src/Copilot/Theorem/What4/0000755000000000000000000000000014762717277017476 5ustar0000000000000000copilot-theorem-4.3/src/Copilot/Theorem/What4/Translate.hs0000644000000000000000000017626214762717277022005 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} -- | -- Module : Copilot.Theorem.What4.Translate -- Description : Translate Copilot specifications into What4 -- Copyright : (c) Galois Inc., 2021-2022 -- Maintainer : robdockins@galois.com -- Stability : experimental -- Portability : POSIX -- -- Translate Copilot specifications to What4 formulas using the 'TransM' monad. module Copilot.Theorem.What4.Translate ( -- * Translation into What4 TransState(..) , TransM , runTransM , LocalEnv , translateExpr , translateConstExpr , getStreamValue , getExternConstant -- * What4 representations of Copilot expressions , XExpr(..) -- * Stream offsets , StreamOffset(..) -- * Auxiliary functions , panic ) where import Control.Monad (forM, zipWithM) import qualified Control.Monad.Fail as Fail import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.State (MonadState (..), StateT (..), gets, modify) import qualified Data.BitVector.Sized as BV import Data.IORef (newIORef, modifyIORef, readIORef) import Data.List (elemIndex, genericIndex, genericLength) import qualified Data.Map as Map import Data.Maybe (fromJust) import Data.Parameterized.Classes (KnownRepr (..)) import Data.Parameterized.Context (EmptyCtx, type (::>)) import Data.Parameterized.NatRepr (LeqProof (..), NatCases (..), NatRepr, decNat, incNat, intValue, isZeroOrGT1, knownNat, minusPlusCancel, mkNatRepr, testNatCases, testStrictLeq, withKnownNat) import Data.Parameterized.Some (Some (..)) import Data.Parameterized.SymbolRepr (SymbolRepr, knownSymbol) import qualified Data.Parameterized.Vector as V import Data.Type.Equality (TestEquality (..), (:~:) (..)) import Data.Word (Word32) import GHC.TypeLits (KnownSymbol) import GHC.TypeNats (KnownNat, type (<=), type (+)) import qualified Panic as Panic import qualified What4.BaseTypes as WT import qualified What4.Interface as WI import qualified What4.InterpretedFloatingPoint as WFP import qualified What4.SpecialFunctions as WSF import qualified Copilot.Core.Expr as CE import qualified Copilot.Core.Operators as CE import qualified Copilot.Core.Spec as CS import qualified Copilot.Core.Type as CT import qualified Copilot.Core.Type.Array as CT import qualified Copilot.PrettyPrint as CP -- Translation into What4 -- | The state for translating Copilot expressions into What4 expressions. As we -- translate, we generate fresh symbolic constants for external variables and -- for stream variables. We need to only generate one constant per variable, so -- we allocate them in a map. When we need the constant for a particular -- variable, we check if it is already in the map, and return it if it is; if it -- isn't, we generate a fresh constant at that point, store it in the map, and -- return it. -- -- We also store 'streams', an immutable field, in this state, rather than wrap -- it up in another monad transformer layer. This is initialized prior to -- translation and is never modified. This maps from stream ids to the -- core stream definitions. data TransState sym = TransState { -- | Map keeping track of all external variables encountered during -- translation. mentionedExternals :: Map.Map CE.Name (Some CT.Type), -- | Memo table for external variables, indexed by the external stream name -- and a stream offset. externVars :: Map.Map (CE.Name, StreamOffset) (XExpr sym), -- | Memo table for stream values, indexed by the stream 'CE.Id' and offset. streamValues :: Map.Map (CE.Id, StreamOffset) (XExpr sym), -- | Map from stream ids to the streams themselves. This value is never -- modified, but I didn't want to make this an RWS, so it's represented as a -- stateful value. streams :: Map.Map CE.Id CS.Stream, -- | A list of side conditions that must be true in order for all applications -- of partial functions (e.g., 'CE.Div') to be well defined. sidePreds :: [WI.Pred sym] } newtype TransM sym a = TransM { unTransM :: StateT (TransState sym) IO a } deriving ( Functor , Applicative , Monad , Fail.MonadFail , MonadIO , MonadState (TransState sym) ) -- | Translate a Copilot specification using the given 'TransM' computation. runTransM :: CS.Spec -> TransM sym a -> IO a runTransM spec m = do -- Build up initial translation state let streamMap = Map.fromList $ (\stream -> (CS.streamId stream, stream)) <$> CS.specStreams spec st = TransState { mentionedExternals = mempty , externVars = mempty , streamValues = mempty , streams = streamMap , sidePreds = [] } (res, _) <- runStateT (unTransM m) st return res -- | An environment used to translate local Copilot variables to What4. type LocalEnv sym = Map.Map CE.Name (StreamOffset -> TransM sym (XExpr sym)) -- | Compute the value of a stream expression at the given offset in the given -- local environment. translateExpr :: forall sym a. WFP.IsInterpretedFloatSymExprBuilder sym => sym -> LocalEnv sym -- ^ Environment for local variables -> CE.Expr a -- ^ Expression to translate -> StreamOffset -- ^ Offset to compute -> TransM sym (XExpr sym) translateExpr sym localEnv e offset = case e of CE.Const tp a -> liftIO $ translateConstExpr sym tp a CE.Drop _tp ix streamId -> getStreamValue sym streamId (addOffset offset ix) CE.Local _tpa _tpb nm e1 body -> do ref <- liftIO (newIORef mempty) -- Look up a stream value by offset, using an IORef to cache values that -- have already been looked up previously. Caching values in this way avoids -- exponential blowup. -- -- Note that using a single IORef to store all local variables means that it -- is possible for local variables to escape their lexical scope. See issue -- #253 for more information. This is an issue that is shared in common with -- `copilot-c99` and the Copilot interpreter. let f :: StreamOffset -> TransM sym (XExpr sym) f offset' = do m <- liftIO (readIORef ref) case Map.lookup offset' m of -- If we have looked up this value before, return the cached value. Just x -> return x -- Otherwise, translate the expression and cache it for subsequent -- lookups. Nothing -> do x <- translateExpr sym localEnv e1 offset' liftIO (modifyIORef ref (Map.insert offset' x)) return x let localEnv' = Map.insert nm f localEnv translateExpr sym localEnv' body offset CE.Var _tp nm -> case Map.lookup nm localEnv of Nothing -> panic ["translateExpr: unknown var " ++ show nm] Just f -> f offset CE.ExternVar tp nm _prefix -> getExternConstant sym tp nm offset CE.Op1 op e1 -> do xe1 <- translateExpr sym localEnv e1 offset translateOp1 sym e op xe1 CE.Op2 op e1 e2 -> do xe1 <- translateExpr sym localEnv e1 offset xe2 <- translateExpr sym localEnv e2 offset translateOp2 sym e op xe1 xe2 CE.Op3 op e1 e2 e3 -> do xe1 <- translateExpr sym localEnv e1 offset xe2 <- translateExpr sym localEnv e2 offset xe3 <- translateExpr sym localEnv e3 offset translateOp3 sym e op xe1 xe2 xe3 CE.Label _ _ e1 -> translateExpr sym localEnv e1 offset -- | Compute and cache the value of a stream with the given identifier at the -- given offset. getStreamValue :: WFP.IsInterpretedFloatSymExprBuilder sym => sym -> CE.Id -> StreamOffset -> TransM sym (XExpr sym) getStreamValue sym streamId offset = do svs <- gets streamValues case Map.lookup (streamId, offset) svs of Just xe -> return xe Nothing -> do streamDef <- getStreamDef streamId xe <- computeStreamValue streamDef modify $ \st -> st { streamValues = Map.insert (streamId, offset) xe (streamValues st) } return xe where computeStreamValue (CS.Stream { CS.streamId = id, CS.streamBuffer = buf, CS.streamExpr = ex, CS.streamExprType = tp }) = let len = genericLength buf in case offset of AbsoluteOffset i | i < 0 -> panic ["Invalid absolute offset " ++ show i ++ " for stream " ++ show id] | i < len -> liftIO (translateConstExpr sym tp (genericIndex buf i)) | otherwise -> translateExpr sym mempty ex (AbsoluteOffset (i - len)) RelativeOffset i | i < 0 -> panic ["Invalid relative offset " ++ show i ++ " for stream " ++ show id] | i < len -> let nm = "s" ++ show id ++ "_r" ++ show i in liftIO (freshCPConstant sym nm tp) | otherwise -> translateExpr sym mempty ex (RelativeOffset (i - len)) -- | Compute and cache the value of an external stream with the given name at -- the given offset. getExternConstant :: WFP.IsInterpretedFloatSymExprBuilder sym => sym -> CT.Type a -> CE.Name -> StreamOffset -> TransM sym (XExpr sym) getExternConstant sym tp nm offset = do es <- gets externVars case Map.lookup (nm, offset) es of Just xe -> return xe Nothing -> do xe <- computeExternConstant modify $ \st -> st { externVars = Map.insert (nm, offset) xe (externVars st) , mentionedExternals = Map.insert nm (Some tp) (mentionedExternals st) } return xe where computeExternConstant = case offset of AbsoluteOffset i | i < 0 -> panic ["Invalid absolute offset " ++ show i ++ " for external stream " ++ nm] | otherwise -> let nm' = nm ++ "_a" ++ show i in liftIO (freshCPConstant sym nm' tp) RelativeOffset i | i < 0 -> panic ["Invalid relative offset " ++ show i ++ " for external stream " ++ nm] | otherwise -> let nm' = nm ++ "_r" ++ show i in liftIO (freshCPConstant sym nm' tp) -- | A view of an XExpr as a bitvector expression, a natrepr for its width, its -- signed/unsigned status, and the constructor used to reconstruct an XExpr from -- it. This is a useful view for translation, as many of the operations can be -- grouped together for all words\/ints\/floats. data SomeBVExpr sym where SomeBVExpr :: 1 <= w => WI.SymBV sym w -> NatRepr w -> BVSign -> (WI.SymBV sym w -> XExpr sym) -> SomeBVExpr sym -- | The sign of a bitvector -- this indicates whether it is to be interpreted -- as a signed 'Int' or an unsigned 'Word'. data BVSign = Signed | Unsigned deriving Eq -- | If the inner expression can be viewed as a bitvector, we project out a view -- of it as such. asBVExpr :: XExpr sym -> Maybe (SomeBVExpr sym) asBVExpr xe = case xe of XInt8 e -> Just (SomeBVExpr e knownNat Signed XInt8) XInt16 e -> Just (SomeBVExpr e knownNat Signed XInt16) XInt32 e -> Just (SomeBVExpr e knownNat Signed XInt32) XInt64 e -> Just (SomeBVExpr e knownNat Signed XInt64) XWord8 e -> Just (SomeBVExpr e knownNat Unsigned XWord8) XWord16 e -> Just (SomeBVExpr e knownNat Unsigned XWord16) XWord32 e -> Just (SomeBVExpr e knownNat Unsigned XWord32) XWord64 e -> Just (SomeBVExpr e knownNat Unsigned XWord64) _ -> Nothing -- | If an 'XExpr' is a bitvector expression, use it to generate a side -- condition involving an application of a partial function. Otherwise, do -- nothing. addBVSidePred1 :: WI.IsExprBuilder sym => XExpr sym -> (forall w. 1 <= w => WI.SymBV sym w -> NatRepr w -> BVSign -> IO (WI.Pred sym)) -> TransM sym () addBVSidePred1 xe makeSidePred = case asBVExpr xe of Just (SomeBVExpr e w sgn _) -> do sidePred <- liftIO $ makeSidePred e w sgn addSidePred sidePred Nothing -> pure () -- | If two 'XExpr's are both bitvector expressions of the same type and -- signedness, use them to generate a side condition involving an application of -- a partial function. Otherwise, do nothing. addBVSidePred2 :: WI.IsExprBuilder sym => XExpr sym -> XExpr sym -> (forall w. 1 <= w => WI.SymBV sym w -> WI.SymBV sym w -> NatRepr w -> BVSign -> IO (WI.Pred sym)) -> TransM sym () addBVSidePred2 xe1 xe2 makeSidePred = case (asBVExpr xe1, asBVExpr xe2) of (Just (SomeBVExpr e1 w1 sgn1 _), Just (SomeBVExpr e2 w2 sgn2 _)) | Just Refl <- testEquality w1 w2 , sgn1 == sgn2 -> do sidePred <- liftIO $ makeSidePred e1 e2 w1 sgn1 addSidePred sidePred _ -> pure () -- | Translate a constant expression by creating a what4 literal and packaging -- it up into an 'XExpr'. translateConstExpr :: forall sym a. WFP.IsInterpretedFloatExprBuilder sym => sym -> CT.Type a -> a -> IO (XExpr sym) translateConstExpr sym tp a = case tp of CT.Bool -> case a of True -> return $ XBool (WI.truePred sym) False -> return $ XBool (WI.falsePred sym) CT.Int8 -> XInt8 <$> WI.bvLit sym knownNat (BV.int8 a) CT.Int16 -> XInt16 <$> WI.bvLit sym knownNat (BV.int16 a) CT.Int32 -> XInt32 <$> WI.bvLit sym knownNat (BV.int32 a) CT.Int64 -> XInt64 <$> WI.bvLit sym knownNat (BV.int64 a) CT.Word8 -> XWord8 <$> WI.bvLit sym knownNat (BV.word8 a) CT.Word16 -> XWord16 <$> WI.bvLit sym knownNat (BV.word16 a) CT.Word32 -> XWord32 <$> WI.bvLit sym knownNat (BV.word32 a) CT.Word64 -> XWord64 <$> WI.bvLit sym knownNat (BV.word64 a) CT.Float -> XFloat <$> WFP.iFloatLitSingle sym a CT.Double -> XDouble <$> WFP.iFloatLitDouble sym a CT.Array tp -> do elts <- traverse (translateConstExpr sym tp) (CT.arrayElems a) Some n <- return $ mkNatRepr (genericLength elts) case isZeroOrGT1 n of Left Refl -> return $ XEmptyArray tp Right LeqProof -> do let Just v = V.fromList n elts return $ withKnownNat n $ XArray v CT.Struct _ -> do elts <- forM (CT.toValues a) $ \(CT.Value tp (CT.Field a)) -> translateConstExpr sym tp a return $ XStruct elts arrayLen :: KnownNat n => CT.Type (CT.Array n t) -> NatRepr n arrayLen _ = knownNat -- | Generate a fresh constant for a given copilot type. This will be called -- whenever we attempt to get the constant for a given external variable or -- stream variable, but that variable has not been accessed yet and therefore -- has no constant allocated. freshCPConstant :: forall sym a . WFP.IsInterpretedFloatSymExprBuilder sym => sym -> String -> CT.Type a -> IO (XExpr sym) freshCPConstant sym nm tp = case tp of CT.Bool -> XBool <$> WI.freshConstant sym (WI.safeSymbol nm) knownRepr CT.Int8 -> XInt8 <$> WI.freshConstant sym (WI.safeSymbol nm) knownRepr CT.Int16 -> XInt16 <$> WI.freshConstant sym (WI.safeSymbol nm) knownRepr CT.Int32 -> XInt32 <$> WI.freshConstant sym (WI.safeSymbol nm) knownRepr CT.Int64 -> XInt64 <$> WI.freshConstant sym (WI.safeSymbol nm) knownRepr CT.Word8 -> XWord8 <$> WI.freshConstant sym (WI.safeSymbol nm) knownRepr CT.Word16 -> XWord16 <$> WI.freshConstant sym (WI.safeSymbol nm) knownRepr CT.Word32 -> XWord32 <$> WI.freshConstant sym (WI.safeSymbol nm) knownRepr CT.Word64 -> XWord64 <$> WI.freshConstant sym (WI.safeSymbol nm) knownRepr CT.Float -> XFloat <$> WFP.freshFloatConstant sym (WI.safeSymbol nm) WFP.SingleFloatRepr CT.Double -> XDouble <$> WFP.freshFloatConstant sym (WI.safeSymbol nm) WFP.DoubleFloatRepr atp@(CT.Array itp) -> do let n = arrayLen atp case isZeroOrGT1 n of Left Refl -> return $ XEmptyArray itp Right LeqProof -> do Refl <- return $ minusPlusCancel n (knownNat @1) elts :: V.Vector n (XExpr t) <- V.generateM (decNat n) (const (freshCPConstant sym "" itp)) return $ XArray elts CT.Struct stp -> do elts <- forM (CT.toValues stp) $ \(CT.Value ftp _) -> freshCPConstant sym "" ftp return $ XStruct elts -- | Retrieve a stream definition given its id. getStreamDef :: CE.Id -> TransM sym CS.Stream getStreamDef streamId = fromJust <$> gets (Map.lookup streamId . streams) -- | Add a side condition originating from an application of a partial function. addSidePred :: WI.Pred sym -> TransM sym () addSidePred newPred = modify (\st -> st { sidePreds = newPred : sidePreds st }) -- * Translate Ops -- Note [Side conditions for floating-point operations] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- We do not currently track side conditions for floating-point operations, as -- they are unlikely to matter. A typical client of copilot-theorem will likely -- treat floating-point operations as uninterpreted functions, and side -- conditions involving uninterpreted functions are very unlikely to be helpful -- except in very specific circumstances. In case we revisit this decision -- later, we make a note of which floating-point operations could potentially -- track side conditions as comments (but without implementing them). type BVOp1 sym w = (KnownNat w, 1 <= w) => WI.SymBV sym w -> IO (WI.SymBV sym w) type FPOp1 sym fi = WFP.FloatInfoRepr fi -> WI.SymExpr sym (WFP.SymInterpretedFloatType sym fi) -> IO (WI.SymExpr sym (WFP.SymInterpretedFloatType sym fi)) fieldName :: KnownSymbol s => CT.Field s a -> SymbolRepr s fieldName _ = knownSymbol valueName :: CT.Value a -> Some SymbolRepr valueName (CT.Value _ f) = Some (fieldName f) translateOp1 :: forall sym a b . WFP.IsInterpretedFloatExprBuilder sym => sym -> CE.Expr b -- ^ Original value we are translating (only used for error -- messages) -> CE.Op1 a b -> XExpr sym -> TransM sym (XExpr sym) translateOp1 sym origExpr op xe = case (op, xe) of (CE.Not, XBool e) -> liftIO $ fmap XBool $ WI.notPred sym e (CE.Not, _) -> panic ["Expected bool", show xe] (CE.Abs _, xe) -> translateAbs xe (CE.Sign _, xe) -> translateSign xe -- We do not track any side conditions for floating-point operations -- (see Note [Side conditions for floating-point operations]), but we will -- make a note of which operations have partial inputs. -- The argument should not be zero (CE.Recip _, xe) -> liftIO $ fpOp recip xe where recip :: forall fi . FPOp1 sym fi recip fiRepr e = do one <- fpLit fiRepr 1.0 WFP.iFloatDiv @_ @fi sym fpRM one e -- The argument should not cause the result to overflow or underlow (CE.Exp _, xe) -> liftIO $ fpSpecialOp WSF.Exp xe -- The argument should not be less than -0 (CE.Sqrt _, xe) -> liftIO $ fpOp (\(_ :: WFP.FloatInfoRepr fi) -> WFP.iFloatSqrt @_ @fi sym fpRM) xe -- The argument should not be negative or zero (CE.Log _, xe) -> liftIO $ fpSpecialOp WSF.Log xe -- The argument should not be infinite (CE.Sin _, xe) -> liftIO $ fpSpecialOp WSF.Sin xe -- The argument should not be infinite (CE.Cos _, xe) -> liftIO $ fpSpecialOp WSF.Cos xe -- The argument should not be infinite, nor should it cause the result to -- overflow (CE.Tan _, xe) -> liftIO $ fpSpecialOp WSF.Tan xe -- The argument should not cause the result to overflow (CE.Sinh _, xe) -> liftIO $ fpSpecialOp WSF.Sinh xe -- The argument should not cause the result to overflow (CE.Cosh _, xe) -> liftIO $ fpSpecialOp WSF.Cosh xe (CE.Tanh _, xe) -> liftIO $ fpSpecialOp WSF.Tanh xe -- The argument should not be outside the range [-1, 1] (CE.Asin _, xe) -> liftIO $ fpSpecialOp WSF.Arcsin xe -- The argument should not be outside the range [-1, 1] (CE.Acos _, xe) -> liftIO $ fpSpecialOp WSF.Arccos xe (CE.Atan _, xe) -> liftIO $ fpSpecialOp WSF.Arctan xe (CE.Asinh _, xe) -> liftIO $ fpSpecialOp WSF.Arcsinh xe -- The argument should not be less than 1 (CE.Acosh _, xe) -> liftIO $ fpSpecialOp WSF.Arccosh xe -- The argument should not be less than or equal to -1, -- nor should it be greater than or equal to +1 (CE.Atanh _, xe) -> liftIO $ fpSpecialOp WSF.Arctanh xe -- The argument should not cause the result to overflow (CE.Ceiling _, xe) -> liftIO $ fpOp (\(_ :: WFP.FloatInfoRepr fi) -> WFP.iFloatRound @_ @fi sym WI.RTP) xe -- The argument should not cause the result to overflow (CE.Floor _, xe) -> liftIO $ fpOp (\(_ :: WFP.FloatInfoRepr fi) -> WFP.iFloatRound @_ @fi sym WI.RTN) xe (CE.BwNot _, xe) -> liftIO $ case xe of XBool e -> XBool <$> WI.notPred sym e _ -> bvOp (WI.bvNotBits sym) xe (CE.Cast _ tp, xe) -> liftIO $ castOp sym origExpr tp xe (CE.GetField atp _ftp extractor, xe) -> translateGetField atp extractor xe where -- Translate an 'CE.Abs' operation and its argument into a what4 -- representation of the appropriate type. translateAbs :: XExpr sym -> TransM sym (XExpr sym) translateAbs xe = do addBVSidePred1 xe $ \e w _ -> do -- The argument should not be INT_MIN bvIntMin <- liftIO $ WI.bvLit sym w (BV.minSigned w) eqIntMin <- liftIO $ WI.bvEq sym e bvIntMin WI.notPred sym eqIntMin liftIO $ numOp bvAbs fpAbs xe where bvAbs :: BVOp1 sym w bvAbs e = do zero <- WI.bvLit sym knownNat (BV.zero knownNat) e_neg <- WI.bvSlt sym e zero neg_e <- WI.bvSub sym zero e WI.bvIte sym e_neg neg_e e fpAbs :: forall fi . FPOp1 sym fi fpAbs _ e = WFP.iFloatAbs @_ @fi sym e -- Translate a 'CE.GetField' operation and its argument into a what4 -- representation. If the argument is not a struct, panic. translateGetField :: forall struct s. KnownSymbol s => CT.Type struct -- ^ The type of the argument -> (struct -> CT.Field s b) -- ^ Extract a struct field -> XExpr sym -- ^ The argument value (should be a struct) -> TransM sym (XExpr sym) translateGetField tp extractor xe = case (tp, xe) of (CT.Struct s, XStruct xes) -> case mIx s of Just ix -> return $ xes !! ix Nothing -> panic [ "Could not find field " ++ show fieldNameRepr , show s ] _ -> unexpectedValue "get-field operation" where fieldNameRepr :: SymbolRepr s fieldNameRepr = fieldName (extractor undefined) structFieldNameReprs :: CT.Struct struct => struct -> [Some SymbolRepr] structFieldNameReprs s = valueName <$> CT.toValues s mIx :: CT.Struct struct => struct -> Maybe Int mIx s = elemIndex (Some fieldNameRepr) (structFieldNameReprs s) -- Translate a 'CE.Sign' operation (i.e, 'signum') and its argument into a -- what4 representation of the appropriate type. We translate @signum x@ as -- @x > 0 ? 1 : (x < 0 ? -1 : x)@. This matches how copilot-c99 translates -- 'CE.Sign' to C code. translateSign :: XExpr sym -> TransM sym (XExpr sym) translateSign xe = liftIO $ numOp bvSign fpSign xe where bvSign :: BVOp1 sym w bvSign e = do zero <- WI.bvLit sym knownRepr (BV.zero knownNat) neg_one <- WI.bvLit sym knownNat (BV.mkBV knownNat (-1)) pos_one <- WI.bvLit sym knownNat (BV.mkBV knownNat 1) e_neg <- WI.bvSlt sym e zero e_pos <- WI.bvSgt sym e zero t <- WI.bvIte sym e_neg neg_one e WI.bvIte sym e_pos pos_one t fpSign :: forall fi . FPOp1 sym fi fpSign fiRepr e = do zero <- fpLit fiRepr 0.0 neg_one <- fpLit fiRepr (-1.0) pos_one <- fpLit fiRepr 1.0 e_neg <- WFP.iFloatLt @_ @fi sym e zero e_pos <- WFP.iFloatGt @_ @fi sym e zero t <- WFP.iFloatIte @_ @fi sym e_neg neg_one e WFP.iFloatIte @_ @fi sym e_pos pos_one t -- Check the type of the argument. If the argument is a bitvector value, -- apply the 'BVOp1'. If the argument is a floating-point value, apply the -- 'FPOp1'. Otherwise, 'panic'. numOp :: (forall w . BVOp1 sym w) -> (forall fpp . FPOp1 sym fpp) -> XExpr sym -> IO (XExpr sym) numOp bvOp fpOp xe = case xe of XInt8 e -> XInt8 <$> bvOp e XInt16 e -> XInt16 <$> bvOp e XInt32 e -> XInt32 <$> bvOp e XInt64 e -> XInt64 <$> bvOp e XWord8 e -> XWord8 <$> bvOp e XWord16 e -> XWord16 <$> bvOp e XWord32 e -> XWord32 <$> bvOp e XWord64 e -> XWord64 <$> bvOp e XFloat e -> XFloat <$> fpOp WFP.SingleFloatRepr e XDouble e -> XDouble <$> fpOp WFP.DoubleFloatRepr e _ -> unexpectedValue "numOp" bvOp :: (forall w . BVOp1 sym w) -> XExpr sym -> IO (XExpr sym) bvOp f xe = case xe of XInt8 e -> XInt8 <$> f e XInt16 e -> XInt16 <$> f e XInt32 e -> XInt32 <$> f e XInt64 e -> XInt64 <$> f e XWord8 e -> XWord8 <$> f e XWord16 e -> XWord16 <$> f e XWord32 e -> XWord32 <$> f e XWord64 e -> XWord64 <$> f e _ -> unexpectedValue "bvOp" fpOp :: (forall fi . FPOp1 sym fi) -> XExpr sym -> IO (XExpr sym) fpOp g xe = case xe of XFloat e -> XFloat <$> g WFP.SingleFloatRepr e XDouble e -> XDouble <$> g WFP.DoubleFloatRepr e _ -> unexpectedValue "fpOp" -- Translate a special-floating operation to the corresponding what4 -- operation. These operations will be treated as uninterpreted functions in -- the solver. fpSpecialOp :: WSF.SpecialFunction (EmptyCtx ::> WSF.R) -> XExpr sym -> IO (XExpr sym) fpSpecialOp fn = fpOp (\fiRepr -> WFP.iFloatSpecialFunction1 sym fiRepr fn) -- Construct a floating-point literal value of the appropriate type. fpLit :: forall fi. WFP.FloatInfoRepr fi -> (forall frac. Fractional frac => frac) -> IO (WI.SymExpr sym (WFP.SymInterpretedFloatType sym fi)) fpLit fiRepr fracLit = case fiRepr of WFP.SingleFloatRepr -> WFP.iFloatLitSingle sym fracLit WFP.DoubleFloatRepr -> WFP.iFloatLitDouble sym fracLit _ -> panic ["Expected single- or double-precision float", show fiRepr] -- A catch-all error message to use when translation cannot proceed. unexpectedValue :: forall m x. (Panic.HasCallStack, MonadIO m) => String -> m x unexpectedValue op = panic [ "Unexpected value in " ++ op ++ ": " ++ show (CP.ppExpr origExpr) , show xe ] type BVOp2 sym w = (KnownNat w, 1 <= w) => WI.SymBV sym w -> WI.SymBV sym w -> IO (WI.SymBV sym w) type FPOp2 sym fi = WFP.FloatInfoRepr fi -> WI.SymExpr sym (WFP.SymInterpretedFloatType sym fi) -> WI.SymExpr sym (WFP.SymInterpretedFloatType sym fi) -> IO (WI.SymExpr sym (WFP.SymInterpretedFloatType sym fi)) type BoolCmp2 sym = WI.Pred sym -> WI.Pred sym -> IO (WI.Pred sym) type BVCmp2 sym w = (KnownNat w, 1 <= w) => WI.SymBV sym w -> WI.SymBV sym w -> IO (WI.Pred sym) type FPCmp2 sym fi = WFP.FloatInfoRepr fi -> WI.SymExpr sym (WFP.SymInterpretedFloatType sym fi) -> WI.SymExpr sym (WFP.SymInterpretedFloatType sym fi) -> IO (WI.Pred sym) translateOp2 :: forall sym a b c . WFP.IsInterpretedFloatExprBuilder sym => sym -> CE.Expr c -- ^ Original value we are translating (only used for error -- messages) -> CE.Op2 a b c -> XExpr sym -> XExpr sym -> TransM sym (XExpr sym) translateOp2 sym origExpr op xe1 xe2 = case (op, xe1, xe2) of (CE.And, XBool e1, XBool e2) -> liftIO $ fmap XBool $ WI.andPred sym e1 e2 (CE.And, _, _) -> unexpectedValues "and operation" (CE.Or, XBool e1, XBool e2) -> liftIO $ fmap XBool $ WI.orPred sym e1 e2 (CE.Or, _, _) -> unexpectedValues "or operation" (CE.Add _, xe1, xe2) -> translateAdd xe1 xe2 (CE.Sub _, xe1, xe2) -> translateSub xe1 xe2 (CE.Mul _, xe1, xe2) -> translateMul xe1 xe2 (CE.Mod _, xe1, xe2) -> do -- The second argument should not be zero addBVSidePred1 xe2 $ \e2 _ _ -> WI.bvIsNonzero sym e2 liftIO $ bvOp (WI.bvSrem sym) (WI.bvUrem sym) xe1 xe2 (CE.Div _, xe1, xe2) -> do -- The second argument should not be zero addBVSidePred1 xe2 $ \e2 _ _ -> WI.bvIsNonzero sym e2 liftIO $ bvOp (WI.bvSdiv sym) (WI.bvUdiv sym) xe1 xe2 -- We do not track any side conditions for floating-point operations -- (see Note [Side conditions for floating-point operations]), but we will -- make a note of which operations have partial inputs. -- The second argument should not be zero (CE.Fdiv _, xe1, xe2) -> liftIO $ fpOp (\(_ :: WFP.FloatInfoRepr fi) -> WFP.iFloatDiv @_ @fi sym fpRM) xe1 xe2 -- None of the following should happen: -- -- * The first argument is negative, and the second argument is a finite -- noninteger -- -- * The first argument is zero, and the second argument is negative -- -- * The arguments cause the result to overflow -- -- * The arguments cause the result to underflow (CE.Pow _, xe1, xe2) -> liftIO $ fpSpecialOp WSF.Pow xe1 xe2 -- The second argument should not be negative or zero (CE.Logb _, xe1, xe2) -> liftIO $ fpOp logbFn xe1 xe2 where logbFn :: forall fi . FPOp2 sym fi -- Implement logb(e1,e2) as log(e2)/log(e1). This matches how copilot-c99 -- translates Logb to C code. logbFn fiRepr e1 e2 = do re1 <- WFP.iFloatSpecialFunction1 sym fiRepr WSF.Log e1 re2 <- WFP.iFloatSpecialFunction1 sym fiRepr WSF.Log e2 WFP.iFloatDiv @_ @fi sym fpRM re2 re1 (CE.Atan2 _, xe1, xe2) -> liftIO $ fpSpecialOp WSF.Arctan2 xe1 xe2 (CE.Eq _, xe1, xe2) -> liftIO $ cmp (WI.eqPred sym) (WI.bvEq sym) (\(_ :: WFP.FloatInfoRepr fi) -> WFP.iFloatEq @_ @fi sym) xe1 xe2 (CE.Ne _, xe1, xe2) -> translateNe xe1 xe2 (CE.Le _, xe1, xe2) -> liftIO $ numCmp (WI.bvSle sym) (WI.bvUle sym) (\(_ :: WFP.FloatInfoRepr fi) -> WFP.iFloatLe @_ @fi sym) xe1 xe2 (CE.Ge _, xe1, xe2) -> liftIO $ numCmp (WI.bvSge sym) (WI.bvUge sym) (\(_ :: WFP.FloatInfoRepr fi) -> WFP.iFloatGe @_ @fi sym) xe1 xe2 (CE.Lt _, xe1, xe2) -> liftIO $ numCmp (WI.bvSlt sym) (WI.bvUlt sym) (\(_ :: WFP.FloatInfoRepr fi) -> WFP.iFloatLt @_ @fi sym) xe1 xe2 (CE.Gt _, xe1, xe2) -> liftIO $ numCmp (WI.bvSgt sym) (WI.bvUgt sym) (\(_ :: WFP.FloatInfoRepr fi) -> WFP.iFloatGt @_ @fi sym) xe1 xe2 (CE.BwAnd _, xe1, xe2) -> liftIO $ bvOp (WI.bvAndBits sym) (WI.bvAndBits sym) xe1 xe2 (CE.BwOr _, xe1, xe2) -> liftIO $ bvOp (WI.bvOrBits sym) (WI.bvOrBits sym) xe1 xe2 (CE.BwXor _, xe1, xe2) -> liftIO $ bvOp (WI.bvXorBits sym) (WI.bvXorBits sym) xe1 xe2 (CE.BwShiftL _ _, xe1, xe2) -> translateBwShiftL xe1 xe2 (CE.BwShiftR _ _, xe1, xe2) -> translateBwShiftR xe1 xe2 (CE.Index _, xe1, xe2) -> translateIndex xe1 xe2 (CE.UpdateField atp _ftp extractor, structXe, fieldXe) -> translateUpdateField atp extractor structXe fieldXe where -- Translate an 'CE.Add' operation and its arguments into a what4 -- representation of the appropriate type. translateAdd :: XExpr sym -> XExpr sym -> TransM sym (XExpr sym) translateAdd xe1 xe2 = do addBVSidePred2 xe1 xe2 $ \e1 e2 _ sgn -> -- The arguments should not result in signed overflow or underflow case sgn of Signed -> do (wrap, _) <- WI.addSignedOF sym e1 e2 WI.notPred sym wrap Unsigned -> pure $ WI.truePred sym liftIO $ numOp (WI.bvAdd sym) (\(_ :: WFP.FloatInfoRepr fi) -> WFP.iFloatAdd @_ @fi sym fpRM) xe1 xe2 -- Translate a 'CE.Sub' operation and its arguments into a what4 -- representation of the appropriate type. translateSub :: XExpr sym -> XExpr sym -> TransM sym (XExpr sym) translateSub xe1 xe2 = do addBVSidePred2 xe1 xe2 $ \e1 e2 _ sgn -> -- The arguments should not result in signed overflow or underflow case sgn of Signed -> do (wrap, _) <- WI.subSignedOF sym e1 e2 WI.notPred sym wrap Unsigned -> pure $ WI.truePred sym liftIO $ numOp (WI.bvSub sym) (\(_ :: WFP.FloatInfoRepr fi) -> WFP.iFloatSub @_ @fi sym fpRM) xe1 xe2 -- Translate a 'CE.Mul' operation and its arguments into a what4 -- representation of the appropriate type. translateMul :: XExpr sym -> XExpr sym -> TransM sym (XExpr sym) translateMul xe1 xe2 = do addBVSidePred2 xe1 xe2 $ \e1 e2 _ sgn -> -- The arguments should not result in signed overflow or underflow case sgn of Signed -> do (wrap, _) <- WI.mulSignedOF sym e1 e2 WI.notPred sym wrap Unsigned -> pure $ WI.truePred sym liftIO $ numOp (WI.bvMul sym) (\(_ :: WFP.FloatInfoRepr fi) -> WFP.iFloatMul @_ @fi sym fpRM) xe1 xe2 -- Translate an 'CE.Ne' operation and its arguments into a what4 -- representation of the appropriate type. translateNe :: XExpr sym -> XExpr sym -> TransM sym (XExpr sym) translateNe xe1 xe2 = liftIO $ cmp neqPred bvNeq fpNeq xe1 xe2 where neqPred :: BoolCmp2 sym neqPred e1 e2 = do e <- WI.eqPred sym e1 e2 WI.notPred sym e bvNeq :: forall w . BVCmp2 sym w bvNeq e1 e2 = do e <- WI.bvEq sym e1 e2 WI.notPred sym e fpNeq :: forall fi . FPCmp2 sym fi fpNeq _ e1 e2 = do e <- WFP.iFloatEq @_ @fi sym e1 e2 WI.notPred sym e -- Translate a 'CE.BwShiftL' operation and its arguments into a what4 -- representation. -- -- Note: we are interpreting the shifter as an unsigned bitvector regardless -- of whether it is a word or an int. translateBwShiftL :: XExpr sym -> XExpr sym -> TransM sym (XExpr sym) translateBwShiftL xe1 xe2 = do -- These partial pattern matches on Just should always succeed because -- BwShiftL should always have bitvectors as arguments. Just (SomeBVExpr e1 w1 sgn1 ctor1) <- return $ asBVExpr xe1 Just (SomeBVExpr e2 w2 _ _ ) <- return $ asBVExpr xe2 e2' <- liftIO $ case testNatCases w1 w2 of NatCaseLT LeqProof -> WI.bvTrunc sym w1 e2 NatCaseEQ -> return e2 NatCaseGT LeqProof -> WI.bvZext sym w1 e2 res <- liftIO $ WI.bvShl sym e1 e2' -- The second argument should not be greater than or equal to the bit -- width wBV <- liftIO $ WI.bvLit sym w1 $ BV.width w1 notTooLarge <- liftIO $ WI.bvUlt sym e2' wBV addSidePred notTooLarge case sgn1 of Unsigned -> do -- Non-zero bits should not be shifted out otherDirection <- liftIO $ WI.bvLshr sym res e2' noWrap <- liftIO $ WI.bvEq sym e1 otherDirection addSidePred noWrap Signed -> do -- Bits that disagree with the sign bit should not be shifted out otherDirection <- liftIO $ WI.bvAshr sym res e2' noWrap <- liftIO $ WI.bvEq sym e1 otherDirection addSidePred noWrap return $ ctor1 res -- Translate a 'CE.BwShiftL' operation and its arguments into a what4 -- representation. -- -- Note: we are interpreting the shifter as an unsigned bitvector regardless -- of whether it is a word or an int. translateBwShiftR :: XExpr sym -> XExpr sym -> TransM sym (XExpr sym) translateBwShiftR xe1 xe2 = do -- These partial pattern matches on Just should always succeed because -- BwShiftL should always have bitvectors as arguments. Just (SomeBVExpr e1 w1 sgn1 ctor1) <- return $ asBVExpr xe1 Just (SomeBVExpr e2 w2 _ _ ) <- return $ asBVExpr xe2 e2' <- liftIO $ case testNatCases w1 w2 of NatCaseLT LeqProof -> WI.bvTrunc sym w1 e2 NatCaseEQ -> return e2 NatCaseGT LeqProof -> WI.bvZext sym w1 e2 -- The second argument should not be greater than or equal to the bit -- width wBV <- liftIO $ WI.bvLit sym w1 $ BV.width w1 notTooLarge <- liftIO $ WI.bvUlt sym e2' wBV addSidePred notTooLarge liftIO $ fmap ctor1 $ case sgn1 of Signed -> WI.bvAshr sym e1 e2' Unsigned -> WI.bvLshr sym e1 e2' -- Translate an 'CE.Index' operation and its arguments into a what4 -- representation. This checks that the first argument is an 'XArray' and -- the second argument is an 'XWord32', invoking 'panic' is this invariant -- is not upheld. -- -- Note: Currently, copilot only checks if array indices are out of bounds -- as a side condition. The method of translation we are using simply -- creates a nest of if-then-else expression to check the index expression -- against all possible indices. If the index expression is known by the -- solver to be out of bounds (for instance, if it is a constant 5 for an -- array of 5 elements), then the if-then-else will trivially resolve to -- true. translateIndex :: XExpr sym -> XExpr sym -> TransM sym (XExpr sym) translateIndex xe1 xe2 = case (xe1, xe2) of (XArray xes, XWord32 ix) -> do -- The second argument should not be out of bounds (i.e., greater than -- or equal to the length of the array) xesLenBV <- liftIO $ WI.bvLit sym knownNat $ BV.mkBV knownNat $ toInteger $ V.lengthInt xes inRange <- liftIO $ WI.bvUlt sym ix xesLenBV addSidePred inRange liftIO $ buildIndexExpr sym ix xes _ -> unexpectedValues "index operation" -- Translate an 'CE.UpdateField' operation and its arguments into a what4 -- representation. This function will panic if one of the following does not -- hold: -- -- - The argument is not a struct. -- -- - The struct's field cannot be found. translateUpdateField :: forall struct s. KnownSymbol s => CT.Type struct -- ^ The type of the struct argument -> (struct -> CT.Field s b) -- ^ Extract a struct field -> XExpr sym -- ^ The first argument value (should be a struct) -> XExpr sym -- ^ The second argument value (should be the same type -- as the struct field) -> TransM sym (XExpr sym) -- ^ The first argument value, but with an updated -- value for the supplied field. translateUpdateField structTp extractor structXe newFieldXe = case (structTp, structXe) of (CT.Struct s, XStruct structFieldXes) -> case mIx s of Just ix -> return $ XStruct $ updateAt ix newFieldXe structFieldXes Nothing -> panic [ "Could not find field " ++ show fieldNameRepr , show s ] _ -> unexpectedValues "update-field operation" where -- Update an element of a list at a particular index. This assumes the -- preconditions that the index is a non-negative number that is less -- than the length of the list. updateAt :: forall a. Int -> a -> [a] -> [a] updateAt _ _ [] = [] updateAt 0 new (_:xs) = new : xs updateAt n new (x:xs) = x : updateAt (n-1) new xs fieldNameRepr :: SymbolRepr s fieldNameRepr = fieldName (extractor undefined) structFieldNameReprs :: CT.Struct struct => struct -> [Some SymbolRepr] structFieldNameReprs s = valueName <$> CT.toValues s mIx :: CT.Struct struct => struct -> Maybe Int mIx s = elemIndex (Some fieldNameRepr) (structFieldNameReprs s) -- Check the types of the arguments. If the arguments are bitvector values, -- apply the 'BVOp2'. If the arguments are floating-point values, apply the -- 'FPOp2'. Otherwise, 'panic'. numOp :: (forall w . BVOp2 sym w) -> (forall fi . FPOp2 sym fi) -> XExpr sym -> XExpr sym -> IO (XExpr sym) numOp bvOp fpOp xe1 xe2 = case (xe1, xe2) of (XInt8 e1, XInt8 e2) -> XInt8 <$> bvOp e1 e2 (XInt16 e1, XInt16 e2) -> XInt16 <$> bvOp e1 e2 (XInt32 e1, XInt32 e2) -> XInt32 <$> bvOp e1 e2 (XInt64 e1, XInt64 e2) -> XInt64 <$> bvOp e1 e2 (XWord8 e1, XWord8 e2) -> XWord8 <$> bvOp e1 e2 (XWord16 e1, XWord16 e2) -> XWord16 <$> bvOp e1 e2 (XWord32 e1, XWord32 e2) -> XWord32 <$> bvOp e1 e2 (XWord64 e1, XWord64 e2) -> XWord64 <$> bvOp e1 e2 (XFloat e1, XFloat e2) -> XFloat <$> fpOp WFP.SingleFloatRepr e1 e2 (XDouble e1, XDouble e2) -> XDouble <$> fpOp WFP.DoubleFloatRepr e1 e2 _ -> unexpectedValues "numOp" -- Check the types of the arguments. If the arguments are signed bitvector -- values, apply the first 'BVOp2'. If the arguments are unsigned bitvector -- values, apply the second 'BVOp2'. Otherwise, 'panic'. bvOp :: (forall w . BVOp2 sym w) -> (forall w . BVOp2 sym w) -> XExpr sym -> XExpr sym -> IO (XExpr sym) bvOp opS opU xe1 xe2 = case (xe1, xe2) of (XInt8 e1, XInt8 e2) -> XInt8 <$> opS e1 e2 (XInt16 e1, XInt16 e2) -> XInt16 <$> opS e1 e2 (XInt32 e1, XInt32 e2) -> XInt32 <$> opS e1 e2 (XInt64 e1, XInt64 e2) -> XInt64 <$> opS e1 e2 (XWord8 e1, XWord8 e2) -> XWord8 <$> opU e1 e2 (XWord16 e1, XWord16 e2) -> XWord16 <$> opU e1 e2 (XWord32 e1, XWord32 e2) -> XWord32 <$> opU e1 e2 (XWord64 e1, XWord64 e2) -> XWord64 <$> opU e1 e2 _ -> unexpectedValues "bvOp" fpOp :: (forall fi . FPOp2 sym fi) -> XExpr sym -> XExpr sym -> IO (XExpr sym) fpOp op xe1 xe2 = case (xe1, xe2) of (XFloat e1, XFloat e2) -> XFloat <$> op WFP.SingleFloatRepr e1 e2 (XDouble e1, XDouble e2) -> XDouble <$> op WFP.DoubleFloatRepr e1 e2 _ -> unexpectedValues "fpOp" -- Translate a special-floating operation to the corresponding what4 -- operation. These operations will be treated as uninterpreted functions in -- the solver. fpSpecialOp :: WSF.SpecialFunction (EmptyCtx ::> WSF.R ::> WSF.R) -> XExpr sym -> XExpr sym -> IO (XExpr sym) fpSpecialOp fn = fpOp (\fiRepr -> WFP.iFloatSpecialFunction2 sym fiRepr fn) -- Check the types of the arguments. If the arguments are bitvector values, -- apply the 'BVCmp2'. If the arguments are floating-point values, apply the -- 'FPCmp2'. Otherwise, 'panic'. cmp :: BoolCmp2 sym -> (forall w . BVCmp2 sym w) -> (forall fi . FPCmp2 sym fi) -> XExpr sym -> XExpr sym -> IO (XExpr sym) cmp boolOp bvOp fpOp xe1 xe2 = case (xe1, xe2) of (XBool e1, XBool e2) -> XBool <$> boolOp e1 e2 (XInt8 e1, XInt8 e2) -> XBool <$> bvOp e1 e2 (XInt16 e1, XInt16 e2) -> XBool <$> bvOp e1 e2 (XInt32 e1, XInt32 e2) -> XBool <$> bvOp e1 e2 (XInt64 e1, XInt64 e2) -> XBool <$> bvOp e1 e2 (XWord8 e1, XWord8 e2) -> XBool <$> bvOp e1 e2 (XWord16 e1, XWord16 e2) -> XBool <$> bvOp e1 e2 (XWord32 e1, XWord32 e2) -> XBool <$> bvOp e1 e2 (XWord64 e1, XWord64 e2) -> XBool <$> bvOp e1 e2 (XFloat e1, XFloat e2) -> XBool <$> fpOp WFP.SingleFloatRepr e1 e2 (XDouble e1, XDouble e2) -> XBool <$> fpOp WFP.DoubleFloatRepr e1 e2 _ -> unexpectedValues "cmp" -- Check the types of the arguments. If the arguments are signed bitvector -- values, apply the first 'BVCmp2'. If the arguments are unsigned bitvector -- values, apply the second 'BVCmp2'. If the arguments are floating-point -- values, apply the 'FPCmp2'. Otherwise, 'panic'. numCmp :: (forall w . BVCmp2 sym w) -> (forall w . BVCmp2 sym w) -> (forall fi . FPCmp2 sym fi) -> XExpr sym -> XExpr sym -> IO (XExpr sym) numCmp bvSOp bvUOp fpOp xe1 xe2 = case (xe1, xe2) of (XInt8 e1, XInt8 e2) -> XBool <$> bvSOp e1 e2 (XInt16 e1, XInt16 e2) -> XBool <$> bvSOp e1 e2 (XInt32 e1, XInt32 e2) -> XBool <$> bvSOp e1 e2 (XInt64 e1, XInt64 e2) -> XBool <$> bvSOp e1 e2 (XWord8 e1, XWord8 e2) -> XBool <$> bvUOp e1 e2 (XWord16 e1, XWord16 e2) -> XBool <$> bvUOp e1 e2 (XWord32 e1, XWord32 e2) -> XBool <$> bvUOp e1 e2 (XWord64 e1, XWord64 e2) -> XBool <$> bvUOp e1 e2 (XFloat e1, XFloat e2) -> XBool <$> fpOp WFP.SingleFloatRepr e1 e2 (XDouble e1, XDouble e2) -> XBool <$> fpOp WFP.DoubleFloatRepr e1 e2 _ -> unexpectedValues "numCmp" -- A catch-all error message to use when translation cannot proceed. unexpectedValues :: forall m x. (Panic.HasCallStack, MonadIO m) => String -> m x unexpectedValues op = panic [ "Unexpected values in " ++ op ++ ": " ++ show (CP.ppExpr origExpr) , show xe1, show xe2 ] translateOp3 :: forall sym a b c d . WFP.IsInterpretedFloatExprBuilder sym => sym -> CE.Expr d -- ^ Original value we are translating (only used for error -- messages) -> CE.Op3 a b c d -> XExpr sym -> XExpr sym -> XExpr sym -> TransM sym (XExpr sym) translateOp3 sym origExpr op xe1 xe2 xe3 = case (op, xe1, xe2, xe3) of (CE.Mux _, XBool te, xe1, xe2) -> liftIO $ mkIte sym te xe1 xe2 (CE.Mux _, _, _, _) -> unexpectedValues "mux operation" (CE.UpdateArray _, xe1, xe2, xe3) -> translateUpdateArray xe1 xe2 xe3 where -- Translate an 'CE.UpdateArray' operation and its arguments into a what4 -- representation. This checks that the first argument is an 'XArray' and -- the second argument is an 'XWord32', invoking 'panic' is this invariant -- is not upheld. -- -- Note: Currently, copilot only checks if array indices are out of bounds -- as a side condition. The method of translation we are using simply -- creates a nest of if-then-else expression to check the index expression -- against all possible indices. If the index expression is known by the -- solver to be out of bounds (for instance, if it is a constant 5 for an -- array of 5 elements), then the if-then-else will trivially resolve to -- true. translateUpdateArray :: XExpr sym -> XExpr sym -> XExpr sym -> TransM sym (XExpr sym) translateUpdateArray xe1 xe2 newXe = case (xe1, xe2) of (XArray xes, XWord32 ix) -> do -- The second argument should not be out of bounds (i.e., greater than -- or equal to the length of the array) xesLenBV <- liftIO $ WI.bvLit sym knownNat $ BV.mkBV knownNat $ toInteger $ V.lengthInt xes inRange <- liftIO $ WI.bvUlt sym ix xesLenBV addSidePred inRange xes' <- liftIO $ buildUpdateArrayExpr sym xes ix newXe pure $ XArray xes' _ -> unexpectedValues "update array operation" unexpectedValues :: forall m x . (Panic.HasCallStack, MonadIO m) => String -> m x unexpectedValues op = panic [ "Unexpected values in " ++ op ++ ":" , show (CP.ppExpr origExpr), show xe1, show xe2, show xe3 ] -- | Construct an expression that indexes into an array by building a chain of -- @if@ expressions, where each expression checks if the current index is equal -- to a given index in the array. If the indices are equal, return the element -- of the array at that index. Otherwise, proceed to the next @if@ expression, -- which checks the next index in the array. buildIndexExpr :: forall sym n. (1 <= n, WFP.IsInterpretedFloatExprBuilder sym) => sym -> WI.SymBV sym 32 -- ^ Index -> V.Vector n (XExpr sym) -- ^ Elements -> IO (XExpr sym) buildIndexExpr sym ix = loop 0 where loop :: forall n'. (1 <= n') => Word32 -> V.Vector n' (XExpr sym) -> IO (XExpr sym) loop curIx xelts = case V.uncons xelts of -- Base case, exactly one element left (xe, Left Refl) -> return xe -- Recursive case (xe, Right xelts') -> do LeqProof <- return $ V.nonEmpty xelts' rstExpr <- loop (curIx+1) xelts' curIxExpr <- WI.bvLit sym knownNat (BV.word32 curIx) ixEq <- WI.bvEq sym curIxExpr ix mkIte sym ixEq xe rstExpr -- | Construct an expression that updates an array element at a particular index -- by building a chain of @if@ expressions, where each expression checks if the -- current index is equal to a given index in the array. If the indices are -- equal, return the array with the element at that index updated. Otherwise, -- proceed to the next @if@ expression, which checks the next index in the -- array. buildUpdateArrayExpr :: forall sym n. (1 <= n, WFP.IsInterpretedFloatExprBuilder sym) => sym -> V.Vector n (XExpr sym) -- ^ Elements -> WI.SymBV sym 32 -- ^ Index -> XExpr sym -- ^ New element -> IO (V.Vector n (XExpr sym)) buildUpdateArrayExpr sym xelts ix newXe = loop (knownNat @0) where n :: NatRepr n n = V.length xelts n32 :: NatRepr 32 n32 = knownNat @32 loop :: forall i. ((i + 1) <= n) => NatRepr i -> IO (V.Vector n (XExpr sym)) loop curIx = case testStrictLeq nextIx n of -- Recursive case Left LeqProof -> do rstExpr <- loop nextIx curIxExpr <- WI.bvLit sym n32 $ BV.mkBV n32 $ intValue curIx ixEq <- WI.bvEq sym curIxExpr ix V.zipWithM (mkIte sym ixEq) newXelts rstExpr -- Base case, we are at the last possible index (n - 1) Right Refl -> pure newXelts where nextIx :: NatRepr (i + 1) nextIx = incNat curIx newXelts :: V.Vector n (XExpr sym) newXelts = V.insertAt curIx newXe xelts -- | Construct an @if@ expression of the appropriate type. mkIte :: WFP.IsInterpretedFloatExprBuilder sym => sym -> WI.Pred sym -> XExpr sym -> XExpr sym -> IO (XExpr sym) mkIte sym pred xe1 xe2 = case (xe1, xe2) of (XBool e1, XBool e2) -> XBool <$> WI.itePred sym pred e1 e2 (XInt8 e1, XInt8 e2) -> XInt8 <$> WI.bvIte sym pred e1 e2 (XInt16 e1, XInt16 e2) -> XInt16 <$> WI.bvIte sym pred e1 e2 (XInt32 e1, XInt32 e2) -> XInt32 <$> WI.bvIte sym pred e1 e2 (XInt64 e1, XInt64 e2) -> XInt64 <$> WI.bvIte sym pred e1 e2 (XWord8 e1, XWord8 e2) -> XWord8 <$> WI.bvIte sym pred e1 e2 (XWord16 e1, XWord16 e2) -> XWord16 <$> WI.bvIte sym pred e1 e2 (XWord32 e1, XWord32 e2) -> XWord32 <$> WI.bvIte sym pred e1 e2 (XWord64 e1, XWord64 e2) -> XWord64 <$> WI.bvIte sym pred e1 e2 (XFloat e1, XFloat e2) -> XFloat <$> WFP.iFloatIte @_ @WFP.SingleFloat sym pred e1 e2 (XDouble e1, XDouble e2) -> XDouble <$> WFP.iFloatIte @_ @WFP.DoubleFloat sym pred e1 e2 (XStruct xes1, XStruct xes2) -> XStruct <$> zipWithM (mkIte sym pred) xes1 xes2 (XEmptyArray tp1, XEmptyArray tp2) -> case tp1 `testEquality` tp2 of Just Refl -> return (XEmptyArray tp1) Nothing -> panic [ "Element type mismatch in ite" , show tp1 , show tp2 ] (XArray xes1, XArray xes2) -> case V.length xes1 `testEquality` V.length xes2 of Just Refl -> XArray <$> V.zipWithM (mkIte sym pred) xes1 xes2 Nothing -> panic [ "Array length mismatch in ite" , show (V.length xes1) , show (V.length xes2) ] _ -> panic ["Unexpected values in ite", show xe1, show xe2] -- | Cast an 'XExpr' to another 'XExpr' of a possibly differing type. castOp :: WFP.IsInterpretedFloatExprBuilder sym => sym -> CE.Expr b -- ^ Original value we are translating (only used for error -- messages) -> CT.Type a -- ^ Type we are casting to -> XExpr sym -- ^ Value to cast -> IO (XExpr sym) castOp sym origExpr tp xe = case (xe, tp) of -- "safe" casts that cannot lose information (XBool _, CT.Bool) -> return xe (XBool e, CT.Word8) -> XWord8 <$> WI.predToBV sym e knownNat (XBool e, CT.Word16) -> XWord16 <$> WI.predToBV sym e knownNat (XBool e, CT.Word32) -> XWord32 <$> WI.predToBV sym e knownNat (XBool e, CT.Word64) -> XWord64 <$> WI.predToBV sym e knownNat (XBool e, CT.Int8) -> XInt8 <$> WI.predToBV sym e knownNat (XBool e, CT.Int16) -> XInt16 <$> WI.predToBV sym e knownNat (XBool e, CT.Int32) -> XInt32 <$> WI.predToBV sym e knownNat (XBool e, CT.Int64) -> XInt64 <$> WI.predToBV sym e knownNat (XInt8 _, CT.Int8) -> return xe (XInt8 e, CT.Int16) -> XInt16 <$> WI.bvSext sym knownNat e (XInt8 e, CT.Int32) -> XInt32 <$> WI.bvSext sym knownNat e (XInt8 e, CT.Int64) -> XInt64 <$> WI.bvSext sym knownNat e (XInt16 _, CT.Int16) -> return xe (XInt16 e, CT.Int32) -> XInt32 <$> WI.bvSext sym knownNat e (XInt16 e, CT.Int64) -> XInt64 <$> WI.bvSext sym knownNat e (XInt32 _, CT.Int32) -> return xe (XInt32 e, CT.Int64) -> XInt64 <$> WI.bvSext sym knownNat e (XInt64 _, CT.Int64) -> return xe (XWord8 e, CT.Int16) -> XInt16 <$> WI.bvZext sym knownNat e (XWord8 e, CT.Int32) -> XInt32 <$> WI.bvZext sym knownNat e (XWord8 e, CT.Int64) -> XInt64 <$> WI.bvZext sym knownNat e (XWord8 _, CT.Word8) -> return xe (XWord8 e, CT.Word16) -> XWord16 <$> WI.bvZext sym knownNat e (XWord8 e, CT.Word32) -> XWord32 <$> WI.bvZext sym knownNat e (XWord8 e, CT.Word64) -> XWord64 <$> WI.bvZext sym knownNat e (XWord16 e, CT.Int32) -> XInt32 <$> WI.bvZext sym knownNat e (XWord16 e, CT.Int64) -> XInt64 <$> WI.bvZext sym knownNat e (XWord16 _, CT.Word16) -> return xe (XWord16 e, CT.Word32) -> XWord32 <$> WI.bvZext sym knownNat e (XWord16 e, CT.Word64) -> XWord64 <$> WI.bvZext sym knownNat e (XWord32 e, CT.Int64) -> XInt64 <$> WI.bvZext sym knownNat e (XWord32 _, CT.Word32) -> return xe (XWord32 e, CT.Word64) -> XWord64 <$> WI.bvZext sym knownNat e (XWord64 _, CT.Word64) -> return xe -- "unsafe" casts, which may lose information -- unsigned truncations (XWord64 e, CT.Word32) -> XWord32 <$> WI.bvTrunc sym knownNat e (XWord64 e, CT.Word16) -> XWord16 <$> WI.bvTrunc sym knownNat e (XWord64 e, CT.Word8) -> XWord8 <$> WI.bvTrunc sym knownNat e (XWord32 e, CT.Word16) -> XWord16 <$> WI.bvTrunc sym knownNat e (XWord32 e, CT.Word8) -> XWord8 <$> WI.bvTrunc sym knownNat e (XWord16 e, CT.Word8) -> XWord8 <$> WI.bvTrunc sym knownNat e -- signed truncations (XInt64 e, CT.Int32) -> XInt32 <$> WI.bvTrunc sym knownNat e (XInt64 e, CT.Int16) -> XInt16 <$> WI.bvTrunc sym knownNat e (XInt64 e, CT.Int8) -> XInt8 <$> WI.bvTrunc sym knownNat e (XInt32 e, CT.Int16) -> XInt16 <$> WI.bvTrunc sym knownNat e (XInt32 e, CT.Int8) -> XInt8 <$> WI.bvTrunc sym knownNat e (XInt16 e, CT.Int8) -> XInt8 <$> WI.bvTrunc sym knownNat e -- signed integer to float (XInt64 e, CT.Float) -> XFloat <$> WFP.iSBVToFloat sym WFP.SingleFloatRepr fpRM e (XInt32 e, CT.Float) -> XFloat <$> WFP.iSBVToFloat sym WFP.SingleFloatRepr fpRM e (XInt16 e, CT.Float) -> XFloat <$> WFP.iSBVToFloat sym WFP.SingleFloatRepr fpRM e (XInt8 e, CT.Float) -> XFloat <$> WFP.iSBVToFloat sym WFP.SingleFloatRepr fpRM e -- unsigned integer to float (XWord64 e, CT.Float) -> XFloat <$> WFP.iBVToFloat sym WFP.SingleFloatRepr fpRM e (XWord32 e, CT.Float) -> XFloat <$> WFP.iBVToFloat sym WFP.SingleFloatRepr fpRM e (XWord16 e, CT.Float) -> XFloat <$> WFP.iBVToFloat sym WFP.SingleFloatRepr fpRM e (XWord8 e, CT.Float) -> XFloat <$> WFP.iBVToFloat sym WFP.SingleFloatRepr fpRM e -- signed integer to double (XInt64 e, CT.Double) -> XDouble <$> WFP.iSBVToFloat sym WFP.DoubleFloatRepr fpRM e (XInt32 e, CT.Double) -> XDouble <$> WFP.iSBVToFloat sym WFP.DoubleFloatRepr fpRM e (XInt16 e, CT.Double) -> XDouble <$> WFP.iSBVToFloat sym WFP.DoubleFloatRepr fpRM e (XInt8 e, CT.Double) -> XDouble <$> WFP.iSBVToFloat sym WFP.DoubleFloatRepr fpRM e -- unsigned integer to double (XWord64 e, CT.Double) -> XDouble <$> WFP.iBVToFloat sym WFP.DoubleFloatRepr fpRM e (XWord32 e, CT.Double) -> XDouble <$> WFP.iBVToFloat sym WFP.DoubleFloatRepr fpRM e (XWord16 e, CT.Double) -> XDouble <$> WFP.iBVToFloat sym WFP.DoubleFloatRepr fpRM e (XWord8 e, CT.Double) -> XDouble <$> WFP.iBVToFloat sym WFP.DoubleFloatRepr fpRM e -- unsigned to signed conversion (XWord64 e, CT.Int64) -> return $ XInt64 e (XWord32 e, CT.Int32) -> return $ XInt32 e (XWord16 e, CT.Int16) -> return $ XInt16 e (XWord8 e, CT.Int8) -> return $ XInt8 e -- signed to unsigned conversion (XInt64 e, CT.Word64) -> return $ XWord64 e (XInt32 e, CT.Word32) -> return $ XWord32 e (XInt16 e, CT.Word16) -> return $ XWord16 e (XInt8 e, CT.Word8) -> return $ XWord8 e _ -> panic ["Could not compute cast", show (CP.ppExpr origExpr), show xe] -- * What4 representations of Copilot expressions -- | The What4 representation of a copilot expression. We do not attempt to -- track the type of the inner expression at the type level, but instead lump -- everything together into the @XExpr sym@ type. The only reason this is a GADT -- is for the array case; we need to know that the array length is strictly -- positive. data XExpr sym where XBool :: WI.SymExpr sym WT.BaseBoolType -> XExpr sym XInt8 :: WI.SymExpr sym (WT.BaseBVType 8) -> XExpr sym XInt16 :: WI.SymExpr sym (WT.BaseBVType 16) -> XExpr sym XInt32 :: WI.SymExpr sym (WT.BaseBVType 32) -> XExpr sym XInt64 :: WI.SymExpr sym (WT.BaseBVType 64) -> XExpr sym XWord8 :: WI.SymExpr sym (WT.BaseBVType 8) -> XExpr sym XWord16 :: WI.SymExpr sym (WT.BaseBVType 16) -> XExpr sym XWord32 :: WI.SymExpr sym (WT.BaseBVType 32) -> XExpr sym XWord64 :: WI.SymExpr sym (WT.BaseBVType 64) -> XExpr sym XFloat :: WI.SymExpr sym (WFP.SymInterpretedFloatType sym WFP.SingleFloat) -> XExpr sym XDouble :: WI.SymExpr sym (WFP.SymInterpretedFloatType sym WFP.DoubleFloat) -> XExpr sym -- | An empty array. The 'CT.Typed' constraint and accompanying 'CT.Type' -- field are necessary in order to record evidence that the array type can be -- used in a context where 'CT.Typed' is required. XEmptyArray :: CT.Typed t => CT.Type t -> XExpr sym -- | A non-empty array. The 'KnownNat' constraint is necessary in order to -- record evidence that the array type can be used in a context for 'CT.Typed' -- is required. XArray :: (KnownNat n, 1 <= n) => V.Vector n (XExpr sym) -> XExpr sym XStruct :: [XExpr sym] -> XExpr sym instance WI.IsExprBuilder sym => Show (XExpr sym) where show (XBool e) = "XBool " ++ show (WI.printSymExpr e) show (XInt8 e) = "XInt8 " ++ show (WI.printSymExpr e) show (XInt16 e) = "XInt16 " ++ show (WI.printSymExpr e) show (XInt32 e) = "XInt32 " ++ show (WI.printSymExpr e) show (XInt64 e) = "XInt64 " ++ show (WI.printSymExpr e) show (XWord8 e) = "XWord8 " ++ show (WI.printSymExpr e) show (XWord16 e) = "XWord16 " ++ show (WI.printSymExpr e) show (XWord32 e) = "XWord32 " ++ show (WI.printSymExpr e) show (XWord64 e) = "XWord64 " ++ show (WI.printSymExpr e) show (XFloat e) = "XFloat " ++ show (WI.printSymExpr e) show (XDouble e) = "XDouble " ++ show (WI.printSymExpr e) show (XEmptyArray _) = "[]" show (XArray vs) = showList (V.toList vs) "" show (XStruct xs) = "XStruct " ++ showList xs "" -- * Stream offsets -- | Streams expressions are evaluated in two possible modes. The \"absolute\" -- mode computes the value of a stream expression relative to the beginning of -- time @t=0@. The \"relative\" mode is useful for inductive proofs and the -- offset values are conceptually relative to some arbitrary, but fixed, index -- @j>=0@. In both cases, negative indexes are not allowed. -- -- The main difference between these modes is the interpretation of streams for -- the first values, which are in the \"buffer\" range. For absolute indices, -- the actual fixed values for the streams are returned; for relative indices, -- uninterpreted values are generated for the values in the stream buffer. For -- both modes, stream values after their buffer region are defined by their -- recurrence expression. data StreamOffset = AbsoluteOffset !Integer | RelativeOffset !Integer deriving (Eq, Ord, Show) -- | Increment a stream offset by a drop amount. addOffset :: StreamOffset -> CE.DropIdx -> StreamOffset addOffset (AbsoluteOffset i) j = AbsoluteOffset (i + toInteger j) addOffset (RelativeOffset i) j = RelativeOffset (i + toInteger j) -- * Auxiliary definitions -- | We assume round-near-even throughout, but this variable can be changed if -- needed. fpRM :: WI.RoundingMode fpRM = WI.RNE data CopilotWhat4 = CopilotWhat4 instance Panic.PanicComponent CopilotWhat4 where panicComponentName _ = "Copilot/What4 translation" panicComponentIssues _ = "https://github.com/Copilot-Language/copilot/issues" {-# NOINLINE Panic.panicComponentRevision #-} panicComponentRevision = $(Panic.useGitRevision) -- | Use this function rather than an error monad since it indicates that -- something in the implementation of @copilot-theorem@ is incorrect. panic :: (Panic.HasCallStack, MonadIO m) => [String] -> m a panic msg = Panic.panic CopilotWhat4 "Copilot.Theorem.What4" msg copilot-theorem-4.3/src/Copilot/Theorem/Kind2/0000755000000000000000000000000014762717277017456 5ustar0000000000000000copilot-theorem-4.3/src/Copilot/Theorem/Kind2/PrettyPrint.hs0000644000000000000000000000431514762717277022321 0ustar0000000000000000{-# LANGUAGE Safe #-} -- | Pretty print a Kind2 file defining predicates and propositions. module Copilot.Theorem.Kind2.PrettyPrint ( prettyPrint ) where import Copilot.Theorem.Misc.SExpr import qualified Copilot.Theorem.Misc.SExpr as SExpr import Copilot.Theorem.Kind2.AST import Data.List (intercalate) -- | A tree of expressions, in which the leafs are strings. type SSExpr = SExpr String -- | Reserved keyword prime. kwPrime = "prime" -- | Pretty print a Kind2 file. prettyPrint :: File -> String prettyPrint = intercalate "\n\n" . map (SExpr.toString shouldIndent id) . ppFile -- | Define the indentation policy of the S-Expressions shouldIndent :: SSExpr -> Bool shouldIndent (Atom _) = False shouldIndent (List [Atom a, Atom _]) = a `notElem` [kwPrime] shouldIndent _ = True -- | Convert a file into a sequence of expressions. ppFile :: File -> [SSExpr] ppFile (File preds props) = map ppPredDef preds ++ ppProps props -- | Convert a sequence of propositions into command to check each of them. ppProps :: [Prop] -> [SSExpr] ppProps ps = [ node "check-prop" [ list $ map ppProp ps ] ] -- | Convert a proposition into an expression. ppProp :: Prop -> SSExpr ppProp (Prop n t) = list [atom n, ppTerm t] -- | Convert a predicate into an expression. ppPredDef :: PredDef -> SSExpr ppPredDef pd = list [ atom "define-pred" , atom (predId pd) , list . map ppStateVarDef . predStateVars $ pd , node "init" [ppTerm $ predInit pd] , node "trans" [ppTerm $ predTrans pd] ] -- | Convert a state variable definition into an expression. ppStateVarDef :: StateVarDef -> SSExpr ppStateVarDef svd = list [atom (varId svd), ppType (varType svd)] -- | Convert a type into an expression. ppType :: Type -> SSExpr ppType Int = atom "Int" ppType Real = atom "Real" ppType Bool = atom "Bool" -- | Convert a term into an expression. ppTerm :: Term -> SSExpr ppTerm (ValueLiteral c) = atom c ppTerm (PrimedStateVar v) = list [atom kwPrime, atom v] ppTerm (StateVar v) = atom v ppTerm (FunApp f args) = node f $ map ppTerm args ppTerm (PredApp p t args) = node (p ++ "." ++ ext) $ map ppTerm args where ext = case t of Init -> "init" Trans -> "trans" copilot-theorem-4.3/src/Copilot/Theorem/Kind2/Translate.hs0000644000000000000000000001652514762717277021760 0ustar0000000000000000{-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE Safe #-} {-# LANGUAGE ViewPatterns #-} -- | Convert modular transition systems ('TransSys') into Kind2 file -- specifications. module Copilot.Theorem.Kind2.Translate ( toKind2 , Style (..) ) where import Copilot.Theorem.TransSys import qualified Copilot.Theorem.Kind2.AST as K import Control.Exception.Base (assert) import Data.Function (on) import Data.Maybe (fromJust) import Data.List (sort, sortBy) import Data.Map (Map, (!)) import qualified Data.Map as Map import qualified Data.Bimap as Bimap -- The following properties MUST hold for the given transition system : -- * Nodes are sorted by topological order -- * Nodes are `completed`, which means the dependency graph is transitive -- and each node imports all the local variables of its dependencies -- type DepGraph = Map NodeId [NodeId] -- | Style of the Kind2 files produced: modular (with multiple separate nodes), -- or all inlined (with only one node). -- -- In the modular style, the graph is simplified to remove cycles by collapsing -- all nodes participating in a strongly connected components. -- -- In the inlined style, the structure of the modular transition system is -- discarded and the graph is first turned into a /non-modular transition/ -- /system/ with only one node, which can be then converted into a Kind2 file. data Style = Inlined | Modular -- | Produce a Kind2 file that checks the properties specified. toKind2 :: Style -- ^ Style of the file (modular or inlined). -> [PropId] -- ^ Assumptions -> [PropId] -- ^ Properties to be checked -> TransSys -- ^ Modular transition system holding the system spec -> K.File toKind2 style assumptions checkedProps spec = addAssumptions spec assumptions $ trSpec (complete spec') predCallsGraph assumptions checkedProps where predCallsGraph = specDependenciesGraph spec' spec' = case style of Inlined -> inline spec Modular -> removeCycles spec trSpec :: TransSys -> DepGraph -> [PropId] -> [PropId] -> K.File trSpec spec predCallsGraph _assumptions checkedProps = K.File preds props where preds = map (trNode spec predCallsGraph) (specNodes spec) props = map trProp $ filter ((`elem` checkedProps) . fst) $ Map.toList (specProps spec) trProp :: (PropId, ExtVar) -> K.Prop trProp (pId, var) = K.Prop pId (trVar . extVarLocalPart $ var) trNode :: TransSys -> DepGraph -> Node -> K.PredDef trNode spec predCallsGraph node = K.PredDef { K.predId, K.predStateVars, K.predInit, K.predTrans } where predId = nodeId node predStateVars = gatherPredStateVars spec node predInit = mkConj $ initLocals node ++ map (trExpr False) (nodeConstrs node) ++ predCalls True spec predCallsGraph node predTrans = mkConj $ transLocals node ++ map (trExpr True) (nodeConstrs node) ++ predCalls False spec predCallsGraph node addAssumptions :: TransSys -> [PropId] -> K.File -> K.File addAssumptions spec assumptions (K.File {K.filePreds, K.fileProps}) = K.File (changeTail aux filePreds) fileProps where changeTail f (reverse -> l) = case l of [] -> error "impossible" x : xs -> reverse $ f x : xs aux pred = let init' = mkConj ( K.predInit pred : map K.StateVar vars ) trans' = mkConj ( K.predTrans pred : map K.PrimedStateVar vars ) in pred { K.predInit = init', K.predTrans = trans' } vars = let bindings = nodeImportedVars (specTopNode spec) toExtVar a = fromJust $ Map.lookup a (specProps spec) toTopVar (ExtVar nId v) = assert (nId == specTopNodeId spec) v in map (varName . toTopVar . toExtVar) assumptions -- The ordering really matters here because the variables -- have to be given in this order in a pred call -- Our convention : -- * First the local variables, sorted by alphabetical order -- * Then the imported variables, by alphabetical order on -- the father node then by alphabetical order on the variable name gatherPredStateVars :: TransSys -> Node -> [K.StateVarDef] gatherPredStateVars spec node = locals ++ imported where nodesMap = Map.fromList [(nodeId n, n) | n <- specNodes spec] extVarType :: ExtVar -> K.Type extVarType (ExtVar n v) = case nodeLocalVars (nodesMap ! n) ! v of VarDescr Integer _ -> K.Int VarDescr Bool _ -> K.Bool VarDescr Real _ -> K.Real locals = map (\v -> K.StateVarDef (varName v) (extVarType $ ExtVar (nodeId node) v) []) . sort . Map.keys $ nodeLocalVars node imported = map (\(v, ev) -> K.StateVarDef (varName v) (extVarType ev) []) . sortBy (compare `on` snd) . Bimap.toList $ nodeImportedVars node mkConj :: [K.Term] -> K.Term mkConj [] = trConst Bool True mkConj [x] = x mkConj xs = K.FunApp "and" xs mkEquality :: K.Term -> K.Term -> K.Term mkEquality t1 t2 = K.FunApp "=" [t1, t2] trVar :: Var -> K.Term trVar v = K.StateVar (varName v) trPrimedVar :: Var -> K.Term trPrimedVar v = K.PrimedStateVar (varName v) trConst :: Type t -> t -> K.Term trConst Integer v = K.ValueLiteral (show v) trConst Real v = K.ValueLiteral (show v) trConst Bool True = K.ValueLiteral "true" trConst Bool False = K.ValueLiteral "false" initLocals :: Node -> [K.Term] initLocals node = concatMap f (Map.toList $ nodeLocalVars node) where f (v, VarDescr t def) = case def of Pre c _ -> [mkEquality (trVar v) (trConst t c)] Expr e -> [mkEquality (trVar v) (trExpr False e)] Constrs cs -> map (trExpr False) cs transLocals :: Node -> [K.Term] transLocals node = concatMap f (Map.toList $ nodeLocalVars node) where f (v, VarDescr _ def) = case def of Pre _ v' -> [mkEquality (trPrimedVar v) (trVar v')] Expr e -> [mkEquality (trPrimedVar v) (trExpr True e)] Constrs cs -> map (trExpr True) cs predCalls :: Bool -> TransSys -> DepGraph -> Node -> [K.Term] predCalls isInitCall spec predCallsGraph node = map mkCall toCall where nid = nodeId node toCall = predCallsGraph ! nid nodesMap = Map.fromList [(nodeId n, n) | n <- specNodes spec] nodeLocals n = map (ExtVar n) . sort . Map.keys . nodeLocalVars $ (nodesMap ! n) mkCall callee | isInitCall = K.PredApp callee K.Init (argsSeq trVar) | otherwise = K.PredApp callee K.Trans (argsSeq trVar ++ argsSeq trPrimedVar) where calleeLocals = nodeLocals callee calleeImported = (concatMap nodeLocals . sort . nodeDependencies) $ nodesMap ! callee localAlias trVarF ev = case Bimap.lookupR ev $ nodeImportedVars node of Nothing -> error $ "This spec is not complete : " ++ show ev ++ " should be imported in " ++ nid Just v -> trVarF v argsSeq trVarF = map (localAlias trVarF) (calleeLocals ++ calleeImported) trExpr :: Bool -> Expr t -> K.Term trExpr primed = tr where tr :: forall t . Expr t -> K.Term tr (Const t c) = trConst t c tr (Ite _ c e1 e2) = K.FunApp "ite" [tr c, tr e1, tr e2] tr (Op1 _ op e) = K.FunApp (show op) [tr e] tr (Op2 _ op e1 e2) = K.FunApp (show op) [tr e1, tr e2] tr (VarE _ v) = if primed then trPrimedVar v else trVar v copilot-theorem-4.3/src/Copilot/Theorem/Kind2/Output.hs0000644000000000000000000000307514762717277021317 0ustar0000000000000000{-# LANGUAGE RankNTypes #-} {-# LANGUAGE Safe #-} -- | Parse output of Kind2. module Copilot.Theorem.Kind2.Output (parseOutput) where import Text.XML.Light hiding (findChild) import Copilot.Theorem.Prove as P import Data.Maybe (fromJust) import qualified Copilot.Theorem.Misc.Error as Err simpleName s = QName s Nothing Nothing -- | Parse output of Kind2. parseOutput :: String -- ^ Property whose validity is being checked. -> String -- ^ XML output of Kind2 -> P.Output parseOutput prop xml = fromJust $ do root <- parseXMLDoc xml case findAnswer . findPropTag $ root of "valid" -> return (Output Valid []) "falsifiable" -> return (Output Invalid []) s -> err $ "Unrecognized status : " ++ s where searchForRuntimeError = undefined findPropTag root = let rightElement elt = qName (elName elt) == "Property" && lookupAttr (simpleName "name") (elAttribs elt) == Just prop in case filterChildren rightElement root of tag : _ -> tag _ -> err $ "Tag for property " ++ prop ++ " not found" findAnswer tag = case findChildren (simpleName "Answer") tag of answTag : _ -> case onlyText (elContent answTag) of answ : _ -> cdData answ _ -> err "Invalid 'Answer' attribute" _ -> err "Attribute 'Answer' not found" err :: forall a . String -> a err msg = Err.fatal $ "Parse error while reading the Kind2 XML output : \n" ++ msg ++ "\n\n" ++ xml copilot-theorem-4.3/src/Copilot/Theorem/Kind2/AST.hs0000644000000000000000000000351114762717277020441 0ustar0000000000000000{-# LANGUAGE Safe #-} -- | Abstract syntax tree of Kind2 files. module Copilot.Theorem.Kind2.AST where -- | A file is a sequence of predicates and propositions. data File = File { filePreds :: [PredDef] , fileProps :: [Prop] } -- | A proposition is defined by a term. data Prop = Prop { propName :: String , propTerm :: Term } -- | A predicate definition. data PredDef = PredDef { predId :: String -- ^ Identifier for the predicate. , predStateVars :: [StateVarDef] -- ^ Variables identifying the states in the -- underlying state transition system. , predInit :: Term -- ^ Predicate that holds for initial -- states. , predTrans :: Term -- ^ Predicate that holds for two states, if -- there is state transition between them. } -- | A definition of a state variable. data StateVarDef = StateVarDef { varId :: String -- ^ Name of the variable. , varType :: Type -- ^ Type of the variable. , varFlags :: [StateVarFlag] } -- ^ Flags for the variable. -- | Types used in Kind2 files to represent Copilot types. -- -- The Kind2 backend provides functions to, additionally, constrain the range -- of numeric values depending on their Copilot type ('Int8', 'Int16', etc.). data Type = Int | Real | Bool -- | Possible flags for a state variable. data StateVarFlag = FConst -- | Type of the predicate, either belonging to an initial state or a pair of -- states with a transition. data PredType = Init | Trans -- | Datatype to describe a term in the Kind language. data Term = ValueLiteral String | PrimedStateVar String | StateVar String | FunApp String [Term] | PredApp String PredType [Term] copilot-theorem-4.3/src/Copilot/Theorem/Kind2/Prover.hs0000644000000000000000000000367414762717277021301 0ustar0000000000000000{-# LANGUAGE LambdaCase #-} {-# LANGUAGE Trustworthy #-} -- | A prover backend based on Kind2. module Copilot.Theorem.Kind2.Prover ( module Data.Default , Options (..) , kind2Prover ) where import Copilot.Theorem.Prove import Copilot.Theorem.Kind2.Output import Copilot.Theorem.Kind2.PrettyPrint import Copilot.Theorem.Kind2.Translate -- It seems [IO.openTempFile] doesn't work on Mac OSX import System.IO hiding (openTempFile) import Copilot.Theorem.Misc.Utils (openTempFile) import System.Process import System.Directory import Data.Default import qualified Copilot.Theorem.TransSys as TS -- | Options for Kind2 data Options = Options { bmcMax :: Int -- ^ Upper bound on the number of unrolling that base and -- step will perform. A value of 0 means /unlimited/. } -- | Default options with unlimited unrolling for base and step. instance Default Options where def = Options { bmcMax = 0 } data ProverST = ProverST { options :: Options , transSys :: TS.TransSys } -- | A prover backend based on Kind2. -- -- The executable @kind2@ must exist and its location be in the @PATH@. kind2Prover :: Options -> Prover kind2Prover opts = Prover { proverName = "Kind2" , startProver = return . ProverST opts . TS.translate , askProver = askKind2 , closeProver = const $ return () } kind2Prog = "kind2" kind2BaseOptions = ["--input-format", "native", "-xml"] askKind2 :: ProverST -> [PropId] -> [PropId] -> IO Output askKind2 (ProverST opts spec) assumptions toCheck = do let kind2Input = prettyPrint . toKind2 Inlined assumptions toCheck $ spec (tempName, tempHandle) <- openTempFile "." "out" "kind" hPutStr tempHandle kind2Input hClose tempHandle let kind2Options = kind2BaseOptions ++ ["--bmc_max", show $ bmcMax opts, tempName] (_, output, _) <- readProcessWithExitCode kind2Prog kind2Options "" putStrLn kind2Input removeFile tempName return $ parseOutput (head toCheck) output copilot-theorem-4.3/src/Copilot/Theorem/Misc/0000755000000000000000000000000014762717277017402 5ustar0000000000000000copilot-theorem-4.3/src/Copilot/Theorem/Misc/Error.hs0000644000000000000000000000166714762717277021041 0ustar0000000000000000{-# LANGUAGE Safe #-} -- | Custom functions to report error messages to users. module Copilot.Theorem.Misc.Error ( badUse , impossible , impossible_ , fatal ) where -- | Tag used with error messages to help users locate the component that -- failed or reports the error. errorHeader :: String errorHeader = "[Copilot-kind ERROR] " -- | Report an error due to an error detected by Copilot (e.g., user error). badUse :: String -- ^ Description of the error. -> a badUse s = error $ errorHeader ++ s -- | Report an error due to a bug in Copilot. impossible :: String -- ^ Error information to attach to the message. -> a impossible s = error $ errorHeader ++ "Unexpected internal error : " ++ s -- | Report an error due to a bug in Copilot. impossible_ :: a impossible_ = error $ errorHeader ++ "Unexpected internal error" -- | Report an unrecoverable error (e.g., incorrect format). fatal :: String -> a fatal = error copilot-theorem-4.3/src/Copilot/Theorem/Misc/Utils.hs0000644000000000000000000000367414762717277021050 0ustar0000000000000000{-# LANGUAGE Trustworthy #-} -- | Utility / auxiliary functions. module Copilot.Theorem.Misc.Utils ( isSublistOf, nub', nubBy', nubEq , openTempFile ) where import Data.Function (on) import Data.List (groupBy, sortBy, group, sort) import Control.Applicative ((<$>)) import Control.Monad import qualified Data.Set as Set import System.IO hiding (openTempFile) import System.Random import System.Directory -- | True if the given list is a subset of the second list, when both are -- considered as sets. isSublistOf :: Ord a => [a] -> [a] -> Bool isSublistOf = Set.isSubsetOf `on` Set.fromList -- | True if both lists contain the same elements, when both are considered as -- sets. nubEq :: Ord a => [a] -> [a] -> Bool nubEq = (==) `on` Set.fromList -- | Remove duplicates from a list. -- -- This is an efficient version of 'Data.List.nub' that works for lists with a -- stronger constraint on the type (i.e., 'Ord', as opposed of -- 'Data.List.nub''s 'Eq' constraint). nub' :: Ord a => [a] -> [a] nub' = map head . group . sort -- | Variant of 'nub'' parameterized by the comparison function. nubBy' :: (a -> a -> Ordering) -> [a] -> [a] nubBy' f = map head . groupBy (\x y -> f x y == EQ) . sortBy f -- | Create a temporary file and open it for writing. openTempFile :: String -- ^ Directory where the file should be created. -> String -- ^ Base name for the file (prefix). -> String -- ^ File extension. -> IO (String, Handle) openTempFile loc baseName extension = do path <- freshPath handle <- openFile path WriteMode return (path, handle) where freshPath :: IO FilePath freshPath = do path <- pathFromSuff <$> randSuff exists <- doesFileExist path if exists then freshPath else return path randSuff :: IO String randSuff = replicateM 4 $ randomRIO ('0', '9') pathFromSuff :: String -> FilePath pathFromSuff suf = loc ++ "/" ++ baseName ++ suf ++ "." ++ extension copilot-theorem-4.3/src/Copilot/Theorem/Misc/SExpr.hs0000644000000000000000000000646014762717277021005 0ustar0000000000000000{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE Safe #-} -- | A representation for structured expression trees, with support for pretty -- printing and for parsing. module Copilot.Theorem.Misc.SExpr where import Text.ParserCombinators.Parsec import Text.PrettyPrint.HughesPJ as PP hiding (char, Str) import Control.Monad -- | A structured expression is either an atom, or a sequence of expressions, -- where the first in the sequence denotes the tag or label of the tree. data SExpr a = Atom a | List [SExpr a] -- | Empty string expression. blank = Atom "" -- | Atomic expression constructor. atom = Atom -- s -- | Empty expression (empty list). unit = List [] -- () -- | Single expression. singleton a = List [Atom a] -- (s) -- | Sequence of expressions. list = List -- (ss) -- | Sequence of expressions with a root or main note, and a series of -- additional expressions or arguments. node a l = List (Atom a : l) -- (s ss) -- A straightforward string representation for 'SExpr's of Strings that -- parenthesizes lists of expressions. instance Show (SExpr String) where show = PP.render . show' where show' (Atom s) = text s show' (List ts) = parens . hsep . map show' $ ts -- More advanced printing with some basic indentation -- | Indent by a given number. indent = nest 1 -- | Pretty print a structured expression as a String. toString :: (SExpr a -> Bool) -- ^ True if an expression should be indented. -> (a -> String) -- ^ Pretty print the value inside as 'SExpr'. -> SExpr a -- ^ Root of 'SExpr' tree. -> String toString shouldIndent printAtom expr = PP.render (toDoc shouldIndent printAtom expr) -- | Pretty print a structured expression as a 'Doc', or set of layouts. toDoc :: (SExpr a -> Bool) -- ^ True if an expression should be indented. -> (a -> String) -- ^ Pretty print the value inside as 'SExpr'. -> SExpr a -- ^ Root of 'SExpr' tree. -> Doc toDoc shouldIndent printAtom expr = case expr of Atom a -> text (printAtom a) List l -> parens (foldl renderItem empty l) where renderItem doc s | shouldIndent s = doc $$ indent (toDoc shouldIndent printAtom s) | otherwise = doc <+> toDoc shouldIndent printAtom s -- | Parser for strings of characters separated by spaces into a structured -- tree. -- -- Parentheses are interpreted as grouping elements, that is, defining a -- 'List', which may be empty. parser :: GenParser Char st (SExpr String) parser = choice [try unitP, nodeP, leafP] where symbol = oneOf "!#$%&|*+-/:<=>?@^_~." lonelyStr = many1 (alphaNum <|> symbol) unitP = string "()" >> return unit leafP = atom <$> lonelyStr nodeP = do void $ char '(' spaces st <- sepBy parser spaces spaces void $ char ')' return $ List st -- | Parser for strings of characters separated by spaces into a structured -- tree. -- -- Parentheses are interpreted as grouping elements, that is, defining a -- 'List', which may be empty. parseSExpr :: String -> Maybe (SExpr String) parseSExpr str = case parse parser "" str of Left s -> error (show s) -- Nothing Right t -> Just t copilot-theorem-4.3/src/Copilot/Theorem/Prover/0000755000000000000000000000000014762717277017764 5ustar0000000000000000copilot-theorem-4.3/src/Copilot/Theorem/Prover/Backend.hs0000644000000000000000000000264114762717277021652 0ustar0000000000000000{-# LANGUAGE RankNTypes #-} {-# LANGUAGE Safe #-} -- | Backend to SMT solvers and theorem provers. -- -- This module provides three definitions: -- -- - A class ('SmtFormat') abstracting over the language used to communicate the -- desired commands to an SMT solver or theorem prover. -- -- - A class ('Backend') abstracting over the backend, which includes the name of -- the executable, any options and flags necessary, and functions to parse the -- results and close the communication. -- -- - A type ('SatResult') representing a satisfiability result communicated by -- the SMT solver or theorem prover. module Copilot.Theorem.Prover.Backend (SmtFormat(..), Backend(..), SatResult(..)) where import Copilot.Theorem.IL import System.IO -- | Format of SMT-Lib commands. class Show a => SmtFormat a where push :: a pop :: a checkSat :: a setLogic :: String -> a declFun :: String -> Type -> [Type] -> a assert :: Expr -> a -- | Backend to an SMT solver or theorem prover. data Backend a = Backend { name :: String , cmd :: String , cmdOpts :: [String] , inputTerminator :: Handle -> IO () , incremental :: Bool , logic :: String , interpret :: String -> Maybe SatResult } -- | Satisfiability result communicated by the SMT solver or theorem prover. data SatResult = Sat | Unsat | Unknown copilot-theorem-4.3/src/Copilot/Theorem/Prover/SMT.hs0000644000000000000000000003230014762717277020761 0ustar0000000000000000{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE Trustworthy #-} -- | Connections to various SMT solvers and theorem provers. module Copilot.Theorem.Prover.SMT ( -- * Backends Backend , SmtFormat , SmtLib , Tptp , yices, dReal, altErgo, metit, z3, cvc4, mathsat -- * Tactics , Options (..) , induction, kInduction, onlySat, onlyValidity -- * Auxiliary , module Data.Default ) where import Copilot.Theorem.IL.Translate import Copilot.Theorem.IL import Copilot.Theorem.Prove (Output (..), check, Proof, Universal, Existential) import qualified Copilot.Theorem.Prove as P import Copilot.Theorem.Prover.Backend import qualified Copilot.Theorem.Prover.SMTIO as SMT import Copilot.Theorem.Prover.SMTLib (SmtLib) import Copilot.Theorem.Prover.TPTP (Tptp) import qualified Copilot.Theorem.Prover.SMTLib as SMTLib import qualified Copilot.Theorem.Prover.TPTP as TPTP import Control.Monad (msum, unless, mzero) import Control.Monad.State (StateT, runStateT, lift, get, modify) import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Maybe (MaybeT (..)) import Data.Word import Data.Maybe (fromJust, fromMaybe) import Data.Function (on) import Data.Default (Default(..)) import Data.Map (Map) import qualified Data.Map as Map import Copilot.Theorem.Misc.Utils import System.IO (hClose) -- * Tactics -- | Options to configure the provers. data Options = Options { startK :: Word32 -- ^ Initial @k@ for the k-induction algorithm. , maxK :: Word32 -- ^ The maximum number of steps of the k-induction algorithm the prover runs -- before giving up. , debug :: Bool -- ^ If @debug@ is set to @True@, the SMTLib/TPTP queries produced by the -- prover are displayed in the standard output. } -- | Default 'Options' with a @0@ @k@ and a max of @10@ steps, and that produce -- no debugging info. instance Default Options where def = Options { startK = 0 , maxK = 10 , debug = False } -- | Tactic to find only a proof of satisfiability. onlySat :: SmtFormat a => Options -> Backend a -> Proof Existential onlySat opts backend = check P.Prover { P.proverName = "OnlySat" , P.startProver = return . ProofState opts backend Map.empty . translateWithBounds , P.askProver = onlySat' , P.closeProver = const $ return () } -- | Tactic to find only a proof of validity. onlyValidity :: SmtFormat a => Options -> Backend a -> Proof Universal onlyValidity opts backend = check P.Prover { P.proverName = "OnlyValidity" , P.startProver = return . ProofState opts backend Map.empty . translateWithBounds , P.askProver = onlyValidity' , P.closeProver = const $ return () } -- | Tactic to find a proof by standard 1-induction. -- -- The values for @startK@ and @maxK@ in the options are ignored. induction :: SmtFormat a => Options -> Backend a -> Proof Universal induction opts backend = check P.Prover { P.proverName = "Induction" , P.startProver = return . ProofState opts backend Map.empty . translateWithBounds , P.askProver = kInduction' 0 0 , P.closeProver = const $ return () } -- | Tactic to find a proof by k-induction. kInduction :: SmtFormat a => Options -> Backend a -> Proof Universal kInduction opts backend = check P.Prover { P.proverName = "K-Induction" , P.startProver = return . ProofState opts backend Map.empty . translateWithBounds , P.askProver = kInduction' (startK opts) (maxK opts) , P.closeProver = const $ return () } -- * Backends -- | Backend to the Yices 2 SMT solver. -- -- It enables non-linear arithmetic (@QF_NRA@), which means MCSat will be used. -- -- The command @yices-smt2@ must be in the user's @PATH@. yices :: Backend SmtLib yices = Backend { name = "Yices" , cmd = "yices-smt2" , cmdOpts = ["--incremental"] , inputTerminator = const $ return () , incremental = True , logic = "QF_NRA" , interpret = SMTLib.interpret } -- | Backend to the cvc4 SMT solver. -- -- It enables support for uninterpreted functions and mixed nonlinear -- arithmetic (@QF_NIRA@). -- -- The command @cvc4@ must be in the user's @PATH@. cvc4 :: Backend SmtLib cvc4 = Backend { name = "CVC4" , cmd = "cvc4" , cmdOpts = ["--incremental", "--lang=smt2", "--tlimit-per=5000"] , inputTerminator = const $ return () , incremental = True , logic = "QF_UFNIRA" , interpret = SMTLib.interpret } -- | Backend to the Alt-Ergo SMT solver. -- -- It enables support for uninterpreted functions and mixed nonlinear -- arithmetic (@QF_NIRA@). -- -- The command @alt-ergo.opt@ must be in the user's @PATH@. altErgo :: Backend SmtLib altErgo = Backend { name = "Alt-Ergo" , cmd = "alt-ergo.opt" , cmdOpts = [] , inputTerminator = hClose , incremental = False , logic = "QF_UFNIRA" , interpret = SMTLib.interpret } -- | Backend to the Z3 theorem prover. -- -- The command @z3@ must be in the user's @PATH@. z3 :: Backend SmtLib z3 = Backend { name = "Z3" , cmd = "z3" , cmdOpts = ["-smt2", "-in"] , inputTerminator = const $ return () , incremental = True , logic = "" , interpret = SMTLib.interpret } -- | Backend to the dReal SMT solver. -- -- It enables non-linear arithmetic (@QF_NRA@). -- -- The libraries for dReal must be installed and @perl@ must be in the user's -- @PATH@. dReal :: Backend SmtLib dReal = Backend { name = "dReal" , cmd = "perl" , cmdOpts = ["-e", "alarm 10; exec dReal"] , inputTerminator = hClose , incremental = False , logic = "QF_NRA" , interpret = SMTLib.interpret } -- | Backend to the Mathsat SMT solver. -- -- It enables non-linear arithmetic (@QF_NRA@). -- -- The command @mathsat@ must be in the user's @PATH@. mathsat :: Backend SmtLib mathsat = Backend { name = "MathSAT" , cmd = "mathsat" , cmdOpts = [] , inputTerminator = const $ return () , incremental = True , logic = "QF_NRA" , interpret = SMTLib.interpret } -- | Backend to the MetiTaski theorem prover. -- -- The command @metit@ must be in the user's @PATH@. -- -- The argument string is the path to the @tptp@ subdirectory of the metitarski -- install location. metit :: String -> Backend Tptp metit installDir = Backend { name = "MetiTarski" , cmd = "metit" , cmdOpts = [ "--time", "5" , "--autoInclude" , "--tptp", installDir , "/dev/stdin" ] , inputTerminator = hClose , incremental = False , logic = "" , interpret = TPTP.interpret } -- | Checks the Copilot specification with k-induction type ProofScript b = MaybeT (StateT (ProofState b) IO) runPS :: ProofScript b a -> ProofState b -> IO (Maybe a, ProofState b) runPS ps = runStateT (runMaybeT ps) data ProofState b = ProofState { options :: Options , backend :: Backend b , solvers :: Map SolverId (SMT.Solver b) , spec :: IL } data SolverId = Base | Step deriving (Show, Ord, Eq) getModels :: [PropId] -> [PropId] -> ProofScript b ([Expr], [Expr], [Expr], Bool) getModels assumptionIds toCheckIds = do IL {modelInit, modelRec, properties, inductive} <- spec <$> get let (as, as') = selectProps assumptionIds properties (as'', toCheck) = selectProps toCheckIds properties modelRec' = modelRec ++ as ++ as' ++ as'' return (modelInit, modelRec', toCheck, inductive) getSolver :: SmtFormat b => SolverId -> ProofScript b (SMT.Solver b) getSolver sid = do solvers <- solvers <$> get case Map.lookup sid solvers of Nothing -> startNewSolver sid Just solver -> return solver setSolver :: SolverId -> SMT.Solver b -> ProofScript b () setSolver sid solver = (lift . modify) $ \s -> s { solvers = Map.insert sid solver (solvers s) } deleteSolver :: SolverId -> ProofScript b () deleteSolver sid = (lift . modify) $ \s -> s { solvers = Map.delete sid (solvers s) } startNewSolver :: SmtFormat b => SolverId -> ProofScript b (SMT.Solver b) startNewSolver sid = do dbg <- (options <$> get >>= return . debug) backend <- backend <$> get s <- liftIO $ SMT.startNewSolver (show sid) dbg backend setSolver sid s return s declVars :: SmtFormat b => SolverId -> [VarDescr] -> ProofScript b () declVars sid vs = do s <- getSolver sid s' <- liftIO $ SMT.declVars s vs setSolver sid s' assume :: SmtFormat b => SolverId -> [Expr] -> ProofScript b () assume sid cs = do s <- getSolver sid s' <- liftIO $ SMT.assume s cs setSolver sid s' entailed :: SmtFormat b => SolverId -> [Expr] -> ProofScript b SatResult entailed sid cs = do backend <- backend <$> get s <- getSolver sid result <- liftIO $ SMT.entailed s cs unless (incremental backend) $ stop sid return result stop :: SmtFormat b => SolverId -> ProofScript b () stop sid = do s <- getSolver sid deleteSolver sid liftIO $ SMT.stop s proofKind :: Integer -> String proofKind 0 = "induction" proofKind k = "k-induction (k = " ++ show k ++ ")" stopSolvers :: SmtFormat b => ProofScript b () stopSolvers = do solvers <- solvers <$> get mapM_ stop (fst <$> Map.toList solvers) entailment :: SmtFormat b => SolverId -> [Expr] -> [Expr] -> ProofScript b SatResult entailment sid assumptions props = do declVars sid $ nub' $ getVars assumptions ++ getVars props assume sid assumptions entailed sid props getVars :: [Expr] -> [VarDescr] getVars = nubBy' (compare `on` varName) . concatMap getVars' where getVars' :: Expr -> [VarDescr] getVars' = \case ConstB _ -> [] ConstI _ _ -> [] ConstR _ -> [] Ite _ e1 e2 e3 -> getVars' e1 ++ getVars' e2 ++ getVars' e3 Op1 _ _ e -> getVars' e Op2 _ _ e1 e2 -> getVars' e1 ++ getVars' e2 SVal t seq (Fixed i) -> [VarDescr (seq ++ "_" ++ show i) t []] SVal t seq (Var i) -> [VarDescr (seq ++ "_n" ++ show i) t []] FunApp t name args -> [VarDescr name t (map typeOf args)] ++ concatMap getVars' args unknown :: ProofScript b a unknown = mzero unknown' :: String -> ProofScript b Output unknown' msg = return $ Output P.Unknown [msg] invalid :: String -> ProofScript b Output invalid msg = return $ Output P.Invalid [msg] sat :: String -> ProofScript b Output sat msg = return $ Output P.Sat [msg] valid :: String -> ProofScript b Output valid msg = return $ Output P.Valid [msg] kInduction' :: SmtFormat b => Word32 -> Word32 -> ProofState b -> [PropId] -> [PropId] -> IO Output kInduction' startK maxK s as ps = (fromMaybe (Output P.Unknown ["proof by k-induction failed"]) . fst) <$> runPS (msum (map induction [(toInteger startK) .. (toInteger maxK)]) <* stopSolvers) s where induction k = do (modelInit, modelRec, toCheck, inductive) <- getModels as ps let base = [evalAt (Fixed i) m | m <- modelRec, i <- [0 .. k]] baseInv = [evalAt (Fixed k) m | m <- toCheck] let step = [evalAt (_n_plus i) m | m <- modelRec, i <- [0 .. k + 1]] ++ [evalAt (_n_plus i) m | m <- toCheck, i <- [0 .. k]] stepInv = [evalAt (_n_plus $ k + 1) m | m <- toCheck] entailment Base (modelInit ++ base) baseInv >>= \case Sat -> invalid $ "base case failed for " ++ proofKind k Unknown -> unknown Unsat -> if not inductive then valid ("proved without induction") else entailment Step step stepInv >>= \case Sat -> unknown Unknown -> unknown Unsat -> valid $ "proved with " ++ proofKind k onlySat' :: SmtFormat b => ProofState b -> [PropId] -> [PropId] -> IO Output onlySat' s as ps = (fromJust . fst) <$> runPS (script <* stopSolvers) s where script = do (modelInit, modelRec, toCheck, inductive) <- getModels as ps let base = map (evalAt (Fixed 0)) modelRec baseInv = map (evalAt (Fixed 0)) toCheck if inductive then unknown' "proposition requires induction to prove." else entailment Base (modelInit ++ base) (map (Op1 Bool Not) baseInv) >>= \case Unsat -> invalid "prop not satisfiable" Unknown -> unknown' "failed to find a satisfying model" Sat -> sat "prop is satisfiable" onlyValidity' :: SmtFormat b => ProofState b -> [PropId] -> [PropId] -> IO Output onlyValidity' s as ps = (fromJust . fst) <$> runPS (script <* stopSolvers) s where script = do (modelInit, modelRec, toCheck, inductive) <- getModels as ps let base = map (evalAt (Fixed 0)) modelRec baseInv = map (evalAt (Fixed 0)) toCheck if inductive then unknown' "proposition requires induction to prove." else entailment Base (modelInit ++ base) baseInv >>= \case Unsat -> valid "proof by SMT solver" Unknown -> unknown Sat -> invalid "SMT solver found a counter-example." selectProps :: [PropId] -> Map PropId ([Expr], Expr) -> ([Expr], [Expr]) selectProps propIds properties = (squash . unzip) [(as, p) | (id, (as, p)) <- Map.toList properties, id `elem` propIds] where squash (a, b) = (concat a, b) copilot-theorem-4.3/src/Copilot/Theorem/Prover/SMTLib.hs0000644000000000000000000000477414762717277021426 0ustar0000000000000000{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE Safe #-} -- | A backend to the SMT-Lib format, enabling to produce commands for SMT-Lib -- implementing solvers, and parse results. module Copilot.Theorem.Prover.SMTLib (SmtLib, interpret) where import Copilot.Theorem.Prover.Backend (SmtFormat (..), SatResult (..)) import Copilot.Theorem.IL import Copilot.Theorem.Misc.SExpr import Text.Printf -- | Type used to represent SMT-lib commands. -- -- Use the interface in 'SmtFormat' to create such commands. newtype SmtLib = SmtLib (SExpr String) instance Show SmtLib where show (SmtLib s) = show s smtTy :: Type -> String smtTy Bool = "Bool" smtTy Real = "Real" smtTy _ = "Int" -- | Interface for SMT-Lib conforming backends. instance SmtFormat SmtLib where push = SmtLib $ node "push" [atom "1"] pop = SmtLib $ node "pop" [atom "1"] checkSat = SmtLib $ singleton "check-sat" setLogic "" = SmtLib $ blank setLogic l = SmtLib $ node "set-logic" [atom l] declFun name retTy args = SmtLib $ node "declare-fun" [atom name, (list $ map (atom . smtTy) args), atom (smtTy retTy)] assert c = SmtLib $ node "assert" [expr c] -- | Parse a satisfiability result. interpret :: String -> Maybe SatResult interpret "sat" = Just Sat interpret "unsat" = Just Unsat interpret _ = Just Unknown expr :: Expr -> SExpr String expr (ConstB v) = atom $ if v then "true" else "false" expr (ConstI _ v) = atom $ show v expr (ConstR v) = atom $ printf "%f" v expr (Ite _ cond e1 e2) = node "ite" [expr cond, expr e1, expr e2] expr (FunApp _ funName args) = node funName $ map expr args expr (Op1 _ op e) = node smtOp [expr e] where smtOp = case op of Not -> "not" Neg -> "-" Abs -> "abs" Exp -> "exp" Sqrt -> "sqrt" Log -> "log" Sin -> "sin" Tan -> "tan" Cos -> "cos" Asin -> "asin" Atan -> "atan" Acos -> "acos" Sinh -> "sinh" Tanh -> "tanh" Cosh -> "cosh" Asinh -> "asinh" Atanh -> "atanh" Acosh -> "acosh" expr (Op2 _ op e1 e2) = node smtOp [expr e1, expr e2] where smtOp = case op of Eq -> "=" Le -> "<=" Lt -> "<" Ge -> ">=" Gt -> ">" And -> "and" Or -> "or" Add -> "+" Sub -> "-" Mul -> "*" Mod -> "mod" Fdiv -> "/" Pow -> "^" expr (SVal _ f ix) = atom $ case ix of Fixed i -> f ++ "_" ++ show i Var off -> f ++ "_n" ++ show off copilot-theorem-4.3/src/Copilot/Theorem/Prover/SMTIO.hs0000644000000000000000000000733314762717277021221 0ustar0000000000000000{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE Safe #-} {-# LANGUAGE ViewPatterns #-} -- | Communication with SMT solvers or theorem provers. -- -- A solver is a running process defined by a 'Backend'. module Copilot.Theorem.Prover.SMTIO ( Solver , startNewSolver, stop , assume, entailed, declVars ) where import Copilot.Theorem.IL import Copilot.Theorem.Prover.Backend import System.IO import System.Process import Control.Monad import Control.Monad.Trans import Control.Monad.Trans.Maybe import Data.Maybe import Data.Set ((\\), fromList, Set, union, empty, elems) -- | A connection with a running SMT solver or theorem prover. data Solver a = Solver { solverName :: String , inh :: Handle , outh :: Handle , process :: ProcessHandle , debugMode :: Bool , vars :: Set VarDescr , model :: Set Expr , backend :: Backend a } -- | Output a debugging message if debugging is enabled for the solver. debug :: Bool -> Solver a -> String -> IO () debug printName s str = when (debugMode s) $ putStrLn $ (if printName then "<" ++ solverName s ++ "> " else "") ++ str send :: Show a => Solver a -> a -> IO () send _ (show -> "") = return () send s (show -> a) = do hPutStr (inh s) $ a ++ "\n" debug True s a hFlush $ inh s receive :: Solver a -> IO SatResult receive s = fromJust <$> runMaybeT (msum $ repeat line) where line :: MaybeT IO SatResult line = do eof <- liftIO $ hIsEOF $ outh s if eof then liftIO (debug True s "[received: EOF]") >> return Unknown else do ln <- liftIO $ hGetLine $ outh s liftIO $ debug True s $ "[received: " ++ ln ++ "]" MaybeT $ return $ (interpret $ backend s) ln -- | Create a new solver implemented by the backend specified. -- -- The error handle from the backend handle is immediately closed/discarded, -- and the logic initialized as specifiied by the backend options. startNewSolver :: SmtFormat a => String -> Bool -> Backend a -> IO (Solver a) startNewSolver name dbgMode b = do (i, o, e, p) <- runInteractiveProcess (cmd b) (cmdOpts b) Nothing Nothing hClose e let s = Solver name i o p dbgMode empty empty b send s $ setLogic $ logic b return s -- | Stop a solver, closing all communication handles and terminating the -- process. stop :: Solver a -> IO () stop s = do hClose $ inh s hClose $ outh s terminateProcess $ process s -- | Register the given expressions as assumptions or axioms with the solver. assume :: SmtFormat a => Solver a -> [Expr] -> IO (Solver a) assume s@(Solver { model }) cs = do let newAxioms = elems $ fromList cs \\ model assume' s newAxioms return s { model = model `union` fromList newAxioms } assume' :: SmtFormat a => Solver a -> [Expr] -> IO () assume' s cs = forM_ cs (send s . assert . bsimpl) -- | Check if a series of expressions are entailed by the axioms or assumptions -- already registered with the solver. entailed :: SmtFormat a => Solver a -> [Expr] -> IO SatResult entailed s cs = do when (incremental $ backend s) $ send s push case cs of [] -> putStrLn "Warning: no proposition to prove." >> assume' s [ConstB True] _ -> assume' s [foldl1 (Op2 Bool Or) (map (Op1 Bool Not) cs)] send s checkSat (inputTerminator $ backend s) (inh s) when (incremental $ backend s) $ send s pop receive s -- | Register the given variables with the solver. declVars :: SmtFormat a => Solver a -> [VarDescr] -> IO (Solver a) declVars s@(Solver { vars }) decls = do let newVars = elems $ fromList decls \\ vars forM_ newVars $ \(VarDescr {varName, varType, args}) -> send s $ declFun varName varType args return s { vars = vars `union` fromList newVars } copilot-theorem-4.3/src/Copilot/Theorem/Prover/TPTP.hs0000644000000000000000000000536514762717277021120 0ustar0000000000000000{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE Safe #-} -- | A backend to , enabling to produce assertions -- and to parse the results from TPTP. module Copilot.Theorem.Prover.TPTP (Tptp, interpret) where import Copilot.Theorem.Prover.Backend (SmtFormat (..), SatResult (..)) import Copilot.Theorem.IL import Data.List -- | Type used to represent TPTP expressions. -- -- Although this type implements the 'SmtFormat' interface, only 'assert' is -- actually used. data Tptp = Ax TptpExpr | Null data TptpExpr = Bin TptpExpr String TptpExpr | Un String TptpExpr | Atom String | Fun String [TptpExpr] instance Show Tptp where show (Ax e) = "fof(formula, axiom, " ++ show e ++ ")." show Null = "" instance Show TptpExpr where show (Bin e1 op e2) = "(" ++ show e1 ++ " " ++ op ++ " " ++ show e2 ++ ")" show (Un op e) = "(" ++ op ++ " " ++ show e ++ ")" show (Atom atom) = atom show (Fun name args) = name ++ "(" ++ intercalate ", " (map show args) ++ ")" instance SmtFormat Tptp where push = Null pop = Null checkSat = Null setLogic = const Null declFun = const $ const $ const Null assert c = Ax $ expr c -- | Parse a satisfiability result. interpret :: String -> Maybe SatResult interpret str | "SZS status Unsatisfiable" `isPrefixOf` str = Just Unsat | "SZS status" `isPrefixOf` str = Just Unknown | otherwise = Nothing expr :: Expr -> TptpExpr expr = \case ConstB v -> Atom $ if v then "$true" else "$false" ConstR v -> Atom $ show v ConstI _ v -> Atom $ show v Ite _ c e1 e2 -> Bin (Bin (expr c) "=>" (expr e1)) "&" (Bin (Un "~" (expr c)) "=>" (expr e2)) FunApp _ f args -> Fun f $ map expr args Op1 _ Not e -> Un (showOp1 Not) $ expr e Op1 _ Neg e -> Un (showOp1 Neg) $ expr e Op1 _ op e -> Fun (showOp1 op) [expr e] Op2 _ op e1 e2 -> Bin (expr e1) (showOp2 op) (expr e2) SVal _ f ix -> case ix of Fixed i -> Atom $ f ++ "_" ++ show i Var off -> Atom $ f ++ "_n" ++ show off showOp1 :: Op1 -> String showOp1 = \case Not -> "~" Neg -> "-" Abs -> "abs" Exp -> "exp" Sqrt -> "sqrt" Log -> "log" Sin -> "sin" Tan -> "tan" Cos -> "cos" Asin -> "arcsin" Atan -> "arctan" Acos -> "arccos" Sinh -> "sinh" Tanh -> "tanh" Cosh -> "cosh" Asinh -> "arcsinh" Atanh -> "arctanh" Acosh -> "arccosh" showOp2 :: Op2 -> String showOp2 = \case Eq -> "=" Le -> "<=" Lt -> "<" Ge -> ">=" Gt -> ">" And -> "&" Or -> "|" Add -> "+" Sub -> "-" Mul -> "*" Mod -> "mod" Fdiv -> "/" Pow -> "^" copilot-theorem-4.3/src/Copilot/Theorem/IL/0000755000000000000000000000000014762717277017013 5ustar0000000000000000copilot-theorem-4.3/src/Copilot/Theorem/IL/Transform.hs0000644000000000000000000000344014762717277021323 0ustar0000000000000000{-# LANGUAGE LambdaCase #-} {-# LANGUAGE Safe #-} -- | Simplify IL expressions by partly evaluating operations on booleans. module Copilot.Theorem.IL.Transform ( bsimpl ) where import Copilot.Theorem.IL.Spec -- | Simplify IL expressions by partly evaluating operations on booleans, -- eliminating some boolean literals. -- -- For example, an if-then-else in which the condition is literally the -- constant True or the constant False can be reduced to an operation without -- choice in which the appropriate branch of the if-then-else is used instead. bsimpl :: Expr -> Expr bsimpl = until (\x -> bsimpl' x == x) bsimpl' where bsimpl' = \case Ite _ (ConstB True) e _ -> bsimpl' e Ite _ (ConstB False) _ e -> bsimpl' e Ite t c e1 e2 -> Ite t (bsimpl' c) (bsimpl' e1) (bsimpl' e2) Op1 _ Not (Op1 _ Not e) -> bsimpl' e Op1 _ Not (ConstB True) -> ConstB False Op1 _ Not (ConstB False) -> ConstB True Op1 t o e -> Op1 t o (bsimpl' e) Op2 _ Or e (ConstB False) -> bsimpl' e Op2 _ Or (ConstB False) e -> bsimpl' e Op2 _ Or _ (ConstB True) -> ConstB True Op2 _ Or (ConstB True) _ -> ConstB True Op2 _ And _ (ConstB False) -> ConstB False Op2 _ And (ConstB False) _ -> ConstB False Op2 _ And e (ConstB True) -> bsimpl' e Op2 _ And (ConstB True) e -> bsimpl' e Op2 _ Eq e (ConstB False) -> bsimpl' (Op1 Bool Not e) Op2 _ Eq (ConstB False) e -> bsimpl' (Op1 Bool Not e) Op2 _ Eq e (ConstB True) -> bsimpl' e Op2 _ Eq (ConstB True) e -> bsimpl' e Op2 t o e1 e2 -> Op2 t o (bsimpl' e1) (bsimpl' e2) FunApp t f args -> FunApp t f (map bsimpl' args) e -> e copilot-theorem-4.3/src/Copilot/Theorem/IL/PrettyPrint.hs0000644000000000000000000000444714762717277021664 0ustar0000000000000000{-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE Safe #-} -- | This module implements a pretty printer for the IL format, an intermediate -- representation used in copilot-theorem to facilitate model checking. module Copilot.Theorem.IL.PrettyPrint (prettyPrint, printConstraint) where import Copilot.Theorem.IL.Spec import Text.PrettyPrint.HughesPJ import qualified Data.Map as Map import Prelude hiding ((<>)) -- | Pretty print an IL specification. prettyPrint :: IL -> String prettyPrint = render . ppSpec -- | Pretty print an IL constraint expression. printConstraint :: Expr -> String printConstraint = render . ppExpr indent = nest 4 emptyLine = text "" ppSpec :: IL -> Doc ppSpec (IL { modelInit, modelRec, properties }) = text "MODEL INIT" $$ indent (foldr (($$) . ppExpr) empty modelInit) $$ emptyLine $$ text "MODEL REC" $$ indent (foldr (($$) . ppExpr) empty modelRec) $$ emptyLine $$ text "PROPERTIES" $$ indent (Map.foldrWithKey (\k -> ($$) . ppProp k) empty properties ) ppProp :: PropId -> ([Expr], Expr) -> Doc ppProp id (as, c) = (foldr (($$) . ppExpr) empty as) $$ quotes (text id) <+> colon <+> ppExpr c ppSeqDescr :: SeqDescr -> Doc ppSeqDescr (SeqDescr id ty) = text id <+> colon <+> ppType ty ppVarDescr :: VarDescr -> Doc ppVarDescr (VarDescr id ret args) = text id <+> colon <+> (hsep . punctuate (space <> text "->" <> space) $ map ppType args) <+> text "->" <+> ppType ret ppType :: Type -> Doc ppType = text . show ppExpr :: Expr -> Doc ppExpr (ConstB v) = text . show $ v ppExpr (ConstR v) = text . show $ v ppExpr (ConstI _ v) = text . show $ v ppExpr (Ite _ c e1 e2) = text "if" <+> ppExpr c <+> text "then" <+> ppExpr e1 <+> text "else" <+> ppExpr e2 ppExpr (Op1 _ op e) = ppOp1 op <+> ppExpr e ppExpr (Op2 _ op e1 e2) = ppExpr e1 <+> ppOp2 op <+> ppExpr e2 ppExpr (SVal _ s i) = text s <> brackets (ppSeqIndex i) ppExpr (FunApp _ name args) = text name <> parens (hsep . punctuate (comma <> space) $ map ppExpr args) ppSeqIndex :: SeqIndex -> Doc ppSeqIndex (Var i) | i == 0 = text "n" | i < 0 = text "n" <+> text "-" <+> integer (-i) | otherwise = text "n" <+> text "+" <+> integer i ppSeqIndex (Fixed i) = integer i ppOp1 :: Op1 -> Doc ppOp1 = text . show ppOp2 :: Op2 -> Doc ppOp2 = text . show copilot-theorem-4.3/src/Copilot/Theorem/IL/Translate.hs0000644000000000000000000002207114762717277021306 0ustar0000000000000000{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE Safe #-} {-# LANGUAGE ScopedTypeVariables #-} -- | Translate Copilot specifications into IL specifications. module Copilot.Theorem.IL.Translate ( translate, translateWithBounds ) where import Copilot.Theorem.IL.Spec import qualified Copilot.Core as C import qualified Data.Map.Strict as Map import Control.Monad (forM, liftM2, when) import Control.Monad.State import Data.Char import Data.List (find) import Text.Printf import GHC.Float (float2Double) import Data.Typeable (Typeable) -- 'nc' stands for naming convention. ncSeq :: C.Id -> SeqId ncSeq = printf "s%d" -- We assume all local variables have distinct names whatever their scopes. ncLocal :: C.Name -> SeqId ncLocal s = "l" ++ dropWhile (not . isNumber) s ncExternVar :: C.Name -> SeqId ncExternVar n = "ext_" ++ n ncUnhandledOp :: String -> String ncUnhandledOp = id ncMux :: Integer -> SeqId ncMux n = "mux" ++ show n -- | Translate a Copilot specification to an IL specification. translate :: C.Spec -> IL translate = translate' False -- | Translate a Copilot specification to an IL specification, adding -- constraints for limiting the values of numeric expressions to known bounds -- based on their specific types (only for integers or natural numbers). translateWithBounds :: C.Spec -> IL translateWithBounds = translate' True translate' :: Bool -> C.Spec -> IL translate' b (C.Spec {C.specStreams, C.specProperties}) = runTrans b $ do let modelInit = concatMap streamInit specStreams mainConstraints <- mapM streamRec specStreams localConstraints <- popLocalConstraints properties <- Map.fromList <$> forM specProperties (\(C.Property {C.propertyName, C.propertyProp}) -> do -- Soundness note: it is OK to call `extractProp` here to drop the -- quantifier from the proposition `propertyProp`. This is because we -- IL translation always occurs within the context of a function that -- returns a `Proof`, and these `Proof` functions are always careful to -- use `Prover`s that respect the propositions's quantifier. e' <- expr (C.extractProp propertyProp) propConds <- popLocalConstraints return (propertyName, (propConds, e'))) return IL { modelInit , modelRec = mainConstraints ++ localConstraints , properties , inductive = not $ null specStreams } bound :: Expr -> C.Type a -> Trans () bound s t = case t of C.Int8 -> bound' C.Int8 C.Int16 -> bound' C.Int16 C.Int32 -> bound' C.Int32 C.Int64 -> bound' C.Int64 C.Word8 -> bound' C.Word8 C.Word16 -> bound' C.Word16 C.Word32 -> bound' C.Word32 C.Word64 -> bound' C.Word64 _ -> return () where bound' :: (Bounded a, Integral a) => C.Type a -> Trans () bound' t = do b <- addBounds <$> get when b $ localConstraint (Op2 Bool And (Op2 Bool Le (trConst t minBound) s) (Op2 Bool Ge (trConst t maxBound) s)) streamInit :: C.Stream -> [Expr] streamInit (C.Stream { C.streamId = id , C.streamBuffer = b :: [val] , C.streamExprType = t }) = zipWith initConstraint [0..] b where initConstraint :: Integer -> val -> Expr initConstraint p v = Op2 Bool Eq (SVal (trType t) (ncSeq id) (Fixed p)) $ trConst t v streamRec :: C.Stream -> Trans Expr streamRec (C.Stream { C.streamId = id , C.streamExpr = e , C.streamBuffer = b , C.streamExprType = t }) = do let s = SVal (trType t) (ncSeq id) (_n_plus $ length b) bound s t e' <- expr e return $ Op2 Bool Eq s e' expr :: Typeable a => C.Expr a -> Trans Expr expr (C.Const t v) = return $ trConst t v expr (C.Label _ _ e) = expr e expr (C.Drop t k id) = return $ SVal (trType t) (ncSeq id) (_n_plus k) expr (C.Local ta _ name ea eb) = do ea' <- expr ea localConstraint (Op2 Bool Eq (SVal (trType ta) (ncLocal name) _n_) ea') expr eb expr (C.Var t name) = return $ SVal (trType t) (ncLocal name) _n_ expr (C.ExternVar t name _) = bound s t >> return s where s = SVal (trType t) (ncExternVar name) _n_ expr (C.Op1 (C.Sign ta) e) = case ta of C.Int8 -> trSign ta e C.Int16 -> trSign ta e C.Int32 -> trSign ta e C.Int64 -> trSign ta e C.Float -> trSign ta e C.Double -> trSign ta e _ -> expr $ C.Const ta 1 where trSign :: (Typeable a, Ord a, Num a) => C.Type a -> C.Expr a -> Trans Expr trSign ta e = expr (C.Op3 (C.Mux ta) (C.Op2 (C.Lt ta) e (C.Const ta 0)) (C.Const ta (-1)) (C.Op3 (C.Mux ta) (C.Op2 (C.Gt ta) e (C.Const ta 0)) (C.Const ta 1) (C.Const ta 0))) expr (C.Op1 (C.Sqrt _) e) = do e' <- expr e return $ Op2 Real Pow e' (ConstR 0.5) expr (C.Op1 (C.Cast _ _) e) = expr e expr (C.Op1 op e) = do e' <- expr e return $ Op1 t' op' e' where (op', t') = trOp1 op expr (C.Op2 (C.Ne t) e1 e2) = do e1' <- expr e1 e2' <- expr e2 return $ Op1 Bool Not (Op2 t' Eq e1' e2') where t' = trType t expr (C.Op2 op e1 e2) = do e1' <- expr e1 e2' <- expr e2 return $ Op2 t' op' e1' e2' where (op', t') = trOp2 op expr (C.Op3 (C.Mux t) cond e1 e2) = do cond' <- expr cond e1' <- expr e1 e2' <- expr e2 newMux cond' (trType t) e1' e2' trConst :: C.Type a -> a -> Expr trConst t v = case t of C.Bool -> ConstB v C.Float -> negifyR (float2Double v) C.Double -> negifyR v t@C.Int8 -> negifyI v (trType t) t@C.Int16 -> negifyI v (trType t) t@C.Int32 -> negifyI v (trType t) t@C.Int64 -> negifyI v (trType t) t@C.Word8 -> negifyI v (trType t) t@C.Word16 -> negifyI v (trType t) t@C.Word32 -> negifyI v (trType t) t@C.Word64 -> negifyI v (trType t) where negifyR :: Double -> Expr negifyR v | v >= 0 = ConstR v | otherwise = Op1 Real Neg $ ConstR $ negate $ v negifyI :: Integral a => a -> Type -> Expr negifyI v t | v >= 0 = ConstI t $ toInteger v | otherwise = Op1 t Neg $ ConstI t $ negate $ toInteger v trOp1 :: C.Op1 a b -> (Op1, Type) trOp1 = \case C.Not -> (Not, Bool) C.Abs t -> (Abs, trType t) -- C.Sign t -> -- C.Recip t -> C.Exp t -> (Exp, trType t) -- C.Sqrt t -> C.Log t -> (Log, trType t) C.Sin t -> (Sin, trType t) C.Tan t -> (Tan, trType t) C.Cos t -> (Cos, trType t) C.Asin t -> (Asin, trType t) C.Atan t -> (Atan, trType t) C.Acos t -> (Acos, trType t) C.Sinh t -> (Sinh, trType t) C.Tanh t -> (Tanh, trType t) C.Cosh t -> (Cosh, trType t) C.Asinh t -> (Asinh, trType t) C.Atanh t -> (Atanh, trType t) C.Acosh t -> (Acosh, trType t) -- C.BwNot t -> -- C.Cast t -> _ -> error "Unsupported unary operator in input." trOp2 :: C.Op2 a b c -> (Op2, Type) trOp2 = \case C.And -> (And, Bool) C.Or -> (Or, Bool) C.Add t -> (Add, trType t) C.Sub t -> (Sub, trType t) C.Mul t -> (Mul, trType t) C.Mod t -> (Mod, trType t) -- C.Div t -> C.Fdiv t -> (Fdiv, trType t) C.Pow t -> (Pow, trType t) -- C.Logb t -> C.Eq _ -> (Eq, Bool) -- C.Ne t -> C.Le t -> (Le, trType t) C.Ge t -> (Ge, trType t) C.Lt t -> (Lt, trType t) C.Gt t -> (Gt, trType t) -- C.BwAnd t -> -- C.BwOr t -> -- C.BwXor t -> -- C.BwShiftL t _ -> -- C.BwShiftR t _ -> _ -> error "Unsupported binary operator in input." trType :: C.Type a -> Type trType = \case C.Bool -> Bool C.Int8 -> SBV8 C.Int16 -> SBV16 C.Int32 -> SBV32 C.Int64 -> SBV64 C.Word8 -> BV8 C.Word16 -> BV16 C.Word32 -> BV32 C.Word64 -> BV64 C.Float -> Real C.Double -> Real -- | Translation state. data TransST = TransST { localConstraints :: [Expr] , muxes :: [(Expr, (Expr, Type, Expr, Expr))] , nextFresh :: Integer , addBounds :: Bool } newMux :: Expr -> Type -> Expr -> Expr -> Trans Expr newMux c t e1 e2 = do ms <- muxes <$> get case find ((==mux) . snd) ms of Nothing -> do f <- fresh let v = SVal t (ncMux f) _n_ modify $ \st -> st { muxes = (v, mux) : ms } return v Just (v, _) -> return v where mux = (c, t, e1, e2) getMuxes :: Trans [Expr] getMuxes = muxes <$> get >>= return . concat . (map toConstraints) where toConstraints (v, (c, _, e1, e2)) = [ Op2 Bool Or (Op1 Bool Not c) (Op2 Bool Eq v e1) , Op2 Bool Or c (Op2 Bool Eq v e2) ] -- | A state monad over the translation state ('TransST'). type Trans = State TransST fresh :: Trans Integer fresh = do modify $ \st -> st {nextFresh = nextFresh st + 1} nextFresh <$> get localConstraint :: Expr -> Trans () localConstraint c = modify $ \st -> st {localConstraints = c : localConstraints st} popLocalConstraints :: Trans [Expr] popLocalConstraints = liftM2 (++) (localConstraints <$> get) getMuxes <* (modify $ \st -> st {localConstraints = [], muxes = []}) runTrans :: Bool -> Trans a -> a runTrans b m = evalState m $ TransST [] [] 0 b copilot-theorem-4.3/src/Copilot/Theorem/IL/Spec.hs0000644000000000000000000001154714762717277020251 0ustar0000000000000000{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE Safe #-} -- | This module implements the specification language for the IL format, an -- intermediate representation used in copilot-theorem to facilitate model -- checking. -- -- A Copilot program is translated into a list of quantifier-free equations -- over integer sequences, implicitly universally quantified by a free variable -- n. Each sequence roughly corresponds to a stream. -- -- This representation is partly inspired by the IL language described in -- Hagen, G.E., /VERIFYING SAFETY PROPERTIES OF LUSTRE PROGRAMS: AN SMT-BASED/ -- /APPROACH/, 2008. module Copilot.Theorem.IL.Spec ( Type (..) , Op1 (..) , Op2 (..) , SeqId , SeqIndex (..) , SeqDescr (..) , VarDescr (..) , Expr (..) , IL (..) , PropId , typeOf , _n_ , _n_plus , evalAt ) where import Data.Map (Map) import Data.Function (on) -- | Identifier of a sequence. type SeqId = String -- | Index within a sequence. data SeqIndex = Fixed Integer -- ^ An absolute index in the sequence. | Var Integer -- ^ An index relative to the current time-step. deriving (Eq, Ord, Show) -- | Idealized types. These differ from Copilot types in that, notionally, -- reals actually denote real numbers. data Type = Bool | Real | SBV8 | SBV16 | SBV32 | SBV64 | BV8 | BV16 | BV32 | BV64 deriving (Eq, Ord) instance Show Type where show = \case Bool -> "Bool" Real -> "Real" SBV8 -> "SBV8" SBV16 -> "SBV16" SBV32 -> "SBV32" SBV64 -> "SBV64" BV8 -> "BV8" BV16 -> "BV16" BV32 -> "BV32" BV64 -> "BV64" -- | Idealized representation of a Copilot expression. data Expr = ConstB Bool -- ^ Constant boolean. | ConstR Double -- ^ Constant real. | ConstI Type Integer -- ^ Constant integer. | Ite Type Expr Expr Expr -- ^ If-then-else. | Op1 Type Op1 Expr -- ^ Apply a unary operator. | Op2 Type Op2 Expr Expr -- ^ Apply a binary operator. | SVal Type SeqId SeqIndex -- ^ Refer to a value in another sequence. | FunApp Type String [Expr] -- ^ Function application. deriving (Eq, Ord, Show) -- | A description of a variable (or function) together with its type. data VarDescr = VarDescr { varName :: String , varType :: Type , args :: [Type] } instance Eq VarDescr where (==) = (==) `on` varName instance Ord VarDescr where compare = compare `on` varName -- | Identifier for a property. type PropId = String -- | Description of a sequence. data SeqDescr = SeqDescr { seqId :: SeqId , seqType :: Type } -- | An IL specification. data IL = IL { modelInit :: [Expr] , modelRec :: [Expr] , properties :: Map PropId ([Expr], Expr) , inductive :: Bool } -- | Unary operators. data Op1 = Not | Neg | Abs | Exp | Sqrt | Log | Sin | Tan | Cos | Asin | Atan | Acos | Sinh | Tanh | Cosh | Asinh | Atanh | Acosh deriving (Eq, Ord) -- | Binary operators. data Op2 = Eq | And | Or | Le | Lt | Ge | Gt | Add | Sub | Mul | Mod | Fdiv | Pow deriving (Eq, Ord) instance Show Op1 where show op = case op of Neg -> "-" Not -> "not" Abs -> "abs" Exp -> "exp" Sqrt -> "sqrt" Log -> "log" Sin -> "sin" Tan -> "tan" Cos -> "cos" Asin -> "asin" Atan -> "atan" Acos -> "acos" Sinh -> "sinh" Tanh -> "tanh" Cosh -> "cosh" Asinh -> "asinh" Atanh -> "atanh" Acosh -> "acosh" instance Show Op2 where show op = case op of And -> "and" Or -> "or" Add -> "+" Sub -> "-" Mul -> "*" Mod -> "mod" Fdiv -> "/" Pow -> "^" Eq -> "=" Le -> "<=" Ge -> ">=" Lt -> "<" Gt -> ">" -- | Return the type of an expression. typeOf :: Expr -> Type typeOf e = case e of ConstB _ -> Bool ConstR _ -> Real ConstI t _ -> t Ite t _ _ _ -> t Op1 t _ _ -> t Op2 t _ _ _ -> t SVal t _ _ -> t FunApp t _ _ -> t -- | An index to the current element of a sequence. _n_ :: SeqIndex _n_ = Var 0 -- | An index to a future element of a sequence. _n_plus :: (Integral a) => a -> SeqIndex _n_plus d = Var (toInteger d) -- | Evaluate an expression at specific index in the sequence. evalAt :: SeqIndex -> Expr -> Expr evalAt _ e@(ConstB _) = e evalAt _ e@(ConstR _) = e evalAt _ e@(ConstI _ _) = e evalAt i (Op1 t op e) = Op1 t op (evalAt i e) evalAt i (Op2 t op e1 e2) = Op2 t op (evalAt i e1) (evalAt i e2) evalAt i (Ite t c e1 e2) = Ite t (evalAt i c) (evalAt i e1) (evalAt i e2) evalAt i (FunApp t name args) = FunApp t name $ map (\e -> evalAt i e) args evalAt _ e@(SVal _ _ (Fixed _)) = e evalAt (Fixed n) (SVal t s (Var d)) = SVal t s (Fixed $ n + d) evalAt (Var k) (SVal t s (Var d)) = SVal t s (Var $ k + d)