diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml new file mode 100644 index 000000000..21e929e6c --- /dev/null +++ b/.github/workflows/build.yml @@ -0,0 +1,66 @@ +name: build + +# Trigger the workflow on push or pull request +on: + - pull_request + - push + +jobs: + cabal: + name: ${{ matrix.os }} / ghc ${{ matrix.ghc }} / cabal ${{ matrix.cabal }} + runs-on: ${{ matrix.os }} + strategy: + matrix: + os: [ubuntu-26.04] + cabal: ["2.4", "3.2", "3.4"] + ghc: + - "8.6.5" + - "8.8.4" + - "8.10.4" + - "9.0.1" + + steps: + + - uses: haskell-actions/setup@main + id: setup-haskell-cabal + name: Setup Haskell + continue-on-error: true + with: + ghc-version: ${{ matrix.ghc }} + cabal-version: ${{ matrix.cabal }} + + - name: Prepare environment + run: | + echo "$HOME/.ghcup/bin" >> $GITHUB_PATH + echo "$HOME/.cabal/bin" >> $GITHUB_PATH + sed -i -e "s;-- \(secure.\) True;\1 False;g" $HOME/.cabal/config + cabal update + + - uses: actions/checkout@v7 + + - name: Install dependencies + run: | + sudo apt-get install -y cppcheck z3 + + - name: Format check + run: | + # Fail if the any non-binary files contain trailing spaces. + if grep -nIHre ' \+$' * ; then exit 1; fi + + # Fail if the code, Cabal files, documentation or CHANGELOGs contain tabs. + if grep -rP '\t' --include='*.hs' --include='*.cabal' --include='*.md' --include='CHANGELOG' . ; then exit 1; fi + + - name: Install copilot + run: | + cabal v2-install --lib copilot/ copilot-core/ copilot-c99/ copilot-language/ copilot-libraries/ copilot-theorem/ copilot-interpreter/ copilot-prettyprinter/ + + - name: Test packages + if: matrix.ghc == '8.10.4' + run: | + cabal v2-test -j1 copilot-core/ copilot-language/ copilot-interpreter/ copilot-c99/ copilot-theorem/ copilot-libraries/ + + - name: Check cpp + if: matrix.ghc == '8.10.4' + run: | + export GHC_ENVIRONMENT=~/.ghc/x86_64-linux-8.10.4/environments/default + runhaskell copilot/examples/Heater.hs; cppcheck --force --addon=misra.py --suppress=misra-c2012-14.4 --error-exitcode=2 heater.c diff --git a/.travis.yml b/.travis.yml deleted file mode 100644 index d5255aeae..000000000 --- a/.travis.yml +++ /dev/null @@ -1,24 +0,0 @@ -# NB: don't set `language: haskell` here - -# The following enables several GHC versions to be tested; often it's enough to -# test only against the last release in a major GHC version. Feel free to omit -# lines listings versions you don't need/want testing for. -env: - - CABALVER=2.4 GHCVER=8.6.5 - - CABALVER=3.2 GHCVER=8.8.4 - - CABALVER=3.2 GHCVER=8.10.4 -# - CABALVER=head GHCVER=head # see section about GHC HEAD snapshots - -# Note: the distinction between `before_install` and `install` is not important. -before_install: - - travis_retry sudo add-apt-repository -y ppa:hvr/ghc - - travis_retry sudo apt-get update - - travis_retry sudo apt-get install cabal-install-$CABALVER ghc-$GHCVER # see note about happy/alex - - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH - - cabal --version - - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" - - travis_retry cabal update - - git submodule update --remote - -script: - - cabal v2-install --lib copilot diff --git a/cabal.project b/cabal.project index 00dfed318..812c95ba6 100644 --- a/cabal.project +++ b/cabal.project @@ -1,2 +1,10 @@ packages: - */*.cabal + copilot-bluespec/copilot-bluespec.cabal + copilot-c99/copilot-c99.cabal + copilot-core/copilot-core.cabal + copilot-interpreter/copilot-interpreter.cabal + copilot-language/copilot-language.cabal + copilot-libraries/copilot-libraries.cabal + copilot-prettyprinter/copilot-prettyprinter.cabal + copilot-theorem/copilot-theorem.cabal + copilot/copilot.cabal diff --git a/copilot-bluespec/.dockerignore b/copilot-bluespec/.dockerignore new file mode 100644 index 000000000..d1a0321bc --- /dev/null +++ b/copilot-bluespec/.dockerignore @@ -0,0 +1,29 @@ +dist +dist-* +cabal-dev +*.o +*.hi +*.chi +*.chs.h +*.dyn_o +*.dyn_hi +.hpc +.hsenv +.cabal-sandbox/ +cabal.sandbox.config +*.prof +*.aux +*.hp +*.eventlog +.stack-work/ +cabal.project.local +cabal.project.local~ +.HTF/ +.ghc.environment.* +copilot-profiling +.DS_Store +.log + +Dockerfile +.git +.gitignore diff --git a/copilot-bluespec/CHANGELOG b/copilot-bluespec/CHANGELOG new file mode 100644 index 000000000..b5130fa0b --- /dev/null +++ b/copilot-bluespec/CHANGELOG @@ -0,0 +1,76 @@ +2026-11-07 + * Version bump (4.8.2). (#792) + * Replace tabs in `DESIGN.md`. (#772) + * Remove trailing spaces. (#775) + +2026-09-07 + * Version bump (4.8.1). (#760) + * Replace tab in CHANGELOG. (#755) + +2026-07-07 + * Version bump (4.8). (#745) + +2026-05-07 + * Version bump (4.7.1). (#730) + * Fix translation of special Float values to Bluespec. (#697) + +2026-03-07 + * Version bump (4.7). (#714) + +2026-01-07 + * Version bump (4.6.1). (#705) + * Disable test suite via newly added manual cabal flag. (#673) + * Fix translation of constant floating-point values. (#696) + +2025-11-07 + * Version bump (4.6). (#679) + * Flip direction of interface inputs and outputs in Bluespec. (#677) + +2025-09-07 + * Version bump (4.5.1). (#666) + +2025-07-07 + * Version bump (4.5). (#642) + * Include `copilot-bluespec` in mainline `copilot` repo. (#623) + +2025-05-08 + * Version bump (4.4). (copilot-bluespec#43) + +2025-05-05 + * Version bump (4.3.1). (copilot-bluespec#41) + * Move Copilot.Compile.Bluespec.External out of shared directory. + (copilot-bluespec#36) + * Allow building with filepath-1.5.*. (copilot-bluespec#39) + +2025-03-10 + * Version bump (4.3). (copilot-bluespec#34) + +2025-01-20 + * Version bump (4.2). (copilot-bluespec#31) + * Implement missing floating-point operations. (copilot-bluespec#28) + * Allow using same trigger name in multiple declarations. + (copilot-bluespec#30) + +2024-11-08 + * Version bump (4.1). (copilot-bluespec#25) + +2024-09-09 + * Version bump (4.0). (copilot-bluespec#23) + * Support translating Copilot array updates to Bluespec. + (copilot-bluespec#19) + +2024-08-03 + * Test GHC 9.4 through 9.8. (copilot-bluespec#20) + +2024-07-11 + * Version bump (3.20). (copilot-bluespec#11) + * Support translating Copilot struct updates to Bluespec. + (copilot-bluespec#10) + * Fix a bug in the translation of the signum function. + (copilot-bluespec#14) + * Fix a bug in the translation of floating-point comparisons. + (copilot-bluespec#15) + +2024-03-08 + * Version bump (3.19). (copilot-bluespec#5) + * Create new library for Bluespec backend. diff --git a/copilot-bluespec/DESIGN.md b/copilot-bluespec/DESIGN.md new file mode 100644 index 000000000..6cf5cd610 --- /dev/null +++ b/copilot-bluespec/DESIGN.md @@ -0,0 +1,1183 @@ +# The design of `copilot-bluespec` + +This document provides an overview of how the `copilot-bluespec` library +compiles a Copilot specification to a Bluespec program. We assume that you +already have some familiarity with core Copilot concepts such as streams, +triggers, externs, etc. + +# Bluespec overview + +Bluespec is a high-level hardware design language (HDL). Bluespec comes with a +compiler, `bsc`, as well as its own simulator, which allows users to run +Bluespec programs easily. Bluespec also supports compiling to Verilog. + +There are two different syntaxes for the Bluespec language: Bluespec Haskell +(BH) and Bluespec SystemVerilog (BSV). Bluespec Haskell (also known as Bluespec +Classic), the older of the two syntaxes, is a more functional, high-level +syntax that is heavily inspired by the Haskell programming language. Bluespec +SystemVerilog, which was created later, more closely SystemVerilog and targets +hardware design engineers who are more familiar with SystemVerilog's syntax. +Both syntaxes are merely front-ends for the same language, and programs written +in one syntax can be converted to the other. + +The `copilot-bluespec` library compiles to Bluespec Haskell rather than +Bluespec SystemVerilog. This is primarily because BH's Haskell-like syntax is a +closer fit to how Copilot is structured, which makes the design of the compiler +simpler. + +# A small example + +To get a sense for how `copilot-bluespec` works, let us compile a simple +Copilot specification down to Bluespec. Our specification will declare a stream +containing the Fibonacci numbers, along with some triggers that will fire if a +Fibonacci number is even or odd: + +```hs +module Main (main) where + +import qualified Prelude as P () + +import Language.Copilot +import Copilot.Compile.Bluespec + +fibs :: Stream Word32 +fibs = [1, 1] ++ (fibs + drop 1 fibs) + +evenStream :: Stream Word32 -> Stream Bool +evenStream n = (n `mod` constant 2) == constant 0 + +oddStream :: Stream Word32 -> Stream Bool +oddStream n = not (evenStream n) + +spec :: Spec +spec = do + trigger "even" (evenStream fibs) [arg fibs] + trigger "odd" (oddStream fibs) [arg fibs] + +main :: IO () +main = do + spec' <- reify spec + compile "Fibs" spec' +``` + +Note that the only parts of this program that are `copilot-bluespec`–specific +are: + +1. The `import Copilot.Compile.Bluespec` statement, and +2. The call to `compile "Fibs" spec'` in `main`. This will compile the Copilot + specification to a Bluespec program named `Fibs.bs`. + +Running this program will generate four files[^1]: + +[^1]: The actual code in these files is machine-generated and somewhat +difficult to read. We have cleaned up the code slightly to make it easier to +understand. + +### `Fibs.bs` + +This defines the majority of the Bluespec code needed to implement a monitor: + +```bluespec +package Fibs where + +import FloatingPoint +import Vector + +import FibsTypes +import BluespecFP + +interface FibsIfc {-# always_ready, always_enabled #-} = + even_guard :: Bool + even_arg0 :: UInt 32 + odd_guard :: Bool + odd_arg0 :: UInt 32 + +{-# properties mkFibs = { verilog } #-} +mkFibs :: Module FibsIfc +mkFibs = + module + s0_0 :: Reg (UInt 32) <- mkReg 1 + s0_1 :: Reg (UInt 32) <- mkReg 1 + let s0 :: Vector.Vector 2 (Reg (UInt 32)) + s0 = update (update newVector 0 s0_0) 1 s0_1 + s0_idx :: Reg (Bit 64) <- mkReg 0 + + let s0_get :: Bit 64 -> UInt 32 + s0_get x = (select s0 ((s0_idx + x) % 2))._read + + s0_gen :: UInt 32 + s0_gen = s0_get 0 + s0_get 1 + + rules + "step": when True ==> + action + select s0 s0_idx := s0_gen + s0_idx := (s0_idx + 1) % 2 + + interface FibsIfc + even_guard :: Bool + even_guard = + (s0_get 0 % 2) == 0 + + even_arg0 :: UInt 32 + even_arg0 = s0_get 0 + + odd_guard :: Bool + odd_guard = + not (s0_get 0 % 2 == 0) + + odd_arg0 :: UInt 32 + odd_arg0 = s0_get 0 + +interface FibsRulesIfc = + even_action :: UInt 32 -> Action + odd_action :: UInt 32 -> Action + +mkFibsRules :: FibsIfc -> FibsRulesIfc -> Rules +mkFibsRules ifc ifcRules = + rules + "even": when ifc.even_guard ==> + ifcRules.even_action ifc.even_arg0 + + "odd": when ifc.odd_guard ==> + ifcRules.odd_action ifc.odd_arg0 + +addFibsRules :: FibsIfc -> FibsRulesIfc -> Module Empty +addFibsRules ifc ifcRules = addRules (mkFibsRules ifc ifcRules) +``` + +Those familiar with Haskell will likely recognize much of the syntax used here, +although it has some minor differences (e.g., using the `package` keyword +instead of `module`, which means something else in Bluespec). We will go into +the parts of the syntax that are unique to Bluespec as they come up. + +The `Fibs.bs` file consists of five definitions: + +1. `FibsIfc`, which is a _module interface_. An interface like `FibsIfc` can be + thought of as a special form of data type that describes how a module (a + hardware object) interacts with the surrounding environment. In order for an + application to make use of a Copilot monitor, it must instantiate + `FibsIfc`'s methods. We will see an example of how to instantiate `FibsIfc` + momentarily. + + The methods of `FibsIfc` correspond to the names of the triggers in the + Copilot spec. Each trigger has a corresponding _guard_ method, which always + has the type `Bool`, and an _argument_ method for each argument that the + trigger accepts, which has a type corresponding to the type of the argument. + We will see how these work in more detail shortly. For now, think of these + methods as being the "outputs" of the monitor program. + +2. `mkFibs`, which returns a module of type `Module FibsIfc`. A module can be + thought of as a generator of hardware objects. The module uses the `FibsIfc` + interface, which indicates that the implementation of the module + instantiates all of the methods in `FibsIfc`. If you squint, you'll + recognize bits and pieces of the original Copilot spec, such as the part + that checks for even stream elements in `even_guard`. We will go over the + individual definitions used in the implementation of `mkFibs` later. + + Note `mkFibs`'s use of the `module` and `action` keywords. These can be + thought of as specialized versions of Haskell's `do`-notation, where + `module` denotes the `Module` monad, and `action` denotes the `ActionValue` + monad. (Note that `Action` is an alias for `ActionValue ()`.) The `Module` + monad describes how to elaborate the structure of a module, whereas the + `ActionValue` monad describes the behavior of a circuit at execution time. + + Another piece of syntax that is unique to Bluespec modules is the `rules` + keyword, which denote rules that may or may not be run on each clock cycle + of the hardware. This particular module only has a single rule, named + `step`, which updates some internal state used by the module. That internal + state is then used to define the values that the interface methods return. + The `when True` part of the rule indicates that it always runs on every + clock cycle. + +3. `FibsRulesIfc` is another module interface, with one method for each of the + Copilot spec's triggers. Each method takes arguments corresponding to the + types of the triggers' arguments and returns a value of type `Action`. As + the name `FibsRulesIfcs` suggests, these methods are intended to be used to + build up rule definitions, and we will see an example of this shortly. + + As an aside, you may be wondering why there are two different interfaces + that each have methods corresponding to the Copilot spec's trigger + functions. Why not just have a single interface instead? The short answer to + this question is that these interfaces are intended for different use cases: + modules that instantiate `FibsRulesIfc` are intended for simulation, whereas + modules that instantiate `FibsIfc` are intended for Verilog code generation. + For a longer answer to this question, see the "Generating Verilog code" + section below. + +4. `mkFibsRules`, a function which takes two values that instantiate the + `FibsIfc` and `FibsRulesIfc` interfaces and returns a `Rules` value. A value + of type `Rules` is just a set of rules, which can be passed around in + Bluespec like any other value. + + `mkFibsRules` defines two rules, one for each trigger function in the + original Copilot spec. Unlike the `step` rule seen earlier, these rules may + not be run on every clock cycle. Specifically, the `even` rule will only run + if the `ifc.even_guard` expression returns `True` on a given clock cycle, + and the `odd` rule will only run if `ifc.odd_guard` returns `True` on a + given clock cycle. If one of these rules are run, then they will invoke the + corresponding method from the `FibsRulesIfc` interface, passing in the + corresponding `*_arg` method(s) from the `FibsIfc`. + +5. `addFibsRules`, a function which is very similar to `mkFibsRules`, except + that it has the return type `Module Empty` instead of `Rules`. All that + `addFibsRules` does is invoke `mkFibsRules` and then pass it to Bluespec's + `addRules` function, which actually adds the rules to a module. This is a + convenience that allows users to quickly define a full Bluespec module that + is suitable for simulation purposes (see the "Simulating Bluespec code" + section below). + + Note that the module that this returns instantiates the `Empty` interface. + `Empty` is a standard interface with no methods at all, and `Empty` is + typically used in top-level Bluespec modules that act as entrypoints to + simulation. + +### `FibsTypes.bs` + +If the Copilot specification contained any structs, then the generated +`FibsTypes.bs` file would contain the corresponding Bluespec struct +definitions. The specification in `Fibs.hs` does not contain any structs, so +this file is mostly empty: + +```bluespec +package FibsTypes where + +import FloatingPoint +import Vector +``` + +Later in this document, we will see a different example that makes use of +structs. + +### `BluespecFP.bsv` + +This is a collection of floating-point operations that leverage BDPI +(Bluespec's foreign-function interface). We will omit the full contents of this +file for brevity, but it will look something like this: + +```bluespec +import FloatingPoint::*; + +import "BDPI" function Float bs_fp_expf (Float x); +import "BDPI" function Double bs_fp_exp (Double x); +import "BDPI" function Float bs_fp_logf (Float x); +import "BDPI" function Double bs_fp_log (Double x); +... +``` + +For more information on what this file does, see the "Floating-point numbers" +section below. + +### `bs_fp.c` + +A collection of floating-point operations implemented in C. These functions are +imported via BDPI in `BluespecFP.bsv`. We will omit the full contents of this +file for brevity, but it will look something like this: + +```bluespec +#include + +union ui_float { + unsigned int i; + float f; +}; + +union ull_double { + unsigned long long i; + double f; +}; + +unsigned int bs_fp_expf(unsigned int x) { + ... +} + +unsigned long long bs_fp_exp(unsigned long long x) { + ... +} + +unsigned int bs_fp_logf(unsigned int x) { + ... +} + +unsigned long long bs_fp_log(unsigned long long x) { + ... +} + +... +``` + +For more information on what this file does, see the "Floating-point numbers" +section below. + +## Using the generated Bluespec code + +What do we do with the Bluespec code after generating it? The answer to this +question ultimately depends on your intended use case. Sometimes, it can be +useful to just simulate the Bluespec code in software, which we can do with a +variety of hardware simulators. In other use cases, it can be more useful to +directly synthesize code that can be embedded in real hardware. We will review +each of these workflows below. + +### Simulating Bluespec code + +Hardware simulation allows us to model the behavior of hardware without +actually needing access to physical hardware to do so. There are a number of +different simulators out there, such as Bluespec's own Bluesim simulator, as +well as Verilog-specific simulators such as Verilator and Icarus Verilog +(`iverilog`). We will be using Bluesim throughout this section, as it is +already bundled with each installation of Bluespec. + +Suppose we have a Bluespec program that we want to monitor with Copilot. This +program will likely have a top-level module (typically of type `Module Empty`), +and it is the role of the program's developer to decide what action the program +should take whenever the monitor fires a trigger. In a full hardware setting, +these actions might constitute something like blinking an LED or displaying a +message on a seven-segment display. For simulation purposes, however, we can +approximate this behavior by doing something simpler (e.g., printing messages +to standard output on the terminal). + +Here is an example of a program that uses the Copilot-generated `Fibs.bs` +monitor shown above: + +```bluespec +package Top where + +import Fibs +import FibsTypes + +mkTop :: Module Empty +mkTop = + module + fibsMod <- mkFibs + addFibsRules fibsMod $ + interface FibsRulesIfc + even_action x = + $display "Even Fibonacci number: %0d" x + + odd_action x = + $display "Odd Fibonacci number: %0d" x +``` + +`mkTop` is the top-level module that we will use as a program entrypoint. The +only interesting thing that it does is create a `FibsIfc` module internally +(using `mkFibs`) and then define the actions to take when the `even` or `odd` +triggers fire. These actions are defined by the implementations of the +`even_action` and `odd_action` methods, respectively, which print custom +messages to standard output. + +We can run `mkTop` by using Bluesim like so: + +``` +$ bsc -sim -g mkTop -u Top.bs +$ bsc -sim -e mkTop -o mkTop.exe bs_fp.c +$ ./mkTop.exe -m 10 +Odd Fibonacci number: 1 +Odd Fibonacci number: 1 +Even Fibonacci number: 2 +Odd Fibonacci number: 3 +Odd Fibonacci number: 5 +Even Fibonacci number: 8 +Odd Fibonacci number: 13 +Odd Fibonacci number: 21 +Even Fibonacci number: 34 +``` + +We pass `-m 10` to instruct Bluespec's simulator to only run for 10 clock +cycles. Note that the first clock cycle does not fire any rules. This is a +quirk of how hardware works: the reset signal is off in the first cycle, and +the values of registers do not become ready until after the reset signal is +enabled. Because all of the rules depend on registers, none of them will fire +until the second clock cycle or later. + +### Generating Verilog code + +Generating code that is suitable for hardware is a somewhat different problem +than generating code that is suitable for simulation. Many types of hardware +(e.g., FPGAs) require specific hardware description languages in order to +synthesize hardware circuits, such as Verilog or VHDL. Bluespec supports +compiling to Verilog, so we will be focusing on that in this section. + +A typical Verilog module has a number of _signals_ that represent the paths +into a circuit (called _inputs_), within a circuit (called _wires_), and +outside of the circuit (called _outputs_). The generated Bluespec code seen +above has been carefully designed such that the triggers in the Copilot spec +compile directly to Verilog outputs. (Copilot also has a notion of external +streams that compile to Verilog inputs; see the "External streams" section for +more on this.) + +Unlike the simulation use case, generating Verilog code does not make use of +the `FibsRulesIfc` interface at all, as this is a convenience that is only +provided to make simulation easier. Instead, we compile the `mkFibs` module +directly to Verilog: + +``` +$ bsc -verilog -g mkFibs -u Fibs.bs +``` + +This generates a Verilog module `mkFibs.v` that looks like the following: + +```verilog +module mkFibs(CLK, + RST_N, + + even_guard, + + even_arg0, + + odd_guard, + + odd_arg0); + input CLK; + input RST_N; + + // value method even_guard + output even_guard; + + // value method even_arg0 + output [31 : 0] even_arg0; + + // value method odd_guard + output odd_guard; + + // value method odd_arg0 + output [31 : 0] odd_arg0; + + ... + +endmodule // mkFibs +``` + +We show only a subset of the generated Verilog code to highlight the inputs and +outputs. There are two inputs corresponding to the `CLK` (clock) and `RST_N` +(reset) signals, which are generated for all Copilot monitors, regardless of +what the underlying spec is. The outputs correspond to the methods of the +`FibsIfc` interface. For instance, the signal in the `even_guard` output +indicates whether the `even` trigger fires on a given clock cycle or not, and +the value in the `even_arg0` output indicates what argument was passed to the +trigger on that clock cycle. These outputs can then be hooked up to another +part of a hardware circuit (e.g., LEDs) that can respond to these values as +needed. + +In general, if a Bluespec interface has a method of type `t` (where `t` is a +non-monadic type), then that method will be compiled to a Verilog output. If a +method has type `t -> Action`, however, then that method will be compiled to a +Verilog input instead. This is a key reason why it is necessary to separate +`FibsIfc` from `FibsRulesIfc`. If we compiled a `Module FibsRulesIfc` to +Verilog, then the triggers would become inputs, not outputs! + +(As a side note: the generated Bluespec code also employs various other tricks +to get the compiled Verilog code to look the way it does. For instance, note +the `{-# properties mkFibs = { verilog } #-}` pragma above `mkFibs`, which +instructs the Bluespec compiler to synthesize Verilog code for it. Also note +the `{-# always_ready, always_enabled #-}` attributes used in `FibsIfc`, which +ensure that the generated Verilog code does not contain unwanted "ready" or +"enabled" signals as inputs.) + +For a more in-depth tutorial on how to use the generated Verilog code on an +actual FPGA, see [this +tutorial](https://github.com/Copilot-Language/copilot/blob/master/copilot/examples/fpga/HelloWorld/README.md). + +## Streams + +Much like in `copilot-c99`, `copilot-bluespec` translates each stream +declaration into a ring buffer. More concretely, it translates a `Stream t` +into a `Vector n (Reg t)`, where: + +* A `Vector` is an array whose length is encoded at the type level, must + like Copilot's arrays. (Note that Bluespec has a separate `Array` type, but + `Array`s are more low-level, and they are not indexed by their length at the + type level.) + +* `n` is the minimum number of elements needed to compute later values in the + stream. + +* `t` is the stream's element type. + +* `Reg` is a register, which stores a value that can be read from and written + to. As time advances, we will update the `Reg`s in the ring buffer with later + values in the stream. + +(Commentary: a ring buffer is not the only way we could translate a stream to +Bluespec. Bluespec also has a +[`MIMO`](https://github.com/B-Lang-org/bsc/blob/f00d205867eefe09c60e11b4df155bb87041799a/src/Libraries/Base3-Misc/MIMO.bsv#L52-L73) +(many-in, many-out) queue that is _almost_ suitable for our needs, but it comes +with an unusual restriction that it must have a minimum size of 2 elements. +There exist Copilot streams that only require one element of storage, so we +would have to special-case these streams if we wanted to use a `MIMO`.) + +The `Fibs.bs` example above contains exactly one stream, which is created at +the top of the `mkFibs` function: + +```bluespec + s0_0 :: Reg (UInt 32) <- mkReg 1 + s0_1 :: Reg (UInt 32) <- mkReg 1 + let s0 :: Vector 2 (Reg (UInt 32)) + s0 = update (update newVector 0 s0_0) 1 s0_1 + s0_idx :: Reg (Bit 64) <- mkReg 0 +``` + +Here, `s0_idx`, tracks the index of the next stream element to be updated. +`mkFibs` then defines several functions in terms of `s0` and `s0_idx`, which +are then used in the rules, which we will describe later. Note that `s0_idx` is +a register of type `Bit 64`, which can be thought of as a raw 64-bit value. + +In order to access an element of a stream, we make use of the `s0_get` +function: + +```bluespec + let s0_get :: Bit 64 -> UInt 32 + s0_get x = (select s0 ((s0_idx + x) % 2))._read +``` + +This will use `s0_idx` and an offset `x` to compute which `Reg` in the `Vector` +to read from. + +## Rules + +The _rules_ govern what actions are performed during each cycle. There are +three actions in the `Fibs.bs` example above: one in `mkFibs`: + +```bluespec + rules + "step": when True ==> + action + select s0 s0_idx := s0_gen + s0_idx := (s0_idx + 1) % 2 +``` + +And two more in `mkFibsRules`: + +```bluespec + rules + "even": when ifc.even_guard ==> + ifcRules.even_action ifc.even_arg0 + + "odd": when ifc.odd_guard ==> + ifcRules.odd_action ifc.odd_arg0 +``` + +Each rule consists of three parts: + +1. A label (e.g., `"step"`) that uniquely identifies the rule within the + module. + +2. An explicit condition, which is a boolean expression of the form + `when ==> ...`. In order for a rule to fire on a given clock cycle, + its explicit condition `` must hold. + +3. A rule body (of type `Action`), which describes what action the rule + performs if it fires on a given clock cycle. + +In the example above, the `"even"` and `"odd"` rules govern the behavior of the +triggers in the Copilot specification. These rules will only fire if +`even_guard` or `odd_guard` hold, and if they fire, they will call the +`even_action` or `odd_action` method of `FibsRulesIfc`, respectively. + +The `"step"` rule is the heart of the Copilot specification, and it always runs +on each clock cycle. `"step"` does two things: + +1. It computes the next element of the `s0` stream using the `s0_gen` function, + which is defined like so: + + ```bluespec + s0_gen :: UInt 32 + s0_gen = s0_get 0 + s0_get 1 + ``` + +2. It increments `s0_idx`, making sure to wrap around to `0` if its value + exceeds `1`. + +### A note on atomicity + +Bluespec rules are _atomic_, which means that the Bluespec compiler will ensure +that the rules are executed in some logical order that ensures the absence of +race conditions. Moreover, all register updates that occur within a module's +rules are performed simultaneously at the end of a clock cycle. + +This might seem strange if you are accustomed to the execution model of a +language like C, where all statements (and their accompanying side effects) are +invoked sequentially, one after the other. This is not how Bluespec works, +however. Recall the definitions of the three rules in the example program +above: + +```bluespec +"step": when True ==> + action + select s0 s0_idx := s0_gen + s0_idx := (s0_idx + 1) % 2 + +"even": when ifc.even_guard ==> + ifcRules.even_action ifc.even_arg0 + +"odd": when ifc.odd_guard ==> + ifcRules.odd_action ifc.odd_arg0 +``` + +If this were a language like C, then the order in which the rules appear would +have an effect on the runtime semantics of the program, as the values that +`even_arg0` and `odd_arg0` return (used in the `"even"` and `"odd"` rules) +depends on the current value of `s0` and `s0_idx`. In Bluespec, however, the +order of these rules do _not_ matter. The `"step"` rule performs side effects +of updating the value of `s0` and `s0_idx`, but these effects are performed in +a single, atomic transaction at the end of the clock cycle. This means that the +values of `s0` and `s0_idx` that `s0_get` sees will always match their values +at the start of the clock cycle, regardless of what order Bluespec uses to +invoke the rules. + +Because the Bluespec compiler can pick whatever rule order it wishes to, this +can impact the order in which `$display` output is presented. This doesn't +impact the example above, as the `"even"` and `"odd"` rules will never fire on +the same clock cycle, meaning that there is always only one `$display` call per +cycle. If program fires multiple rules on a clock cycle and each one calls +`$display`, then the order in which the `$display` calls will run is not +specified. + +## External streams + +The example above sampled data from a stream that was defined within the +Copilot specification. Copilot also features a notion of _external_ streams, +which sample data from the surrounding environment. (For instance, one could +populate an external stream with data read from a sensor in a real-world +application.) To see what happens when a specification uses an external stream, +let's make one small change to the example above: + +```diff + fibs :: Stream Word32 +-fibs = [1, 1] ++ (fibs + drop 1 fibs) ++fibs = extern "fibs" Nothing +``` + +Now let's re-run the example and inspect the resulting Bluespec program. There +are several notable changes worth commenting on. The first change is in the +definition of the `FibsIfc` interface: + +```bluespec +interface FibsIfc {-# always_ready, always_enabled #-} = + even_guard :: Bool + even_arg0 :: UInt 32 + odd_guard :: Bool + odd_arg0 :: UInt 32 + fibs :: UInt 32 -> Action {-# prefixs = "", arg_names = [fibs] #-} +``` + +This time, there is an additional `fibs` method of type `UInt 32 -> Action`. +This type is carefully chosen such that when `FibsIfc` is compiled to Verilog, +`fibs` will be represented as an input to the Verilog module, which intuitively +matches how external streams are used in Copilot itself. (Also note the +attributes to the right of the type signature, which ensure that the generated +Verilog input has precisely the name "`fibs`".) + +The next change is in `mkFibs`, which demonstrates how the `fibs` method is +instantiated: + +```bluespec +{-# properties mkFibs = { verilog } #-} +mkFibs :: Module FibsIfc +mkFibs = + module + fibs_wire :: Wire (UInt 32) <- mkBypassWire + + interface FibsIfc + even_guard :: Bool + even_guard = + (fibs_wire._read % 2) == 0 + + even_arg0 :: UInt 32 + even_arg0 = fibs_wire._read + + odd_guard :: Bool + odd_guard = + not (fibs_wire._read % 2 == 0) + + odd_arg0 :: UInt 32 + odd_arg0 = fibs_wire._read + + fibs val = fibs_wire := val +``` + +This looks quite a bit different! Let's go over what has changed: + +* There are no longer any registers to hold internal state, nor is there a + `"step"` rule that updates the registers. These registers were ultimately + used in service of maintaining the ring buffers that comprised the definition + of the `fibs` stream that was defined within Copilot. Now that `fibs` is an + external stream, none of the ring buffer machinery is needed anymore. + + (Note that this is not an all-or-nothing proposition, as it is possible to + have a Copilot spec that combines defined-within-Copilot streams and external + streams.) + +* There is a new piece of internal state: the `fibs_wire` `Wire`. Moreover, + all places where `s0_get 0` was called before have now been replaced with + `fibs_wire._read`. A `Wire` is essentially a special type of register that + compiles to more compact Verilog code. + +* Finally, there is now an implementation of the `fibs` method, which writes + the supplied value to `fibs_wire`. This is what allows other methods to see + the most recently sampled value in the `fibs` external stream. + +The next change is in the definition of `FibsRulesIfc`, which has also gained +another method corresponding to the `fibs` external stream: + +```bluespec +interface FibsRulesIfc = + even_action :: UInt 32 -> Action + odd_action :: UInt 32 -> Action + fibs_action :: ActionValue (UInt 32) +``` + +Unlike `even_action` and `odd_action`, which denote an action for _consuming_ a +value, the type of `fibs_action` (`ActionValue (UInt 32)`) denotes how to +_produce_ a value. This makes sense, since the application being monitored +ultimately has to be the source of the values that populate the external +stream. The implementation of the `fibs_action` method is where this population +happens. + +Finally, the definition of `mkFibsRules` now implements a `"fibs"` rule: + +```bluespec +mkFibsRules :: FibsIfc -> FibsRulesIfc -> Rules +mkFibsRules ifc ifcRules = + rules + "even": when ifc.even_guard ==> + ifcRules.even_action ifc.even_arg0 + + "odd": when ifc.odd_guard ==> + ifcRules.odd_action ifc.odd_arg0 + + "fibs": when Prelude.True ==> + action + fibsVal <- ifcRules.fibs_action + ifc.fibs fibsVal +``` + +This new rule produces a external value using `ifcRules.fibs_action` and then +feeds it to `ifc.fibs` as an input. + +### Simulating Bluespec code involving external streams + +Let's update our example from the "Simulating Bluespec code" section to +accommodate `fibs` becoming an external stream. Here is an example of what a +`Top.bs` application might look like: + +```bluespec +package Top where + +import Vector + +import Fibs +import FibsTypes + +mkTop :: Module Empty +mkTop = + module + s0_0 :: Reg (UInt 32) <- mkReg 1 + s0_1 :: Reg (UInt 32) <- mkReg 1 + let s0 :: Vector 2 (Reg (UInt 32)) + s0 = update (update newVector 0 s0_0) 1 s0_1 + s0_idx :: Reg (Bit 64) <- mkReg 0 + + let s0_get :: Bit 64 -> UInt 32 + s0_get x = (select s0 ((s0_idx + x) % 2))._read + + s0_gen :: UInt 32 + s0_gen = s0_get 0 + s0_get 1 + + fibsMod <- mkFibs + + addFibsRules fibsMod $ + interface FibsRulesIfc + even_action x = + $display "Even Fibonacci number: %0d" x + + odd_action x = + $display "Odd Fibonacci number: %0d" x + + fibs_action = return (s0_get 0) + + rules + "step": when True ==> + action + select s0 s0_idx := s0_gen + s0_idx := (s0_idx + 1) % 2 +``` + +Note that all of the code involving registers and the `"step"` rule now lives +in `Top.bs`, as it is now the responsibility of the application to produce the +values for the `fibs` stream. There is also now an implementation of the +`fibs_action` method that returns the most recently computed Fibonacci number +on each clock cycle. + +### Generating Verilog code involving external streams + +Compiling the new version of `mkFibs` to Verilog produces a `mkFibs.v` file +that looks like the following: + +```verilog +module mkFibs(CLK, + RST_N, + + even_guard, + + even_arg0, + + odd_guard, + + odd_arg0, + + fibs); + input CLK; + input RST_N; + + // value method even_guard + output even_guard; + + // value method even_arg0 + output [31 : 0] even_arg0; + + // value method odd_guard + output odd_guard; + + // value method odd_arg0 + output [31 : 0] odd_arg0; + + // action method fibs + input [31 : 0] fibs; + + ... + +endmodule // mkFibs +``` + +As expected, the only notable change is that there is now a `fibs` input. + +# Notes + +## Arrays + +Copilot's `Array n t` type is translated directly to Bluespec's `Vector n t` +type, which makes life very simple. + +## Structs + +Like Copilot, Bluespec has a notion of structs, e.g., + +```bluespec +struct Coord = + x :: UInt 32 + y :: UInt 32 + +exCoord :: Coord +exCoord = Coord { x = 27, y = 42 } + +flipCoord :: Coord -> Coord +flipCoord c = Coord { x = C.y, y = C.x } +``` + +As such, it proves fairly straightforward to translate Copilot structs to +Bluespec structs. For instance, given these Copilot structs: + +```hs +data Volts = Volts + { numVolts :: Field "numVolts" Word16 + , flag :: Field "flag" Bool + } + +instance Struct Volts where + typeName _ = "Volts" + toValues volts = [ Value Word16 (numVolts volts) + , Value Bool (flag volts) + ] + +instance Typed Volts where + typeOf = Struct (Volts (Field 0) (Field False)) + +data Battery = Battery + { temp :: Field "temp" Word16 + , volts :: Field "volts" Volts + } + +instance Struct Battery where + typeName _ = "Battery" + toValues battery = [ Value typeOf (temp battery) + , Value typeOf (volts battery) + ] + +instance Typed Battery where + typeOf = Struct (Battery (Field 0) (Field undefined)) +``` + +`copilot-bluespec` will generate the following `StructsTypes.bs` file: + +```bluespec +package StructsTypes where + +import FloatingPoint +import Vector + +struct Volts = + numVolts :: UInt 16 + flag :: Bool + deriving (Bits) + +struct Vattery = + temp :: UInt 16 + volts :: BS_volts + deriving (Bits) +``` + +The purpose of the `*Types.bs` file is to define structs separately from other +parts of the generated code. Note that each struct definition derives a `Bits` +instance so that it can be stored inside a `Reg`. + +## Capitalization of generated names + +Copilot allows users to name several things which will influence the names of +generated code, including external streams, triggers, structs, and the file +names. The `copilot-c99` backend is able to turn just about any user-supplied +name into the name of a C identifier, as C is a remarkably case-insensitive +language. For instance, both "`Volts`" and "`volts`" are legal struct names in +C. + +Bluespec, on the other hand, imposes restrictions on which identifiers can +begin with an uppercase letter and which can begin with a lowercase letter. +The following identifiers must begin with an uppercase letter: + +* Struct names +* Interface names + +The following identifiers must begin with a lowercase letter: + +* Function and value names +* Interface method names + +Package names and rule names may begin with either an uppercase or lowercase +letter. + +How do we ensure that `copilot-bluespec` respects Bluespec's capitalization +requirements? As an example, suppose a Copilot specification defines a struct +named "`volts`". This name cannot be used as a Bluespec struct name on its own, +as it does not begin with an uppercase letter. To avoid issues, we prepend the +prefix "`BS_`" to this name to get "`BS_volts`", which is a valid Bluespec +identifier. Similarly, `copilot-bluespec` will prepend the prefix `bs_` to +uppercase Copilot names if it is used in a place that expects lowercase +Bluespec identifiers. + +Note that `copilot-bluespec` will only prepend prefixes if they are necessary +to prevent the generated code from being littered with `BS_`/`bs_` prefixes in +the common case. + +## Floating-point numbers + +`copilot-bluespec` supports all of Copilot's floating-point operations with +varying degrees of performance. The following floating-point operations compile +directly to relatively performant circuits: + +* Basic arithmetic (`(+)`, `(-)`, `(*)`, `(/)`) +* Equality checking (`(==)` and `(/=)`) +* Inequality checking (`(<)`, `(<=)`, `(>)`, and `(>=)`) +* `abs` +* `signum` +* `recip` + +These operations correspond to the floating-point operations that the Bluespec +standard library provides that are well tested. Unfortunately, the Bluespec +standard library does not offer well-tested versions (or even _any_ versions) +of the remainder of Copilot's floating-point operations. The rest of these +operations are instead implemented by using BDPI (Bluespec's foreign function +interface) to interface with C code: + +* `sqrt` +* `acos` +* `asin` +* `atan` +* `atan2` +* `cos` +* `sin` +* `tan` +* `acosh` +* `asinh` +* `atanh` +* `cosh` +* `sinh` +* `tanh` +* `exp` +* `pow` +* `log` +* `logb` +* `ceiling` +* `floor` + +Implementing these operations via C provides high confidence that they are +implemented correctly, but at a somewhat steep performance penalty. + +Because these operations need to be implemented via BDPI, `copilot-bluespec` +generates two additional files: `BluespecFP.bsv` (which contains the Bluespec +function stubs for each function implemented via BDPI) and `bs_fp.c` (which +contains the corresponding C function definitions). To see how this works, +let us take a look at one of the BDPI'd functions, `sqrt`: + +```bluespec +import "BDPI" function Double bs_fp_sqrt (Double x); +import "BDPI" function Float bs_fp_sqrtf (Float x); +``` + +This declares a Bluespec function `bs_fp_sqrt` that is implemented using a C +function (also of the name `bs_fp_sqrt`) under the hood. This takes a Bluespec +`Double` as an argument and also returns a `Double`. Note that `Double` is not +treated magically by the Bluespec compiler here. This is because any Bluespec +struct can be used in BDPI (provided that the struct type implements the `Bits` +class), and Bluespec's `Double` is implemented as a struct with a `Bits` +instance that exactly matches the bit layout expected by IEEE-754 +double-precision floats. (Similarly for Bluespec's `Float` type.) + +Note that at present, the `import "BDPI"` feature is only available when using +the BSV syntax, not the BH syntax. As such, this is currently the only place +where we generate BSV code. + +The corresponding C code for `bs_fp_sqrt(f)` is: + +```c +union ull_double { + unsigned long long i; + double f; +}; + +union ui_float { + unsigned int i; + float f; +}; + +unsigned long long bs_fp_sqrt(unsigned long long x) { + union ull_double x_u; + union ull_double r_u; + x_u.i = x; + r_u.f = sqrt(x_u.f); + return r_u.i; +} + +unsigned int bs_fp_sqrtf(unsigned int x) { + union ui_float x_u; + union ui_float r_u; + x_u.i = x; + r_u.f = sqrtf(x_u.f); + return r_u.i; +} +``` + +There is a lot to unpack here. Let's go through this step by step: + +1. The C version of `bs_fp_sqrt` takes and returns an `unsigned long long`. The + use of `unsigned long long` is dictated by Bluespec itself: whenever you + use a Bluespec type in BDPI that fits in exactly 64 bits, then Bluespec + expects the corresponding C type to be `unsigned long long`. (You can see + this for yourself by inspecting the generated `imported_BDPI_functions.h` + header file.) + + There is a similar story for `bs_fp_sqrtf`, which takes an `unsigned int`. + Bluespec dictates the use of `unsigned int` when the BDPI types fits in + exactly 32 bits. + +2. This poses something of a challenge for us, since we want the implementation + of `bs_fp_sqrt` to work over `double`s, not `unsigned long long`s. To make + this possible, we define a `union ull_double` type that allows easily + converting an `unsigned long long` to a `double` and vice versa. + + There is an analogous story for `ui_float`, which allows conversion to and + from the `unsigned int` and `float` types. + +3. Finally, we perform the `sqrt(f)` function on the argument, using + `ull_double`/`ui_float` as necessary to make the types work out. + +Strictly speaking, it is only necessary to compile the generated `bs_fp.c` file +if the generated Bluespec program makes use of any of the BDPI-related +floating-point operations mentioned above. That being said, it doesn't hurt to +compile it even if the generated Bluespec program _doesn't_ use any of them, so +it's generally good practice to pass `bs_fp.c` to `bsc`. + +Eventually, we would like to stop using BDPI in favor of native Bluespec code, +which would be more performant. To do so, would we need to address the +following Bluespec issues: + +* The implementation of `sqrt` in Bluespec's standard library is buggy: + https://github.com/B-Lang-org/bsc/issues/710 + +* Bluespec's standard library does not implement the remaining floating-point + operations at all: https://github.com/B-Lang-org/bsc/issues/368 + +## Warnings + +Code generated by `copilot-bluespec` should always compile, but it is not +currently guaranteed that the code will compile without warnings. This is +because unlike `gcc` or `clang`, the `bsc` compiler produces much more warnings +by default, and in rare cases, you may trigger `bsc` warnings. This section +describes some of these warnings. + +### Rule bodies with no actions (G0023) + +Let's suppose you have a trigger named `nop`, and you instantiate it like so: + +```bluespec +exampleIfc :: Module ExampleIfc +exampleIfc = + module + interface + nop :: Action + nop = return () +``` + +As a result, firing the `nop` trigger will do absolutely nothing. `bsc` takes +notice of this fact and warns you about it: + +``` +Warning: "CopilotTest.bs", line 27, column 8: (G0023) + The body of rule `nop' has no actions. Removing... +``` + +Where `G0023` is a unique code associated with this class of warning. + +### Warning suppression notification (S0080) + +If you find the warnings above to be annoying, `bsc` offers a way to suppress +them with the `-suppress-warnings ::...` flag. +For instance, you can suppress the G0023 warning code by passing: + +``` +-suppress-warnings G0023 +``` + +This does indeed suppress them, but now `bsc` produces _another_ warning: + +``` +Warning: Unknown position: (S0080) + 1 warnings were suppressed. +``` + +That's right, `bsc` warns you about the use of `-suppress-warnings`. That feels +a bit silly to me, but in any case, the new warning comes with its own warning +code, S0080. As a result, you can _really_ suppress warnings by passing this to +`bsc`: + +``` +-suppress-warnings G0023:S0080 +``` + +## `language-bluespec` + +`copilot-bluespec` uses +[`language-bluespec`](https://github.com/GaloisInc/language-bluespec) as a +library for creating Bluespec Haskell ASTs. Most of the source code from +`language-bluespec` is directly based on the code in the Bluespec compiler, +[`bsc`](https://github.com/B-Lang-org/bsc). This is because there is (to our +knowledge) no other existing Haskell library for representing Bluespec Haskell +ASTs, and adapting the code in `bsc` proves to be the most straightforward way +of achieving what `copilot-bluespec` needs. + +It is conceivable that if the Bluespec language evolves in the future, then we +will need to update `language-bluespec` accordingly. This seems somewhat +unlikely, however, as we are generating code in a very simple subset of the +Bluespec language. + +Another possibility is to split out the AST parts of `bsc` into their own +library and maintain them going forward. See +https://github.com/B-Lang-org/bsc/issues/546 for more discussion on this point. diff --git a/copilot-bluespec/Dockerfile b/copilot-bluespec/Dockerfile new file mode 100644 index 000000000..381842442 --- /dev/null +++ b/copilot-bluespec/Dockerfile @@ -0,0 +1,36 @@ +FROM ubuntu:focal + +ENV DEBIAN_FRONTEND=noninteractive +RUN apt-get update && \ + apt-get install --yes curl gcc g++ git libz-dev make libgmp3-dev libtcl8.6 libtinfo-dev wget + +ENV BSC_VER=2023.07 +RUN mkdir -p /root/bsc +RUN wget https://github.com/B-Lang-org/bsc/releases/download/$BSC_VER/bsc-$BSC_VER-ubuntu-20.04.tar.gz -O /root/bsc.tar.gz && \ + tar -xvf /root/bsc.tar.gz -C /root/bsc --strip-components=1 && \ + rm /root/bsc.tar.gz + +ENV GHCUP_VER=0.1.22.0 +RUN mkdir -p /root/.ghcup/bin +RUN wget https://downloads.haskell.org/~ghcup/$GHCUP_VER/x86_64-linux-ghcup-$GHCUP_VER -O /root/.ghcup/bin/ghcup && \ + chmod a+x /root/.ghcup/bin/ghcup + +ENV PATH=/root/bsc/bin:/root/.cabal/bin:/root/.ghcup/bin:$PATH + +ENV GHC_VER=9.4.8 +ENV CABAL_VER=3.8.1.0 +RUN ghcup install ghc $GHC_VER && \ + ghcup set ghc $GHC_VER && \ + ghcup install cabal $CABAL_VER && \ + ghcup set cabal $CABAL_VER && \ + cabal update + +COPY . /copilot-bluespec +WORKDIR /copilot-bluespec + +RUN cabal configure --enable-tests && \ + cabal build --write-ghc-environment-files=always && \ + cabal install --lib copilot . --package-env . && \ + cabal test + +ENTRYPOINT ["/usr/bin/bash"] diff --git a/copilot-bluespec/LICENSE b/copilot-bluespec/LICENSE new file mode 100644 index 000000000..d4ed5bc4c --- /dev/null +++ b/copilot-bluespec/LICENSE @@ -0,0 +1,29 @@ +2009 +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. diff --git a/copilot-bluespec/README.md b/copilot-bluespec/README.md new file mode 100644 index 000000000..e85d9e8c5 --- /dev/null +++ b/copilot-bluespec/README.md @@ -0,0 +1,57 @@ +[![Build Status](https://github.com/Copilot-Language/copilot-bluespec/workflows/copilot-bluespec/badge.svg)](https://github.com/Copilot-Language/copilot-bluespec/actions?query=workflow%3Acopilot-bluespec) + +# Copilot: a stream DSL +Copilot-Bluespec implements a Bluespec backend for Copilot, producing code that +is suitable for FPGAs. + +Copilot is a runtime verification framework written in Haskell. It allows the +user to write programs in a simple but powerful way using a stream-based +approach. + +Programs can be interpreted for testing, or translated Bluespec code to be +incorporated in a project, or as a standalone application. The Bluespec backend +ensures us that the output is constant in memory and time, making it suitable +for systems with hard realtime requirements. + +## Installation +Copilot-Bluespec can be found on +[Hackage](https://hackage.haskell.org/package/copilot-bluespec). It is intended +to be installed alongside a Copilot distribution by running the following +commands: + +``` +$ cabal update +$ cabal install copilot +$ cabal install copilot-bluespec +``` + +For more detailed instructions on how to install Copilot, please refer to the +[Copilot website](https://copilot-language.github.io). + +The generated Bluespec code requires `bsc` (the Bluespec compiler) in order to +be compiled. `bsc` can be downloaded +[here](https://github.com/B-Lang-org/bsc/releases). + +We also provide a [Dockerfile](Dockerfile) which automates the process of +installing Copilot, Copilot-Bluespec, and `bsc`. The Dockerfile can be built and +run using the following commands: + +``` +$ docker build -t . +$ docker run -it +``` + +Where `` is a unique name for the Docker image. + +## Further information +For further information, install instructions and documentation, please visit +the Copilot website: +[https://copilot-language.github.io](https://copilot-language.github.io) + +There is also an implementation-focused design document +[here](https://raw.githubusercontent.com/Copilot-Language/copilot/master/copilot-bluespec/DESIGN.md). + + +## License +Copilot is distributed under the BSD-3-Clause license, which can be found +[here](https://raw.githubusercontent.com/Copilot-Language/copilot/master/copilot-bluespec/LICENSE). diff --git a/copilot-bluespec/Setup.hs b/copilot-bluespec/Setup.hs new file mode 100644 index 000000000..bf6890196 --- /dev/null +++ b/copilot-bluespec/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain \ No newline at end of file diff --git a/copilot-bluespec/copilot-bluespec.cabal b/copilot-bluespec/copilot-bluespec.cabal new file mode 100644 index 000000000..1d8f7b3af --- /dev/null +++ b/copilot-bluespec/copilot-bluespec.cabal @@ -0,0 +1,112 @@ +cabal-version : >= 1.10 +name : copilot-bluespec +version : 4.8.2 +synopsis : A compiler for Copilot targeting FPGAs. +description : + This package is a back-end from Copilot to FPGAs in Bluespec. + . + Copilot is a stream (i.e., infinite lists) domain-specific language (DSL) in + Haskell. Copilot contains an interpreter, multiple back-end compilers, and + other verification tools. + . + A tutorial, examples, and other information are available at + . + +license : BSD3 +license-file : LICENSE +maintainer : Ryan Scott +homepage : https://copilot-language.github.io +bug-reports : https://github.com/Copilot-Language/copilot-bluespec/issues +stability : Experimental +category : Language, Embedded +build-type : Simple +extra-source-files : README.md + , CHANGELOG + +author : Frank Dedden + , Alwyn Goodloe + , Ivan Perez + , Ryan Scott + +x-curation: uncurated + +source-repository head + type: git + location: https://github.com/Copilot-Language/copilot-bluespec.git + +flag test-bluespec + description: Enable tests that require the Bluespec compiler (bsc) + default: False + manual: True + +library + default-language : Haskell2010 + hs-source-dirs : src + + ghc-options : -Wall + build-depends : base >= 4.9 && < 5 + , directory >= 1.3 && < 1.4 + , filepath >= 1.4 && < 1.6 + , fp-ieee >= 0.1.0 && < 0.2 + , ieee754 >= 0.8.0 && < 0.9 + , pretty >= 1.1.2 && < 1.2 + + , copilot-core >= 4.8.2 && < 4.9 + , language-bluespec >= 0.1 && < 0.2 + + exposed-modules : Copilot.Compile.Bluespec + + other-modules : Copilot.Compile.Bluespec.CodeGen + , Copilot.Compile.Bluespec.Compile + , Copilot.Compile.Bluespec.Error + , Copilot.Compile.Bluespec.Expr + , Copilot.Compile.Bluespec.External + , Copilot.Compile.Bluespec.FloatingPoint + , Copilot.Compile.Bluespec.Name + , Copilot.Compile.Bluespec.Representation + , Copilot.Compile.Bluespec.Settings + , Copilot.Compile.Bluespec.Type + +test-suite tests + type: + exitcode-stdio-1.0 + + main-is: + Main.hs + + other-modules: + Test.Copilot.Compile.Bluespec + + Test.Copilot.Compile.Bluespec.External + + build-depends: + base + , directory + , HUnit + , QuickCheck + , extra + , ieee754 + , pretty + , process + , random + , test-framework + , test-framework-hunit + , test-framework-quickcheck2 + , unix + + , copilot-core + , copilot-bluespec + + hs-source-dirs: + tests + + default-language: + Haskell2010 + + ghc-options: + -Wall + + if flag(test-bluespec) + buildable: True + else + buildable: False diff --git a/copilot-bluespec/src/Copilot/Compile/Bluespec.hs b/copilot-bluespec/src/Copilot/Compile/Bluespec.hs new file mode 100644 index 000000000..499b1cff6 --- /dev/null +++ b/copilot-bluespec/src/Copilot/Compile/Bluespec.hs @@ -0,0 +1,12 @@ +-- | Compile Copilot specifications to Bluespec code. +module Copilot.Compile.Bluespec + ( compile + , compileWith + , BluespecSettings(..) + , mkDefaultBluespecSettings + ) where + +-- Internal imports +import Copilot.Compile.Bluespec.Compile ( compile, compileWith ) +import Copilot.Compile.Bluespec.Settings ( BluespecSettings (..), + mkDefaultBluespecSettings ) diff --git a/copilot-bluespec/src/Copilot/Compile/Bluespec/CodeGen.hs b/copilot-bluespec/src/Copilot/Compile/Bluespec/CodeGen.hs new file mode 100644 index 000000000..859c73dec --- /dev/null +++ b/copilot-bluespec/src/Copilot/Compile/Bluespec/CodeGen.hs @@ -0,0 +1,367 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | High-level translation of Copilot Core into Bluespec. +module Copilot.Compile.Bluespec.CodeGen + ( -- * Type declarations + mkStructDecln + + -- * Ring buffers + , mkBuffDecln + , mkIndexDecln + , mkAccessDecln + + -- * Stream generators + , mkGenFun + + -- * External streams + , mkExtWireDecln + + -- * Monitor processing + , mkStepRule + , mkExtRule + , mkTriggerRule + + -- * Module interface specifications + , mkSpecIfcFields + , mkSpecIfcRulesFields + ) where + +-- External imports +import Data.String (IsString (..)) +import qualified Language.Bluespec.Classic.AST as BS +import qualified Language.Bluespec.Classic.AST.Builtin.Ids as BS +import qualified Language.Bluespec.Classic.AST.Builtin.Types as BS + +-- Internal imports: Copilot +import Copilot.Core + +-- Internal imports +import Copilot.Compile.Bluespec.Expr +import Copilot.Compile.Bluespec.External +import Copilot.Compile.Bluespec.Name +import Copilot.Compile.Bluespec.Representation +import Copilot.Compile.Bluespec.Type + +-- | Write a generator function for a stream. +mkGenFun :: String -> Expr a -> Type a -> BS.CDefl +mkGenFun name expr ty = + -- name :: ty + -- name = expr + BS.CLValueSign + (BS.CDef nameId (BS.CQType [] (transType ty)) [def]) + [] + where + nameId = BS.mkId BS.NoPos $ fromString $ lowercaseName name + def = BS.CClause [] [] (transExpr expr) + +-- | Bind a @Wire@ variable using @mkBypassWire@. +mkExtWireDecln :: String -> Type a -> BS.CStmt +mkExtWireDecln name ty = + BS.CSBindT + (BS.CPVar (BS.mkId BS.NoPos (fromString (wireName name)))) + Nothing + [] + (BS.CQType [] (tWire `BS.TAp` transType ty)) + (BS.CVar (BS.mkId BS.NoPos "mkBypassWire")) + +-- | Bind a buffer variable and initialise it with the stream buffer. +mkBuffDecln :: forall a. Id -> Type a -> [a] -> [BS.CStmt] +mkBuffDecln sId ty xs = + initVals ++ [BS.CSletrec [initBufSig]] + where + -- sId_0 :: Reg <- mkReg xs_0 + -- ... + -- sId_(n-1) :: Reg <- mkReg xs_(n-1) + initVals = zipWith mkInitVal xs [0..] + -- sId :: Vector n (Reg ) + -- sId = update (... (update newVector 0 sId_0) ...) (n-1) sId_(n-1) + initBufSig = BS.CLValueSign + (BS.CDef nameId (BS.CQType [] vecTy) [initBufDef]) + [] + initBufDef = BS.CClause + [] + [] + (genVector + (\idx _ -> BS.CVar $ BS.mkId BS.NoPos $ + fromString $ streamElemName sId idx) + xs) + + nameId = BS.mkId BS.NoPos $ fromString $ streamName sId + bsTy = tReg `BS.TAp` transType ty + vecTy = tVector `BS.TAp` BS.cTNum numElems BS.NoPos `BS.TAp` bsTy + numElems = toInteger $ length xs + + mkInitVal :: a -> Int -> BS.CStmt + mkInitVal x elemNum = + BS.CSBindT + (BS.CPVar elemId) + Nothing + [] + (BS.CQType [] bsTy) + (BS.CApply (BS.CVar (BS.mkId BS.NoPos "mkReg")) [constTy ty x]) + where + elemName = streamElemName sId elemNum + elemId = BS.mkId BS.NoPos $ fromString elemName + +-- | Make an index variable and initialise it to 0. +mkIndexDecln :: Id -> BS.CStmt +mkIndexDecln sId = + -- sId_idx :: Reg (Bit 64) <- mkReg 0 + BS.CSBindT + (BS.CPVar nameId) + Nothing + [] + (BS.CQType [] bsTy) + (BS.CApply (BS.CVar (BS.mkId BS.NoPos "mkReg")) + [cLit $ BS.LInt $ BS.ilDec 0]) + where + nameId = BS.mkId BS.NoPos $ fromString $ indexName sId + bsTy = tReg `BS.TAp` BS.tBitN 64 BS.NoPos + +-- | Define an accessor function for the ring buffer associated with a stream +mkAccessDecln :: Id -> Type a -> [a] -> BS.CDefl +mkAccessDecln sId ty xs = + -- sId_get :: Bits 64 -> ty + -- sId_get x = (select sId ((sId_idx + x) % buffLength))._read + BS.CLValueSign (BS.CDef nameId (BS.CQType [] funTy) [def]) [] + where + def = BS.CClause [BS.CPVar argId] [] expr + argTy = BS.tBit `BS.TAp` BS.cTNum 64 BS.NoPos + retTy = transType ty + funTy = BS.tArrow `BS.TAp` argTy `BS.TAp` retTy + name = streamAccessorName sId + nameId = BS.mkId BS.NoPos $ fromString name + buffLength = cLit $ BS.LInt $ BS.ilDec $ toInteger $ length xs + argId = BS.mkId BS.NoPos "x" + index = BS.CApply (BS.CVar (BS.idPercentAt BS.NoPos)) + [ BS.CApply (BS.CVar BS.idPlus) + [ BS.CVar (BS.mkId BS.NoPos (fromString (indexName sId))) + , BS.CVar argId + ] + , buffLength + ] + indexExpr = cIndexVector + (BS.CVar (BS.mkId BS.NoPos (fromString (streamName sId)))) + index + expr = BS.CSelect indexExpr (BS.id_read BS.NoPos) + +-- | Define fields for a module interface containing a specification's trigger +-- functions and external variables. +mkSpecIfcFields :: [UniqueTrigger] -> [External] -> [BS.CField] +mkSpecIfcFields uniqueTriggers exts = + concatMap mkTriggerFields uniqueTriggers ++ map mkExtField exts + where + -- trigger_guard :: Bool + -- trigger_arg0 :: arg_ty_0 + -- ... + -- trigger_arg(n-1) :: arg_ty_(n-1) + mkTriggerFields :: UniqueTrigger -> [BS.CField] + mkTriggerFields (UniqueTrigger uniqueName (Trigger _name _ args)) = + triggerGuardField : triggerArgFields + where + triggerGuardField :: BS.CField + triggerGuardField = mkField (guardName uniqueName) [] BS.tBool + + triggerArgFields :: [BS.CField] + triggerArgFields = + zipWith + (\(UExpr arg _) argName -> mkField argName [] (transType arg)) + args + (argNames uniqueName) + + -- ext :: ty -> Action + mkExtField :: External -> BS.CField + mkExtField (External name ty) = + mkField + name + [ BS.PIPrefixStr "" + , BS.PIArgNames [BS.mkId BS.NoPos $ fromString $ lowercaseName name] + ] + (BS.tArrow `BS.TAp` transType ty `BS.TAp` BS.tAction) + +-- | Define fields for a module interface containing the actions to perform for +-- a specification's trigger functions and external variables. +mkSpecIfcRulesFields :: [Trigger] -> [External] -> [BS.CField] +mkSpecIfcRulesFields triggers exts = + map mkTriggerField triggers ++ map mkExtField exts + where + -- trigger_action :: arg_ty_0 -> ... -> arg_ty_(n-1) -> Action + mkTriggerField :: Trigger -> BS.CField + mkTriggerField (Trigger name _ args) = + mkField (actionName name) [] triggerFieldType + where + triggerFieldType :: BS.CType + triggerFieldType = foldr addArgType BS.tAction args + + addArgType :: UExpr -> BS.CType -> BS.CType + addArgType (UExpr arg _) res = + BS.tArrow `BS.TAp` transType arg `BS.TAp` res + + -- ext_action :: ActionValue ty + mkExtField :: External -> BS.CField + mkExtField (External name ty) = + mkField (actionName name) [] (BS.tActionValue `BS.TAp` transType ty) + +-- | Define a rule for an external stream that performs an action on the most +-- recently computed value from the stream. +mkExtRule :: External -> BS.CRule +mkExtRule (External name _) = + -- rules + -- "ext": when True ==> + -- action + -- extVal <- ifcRules.ext_action + -- ifc.ext extVal + BS.CRule + [] + (Just $ cLit $ BS.LString name) + [BS.CQFilter $ BS.CCon BS.idTrue []] + (BS.Caction BS.NoPos [callExtAction, callExt]) + where + ifcArgId = BS.mkId BS.NoPos $ fromString ifcArgName + ifcRulesArgId = BS.mkId BS.NoPos $ fromString ifcRulesArgName + + extActionId = BS.mkId BS.NoPos $ fromString $ actionName name + extId = BS.mkId BS.NoPos $ fromString name + extValId = BS.mkId BS.NoPos $ fromString $ name ++ "Val" + + -- extVal <- ifcRules.ext_action + callExtAction :: BS.CStmt + callExtAction = + BS.CSBind + (BS.CPVar extValId) + Nothing + [] + (BS.CSelect (BS.CVar ifcRulesArgId) extActionId) + + -- ifc.ext extVal + callExt :: BS.CStmt + callExt = + BS.CSExpr Nothing $ + BS.CApply (BS.CSelect (BS.CVar ifcArgId) extId) [BS.CVar extValId] + +-- | Define a rule for a trigger function that performs an action when the rule +-- fires. +mkTriggerRule :: UniqueTrigger -> BS.CRule +mkTriggerRule (UniqueTrigger uniqueName (Trigger name _ args)) = + -- rules + -- "trigger": when ifc.trigger_guard ==> + -- ifcRules.trigger_action ifc.trigger_arg0 + BS.CRule + [] + (Just $ cLit $ BS.LString uniqueName) + [ BS.CQFilter $ + BS.CSelect + (BS.CVar ifcArgId) + (BS.mkId BS.NoPos $ fromString $ guardName uniqueName) + ] + (BS.CApply actionNameExpr args') + where + ifcArgId = BS.mkId BS.NoPos $ fromString ifcArgName + ifcRulesArgId = BS.mkId BS.NoPos $ fromString ifcRulesArgName + -- Note that we use 'name' here instead of 'uniqueName', as 'name' is the + -- name of the actual external function. + actionNameId = BS.mkId BS.NoPos $ fromString $ actionName name + actionNameExpr = BS.CSelect (BS.CVar ifcRulesArgId) actionNameId + + args' = take (length args) (map argCall (argNames uniqueName)) + argCall = BS.CSelect (BS.CVar ifcArgId) . BS.mkId BS.NoPos . fromString + +-- | Writes the @step@ rule that updates all streams. +mkStepRule :: [Stream] -> Maybe BS.CRule +mkStepRule streams + | null allUpdates + = -- If there is nothing to update, don't bother creating a step rule. + -- Doing so wouldn't harm anything, but bsc will generate a warning + -- when compiling such an empty rule. + Nothing + | otherwise + = Just $ + BS.CRule + [] + (Just $ cLit $ BS.LString "step") + [BS.CQFilter $ BS.CCon BS.idTrue []] + (BS.Caction BS.NoPos allUpdates) + where + allUpdates = bufferUpdates ++ indexUpdates + (bufferUpdates, indexUpdates) = unzip $ map mkUpdateGlobals streams + + -- Write code to update global stream buffers and index. + mkUpdateGlobals :: Stream -> (BS.CStmt, BS.CStmt) + mkUpdateGlobals (Stream sId buff _ _) = + (bufferUpdate, indexUpdate) + where + bufferUpdate = + BS.CSExpr Nothing $ + BS.Cwrite + BS.NoPos + (cIndexVector (BS.CVar buffId) (BS.CVar indexId)) + (BS.CVar genId) + + indexUpdate = + BS.CSExpr Nothing $ + BS.Cwrite + BS.NoPos + (BS.CVar indexId) + (BS.CApply (BS.CVar (BS.idPercentAt BS.NoPos)) + [incIndex, buffLength]) + where + buffLength = cLit $ BS.LInt $ BS.ilDec $ toInteger $ length buff + incIndex = BS.CApply (BS.CVar BS.idPlus) + [ BS.CVar indexId + , cLit $ BS.LInt $ BS.ilDec 1 + ] + + buffId = BS.mkId BS.NoPos $ fromString $ streamName sId + genId = BS.mkId BS.NoPos $ fromString $ generatorName sId + indexId = BS.mkId BS.NoPos $ fromString $ indexName sId + +-- | Write a struct declaration based on its definition. +mkStructDecln :: Struct a => a -> BS.CDefn +mkStructDecln x = + BS.Cstruct + True + BS.SStruct + (BS.IdK structId) + [] -- No type variables + structFields + -- Derive a Bits instance so that we can put this struct in a Reg + [BS.CTypeclass BS.idBits] + where + structId = BS.mkId BS.NoPos $ fromString $ uppercaseName $ typeName x + structFields = map mkStructField $ toValues x + + mkStructField :: Value a -> BS.CField + mkStructField (Value ty field) = + mkField (fieldName field) [] (transType ty) + +-- | Write a field of a struct or interface, along with its pragmas and type +-- signature. +mkField :: String -> [BS.IfcPragma] -> BS.CType -> BS.CField +mkField name pragmas ty = + BS.CField + { BS.cf_name = BS.mkId BS.NoPos $ fromString $ lowercaseName name + , BS.cf_pragmas = Just pragmas + , BS.cf_type = BS.CQType [] ty + , BS.cf_default = [] + , BS.cf_orig_type = Nothing + } + +-- | The @Reg@ Bluespec interface type. +tReg :: BS.CType +tReg = BS.TCon $ + BS.TyCon + { BS.tcon_name = BS.idReg + , BS.tcon_kind = Just (BS.Kfun BS.KStar BS.KStar) + , BS.tcon_sort = BS.TIstruct (BS.SInterface []) + [BS.id_write BS.NoPos, BS.id_read BS.NoPos] + } + +-- | The @Wire@ Bluespec type. +tWire :: BS.CType +tWire = BS.TCon $ + BS.TyCon + { BS.tcon_name = BS.mkId BS.NoPos "Wire" + , BS.tcon_kind = Just (BS.Kfun BS.KStar BS.KStar) + , BS.tcon_sort = BS.TItype 0 tReg + } diff --git a/copilot-bluespec/src/Copilot/Compile/Bluespec/Compile.hs b/copilot-bluespec/src/Copilot/Compile/Bluespec/Compile.hs new file mode 100644 index 000000000..5343fd6a1 --- /dev/null +++ b/copilot-bluespec/src/Copilot/Compile/Bluespec/Compile.hs @@ -0,0 +1,437 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Compile Copilot specifications to Bluespec code. +module Copilot.Compile.Bluespec.Compile + ( compile + , compileWith + ) where + +-- External imports +import Data.List (nub, nubBy, union) +import Data.Maybe (catMaybes, maybeToList) +import Data.String (IsString (..)) +import Data.Type.Equality (testEquality, (:~:)(Refl)) +import Data.Typeable (Typeable) +import qualified Language.Bluespec.Classic.AST as BS +import qualified Language.Bluespec.Classic.AST.Builtin.Ids as BS +import qualified Language.Bluespec.Classic.AST.Builtin.Types as BS +import Text.PrettyPrint.HughesPJClass (Pretty (..), render) +import System.Directory (createDirectoryIfMissing) +import System.Exit (exitFailure) +import System.FilePath (()) +import System.IO (hPutStrLn, stderr) + +-- Internal imports: Copilot +import Copilot.Core + +-- Internal imports +import Copilot.Compile.Bluespec.CodeGen +import Copilot.Compile.Bluespec.External +import Copilot.Compile.Bluespec.FloatingPoint +import Copilot.Compile.Bluespec.Name +import Copilot.Compile.Bluespec.Representation +import Copilot.Compile.Bluespec.Settings + +-- | Compile a specification to a Bluespec file. +-- +-- The first argument is the settings for the Bluespec code generated. +-- +-- The second argument is used as a module name and the prefix for the .bs files +-- that are generated. +compileWith :: BluespecSettings -> String -> Spec -> IO () +compileWith bsSettings prefix spec + | null triggers + = do hPutStrLn stderr $ + "Copilot error: attempt at compiling empty specification.\n" + ++ "You must define at least one trigger to generate Bluespec monitors." + exitFailure + + | incompatibleTriggers triggers + = do hPutStrLn stderr $ + "Copilot error: attempt at compiling specification with conflicting " + ++ "trigger definitions.\n" + ++ "Multiple triggers have the same name, but different argument " + ++ "types.\n" + exitFailure + + | otherwise + = do let typesBsFile = render $ pPrint $ compileTypesBS bsSettings prefix spec + bsFile = render $ pPrint $ compileBS bsSettings prefix spec + + let dir = bluespecSettingsOutputDirectory bsSettings + createDirectoryIfMissing True dir + writeFile (dir specTypesPkgName prefix ++ ".bs") typesBsFile + writeFile (dir "bs_fp.c") copilotBluespecFloatingPointC + writeFile (dir "BluespecFP.bsv") copilotBluespecFloatingPointBSV + writeFile (dir prefix ++ ".bs") bsFile + where + triggers = specTriggers spec + + -- Check that two triggers do no conflict, that is: if their names are + -- equal, the types of their arguments should be equal as well. + incompatibleTriggers :: [Trigger] -> Bool + incompatibleTriggers = pairwiseAny conflict + where + conflict :: Trigger -> Trigger -> Bool + conflict t1@(Trigger name1 _ _) t2@(Trigger name2 _ _) = + name1 == name2 && not (compareTrigger t1 t2) + + -- True if the function holds for any pair of elements. We assume that + -- the function is commutative. + pairwiseAny :: (a -> a -> Bool) -> [a] -> Bool + pairwiseAny _ [] = False + pairwiseAny _ (_:[]) = False + pairwiseAny f (x:xs) = any (f x) xs || pairwiseAny f xs + +-- | Compile a specification to a Bluespec. +-- +-- The first argument is used as a prefix for the generated .bs files. +compile :: String -> Spec -> IO () +compile = compileWith mkDefaultBluespecSettings + +-- | Generate a @.bs@ file from a 'Spec'. This is the main payload of +-- the Bluespec backend. See the @copilot-bluespec/DESIGN.md@ document for a +-- high-level description of what this file contains. +compileBS :: BluespecSettings -> String -> Spec -> BS.CPackage +compileBS _bsSettings prefix spec = + BS.CPackage + (BS.mkId BS.NoPos (fromString prefix)) + (Right []) + (stdLibImports ++ genImports) + [] + [ ifcDef + , mkModuleDefPragma + , mkModuleDef + , ifcRulesDef + , mkModuleRulesDef + , addModuleRulesDef + ] + [] + where + -- import Types + genImports :: [BS.CImport] + genImports = + [ BS.CImpId False $ BS.mkId BS.NoPos $ fromString + $ specTypesPkgName prefix + , BS.CImpId False $ BS.mkId BS.NoPos "BluespecFP" + ] + + -- interface Ifc {-# always_ready, always_enabled #-} = + -- ... + ifcDef :: BS.CDefn + ifcDef = BS.Cstruct + True + (BS.SInterface [BS.PIAlwaysRdy, BS.PIAlwaysEnabled]) + (BS.IdK ifcId) + [] -- No type variables + ifcFields + [] -- No derived instances + + -- {-# properties mkFibs = { verilog } #-} + mkModuleDefPragma :: BS.CDefn + mkModuleDefPragma = BS.CPragma $ BS.Pproperties mkModuleDefId [BS.PPverilog] + + -- mk :: Module Ifc + -- mk = + -- module + -- ... + mkModuleDef :: BS.CDefn + mkModuleDef = BS.CValueSign $ + BS.CDef + mkModuleDefId + (BS.CQType [] (BS.tModule `BS.TAp` ifcTy)) + [ BS.CClause [] [] $ + BS.Cmodule BS.NoPos $ + wireGlobalStmts ++ genFunStmts ++ ruleIfcStmts + ] + where + wireGlobalStmts :: [BS.CMStmt] + wireGlobalStmts = map BS.CMStmt (mkExtWires ++ mkGlobals) + + genFunStmts :: [BS.CMStmt] + genFunStmts = + -- language-bluespec's pretty-printer will error if it encounters a + -- CSletrec with an empty list of definitions, so avoid generating a + -- CSletrec if there are no streams. + [ BS.CMStmt $ BS.CSletrec genFuns | not (null genFuns) ] + + ruleIfcStmts :: [BS.CMStmt] + ruleIfcStmts = + [ BS.CMrules $ BS.Crules [] $ maybeToList $ mkStepRule streams + , BS.CMinterface $ BS.Cinterface BS.NoPos (Just ifcId) ifcMethodImpls + ] + + -- interface RulesIfc = + -- ... + ifcRulesDef :: BS.CDefn + ifcRulesDef = + BS.Cstruct + True + (BS.SInterface []) + (BS.IdK ifcRulesId) + [] -- No type variables + ifcRulesFields + [] -- No derived instances + + -- mkRules :: Ifc -> RulesIfc -> Rules + -- mkRules ifc ifcRules = + -- rules + -- ... + mkModuleRulesDef :: BS.CDefn + mkModuleRulesDef = + BS.CValueSign $ + BS.CDef + mkModuleRulesDefId + (BS.CQType [] mkModuleRulesType) + [ BS.CClause + (map BS.CPVar [ifcArgId, ifcRulesArgId]) + [] + (BS.Crules [] moduleRules) + ] + where + -- Ifc -> RulesIfc -> Rules + mkModuleRulesType :: BS.CType + mkModuleRulesType = + BS.tArrow `BS.TAp` ifcTy `BS.TAp` + (BS.tArrow `BS.TAp` ifcRulesTy `BS.TAp` BS.tRules) + + -- rules + -- ... + moduleRules :: [BS.CRule] + moduleRules = map mkTriggerRule uniqueTriggers ++ map mkExtRule exts + + -- addRules :: Ifc -> RulesIfc -> Module Empty + -- addRules ifc ifcRules = addRules (mkRules ifc ifcRules) + addModuleRulesDef :: BS.CDefn + addModuleRulesDef = + BS.CValueSign $ + BS.CDef + addModuleRulesDefId + (BS.CQType [] addModuleRulesType) + [ BS.CClause + (map BS.CPVar [ifcArgId, ifcRulesArgId]) + [] + addModuleRulesExpr + ] + where + -- Ifc -> RulesIfc -> Module Empty + addModuleRulesType :: BS.CType + addModuleRulesType = + BS.tArrow `BS.TAp` ifcTy `BS.TAp` + (BS.tArrow `BS.TAp` ifcRulesTy `BS.TAp` + (BS.tModule `BS.TAp` emptyTy)) + + -- addRules (mkRules ifc ifcRules) + addModuleRulesExpr :: BS.CExpr + addModuleRulesExpr = + BS.CApply + (BS.CVar (BS.idAddRules BS.NoPos)) + [BS.CApply + (BS.CVar mkModuleRulesDefId) + (map BS.CVar [ifcArgId, ifcRulesArgId])] + + mkModuleDefId = + BS.mkId BS.NoPos $ fromString $ "mk" ++ prefix + mkModuleRulesDefId = + BS.mkId BS.NoPos $ fromString $ "mk" ++ prefix ++ "Rules" + addModuleRulesDefId = + BS.mkId BS.NoPos $ fromString $ "add" ++ prefix ++ "Rules" + + streams = specStreams spec + triggers = specTriggers spec + uniqueTriggers = mkUniqueTriggers triggers + exts = gatherExts streams triggers + + -- Remove duplicates due to multiple guards for the same trigger. + triggersNoDups = nubBy compareTrigger triggers + + ifcArgId = BS.mkId BS.NoPos $ fromString ifcArgName + ifcRulesArgId = BS.mkId BS.NoPos $ fromString ifcRulesArgName + + ifcId = BS.mkId BS.NoPos $ fromString $ specIfcName prefix + ifcFields = mkSpecIfcFields uniqueTriggers exts + ifcTy = BS.TCon (BS.TyCon + { BS.tcon_name = ifcId + , BS.tcon_kind = Just BS.KStar + , BS.tcon_sort = BS.TIstruct + (BS.SInterface []) + (map BS.cf_name ifcFields) + }) + + ifcRulesId = BS.mkId BS.NoPos $ fromString $ specIfcRulesName prefix + ifcRulesFields = mkSpecIfcRulesFields triggersNoDups exts + + ifcRulesTy = + BS.TCon $ + BS.TyCon + { BS.tcon_name = ifcRulesId + , BS.tcon_kind = Just BS.KStar + , BS.tcon_sort = + BS.TIstruct (BS.SInterface []) (map BS.cf_name ifcRulesFields) + } + + emptyTy = BS.TCon (BS.TyCon + { BS.tcon_name = BS.idEmpty + , BS.tcon_kind = Just BS.KStar + , BS.tcon_sort = BS.TIstruct (BS.SInterface []) [] + }) + + -- Bind @Wire@ variables for each extern stream. + mkExtWires :: [BS.CStmt] + mkExtWires = map extWireStmt exts + where + extWireStmt :: External -> BS.CStmt + extWireStmt (External name ty) = mkExtWireDecln name ty + + -- Make buffer and index declarations for streams. + mkGlobals :: [BS.CStmt] + mkGlobals = concatMap buffDecln streams ++ map indexDecln streams + where + buffDecln (Stream sId buff _ ty) = mkBuffDecln sId ty buff + indexDecln (Stream sId _ _ _ ) = mkIndexDecln sId + + -- Make generator functions for streams. + genFuns :: [BS.CDefl] + genFuns = map accessDecln streams ++ map streamGen streams + where + accessDecln :: Stream -> BS.CDefl + accessDecln (Stream sId buff _ ty) = mkAccessDecln sId ty buff + + streamGen :: Stream -> BS.CDefl + streamGen (Stream sId _ expr ty) = mkGenFun (generatorName sId) expr ty + + -- Make interface methods for @Ifc@. + ifcMethodImpls :: [BS.CDefl] + ifcMethodImpls = + concatMap triggerMethodImpls uniqueTriggers + ++ map extMethodImpl exts + where + -- interface + -- ext val = ext_wire := val + extMethodImpl :: External -> BS.CDefl + extMethodImpl (External name _) = + BS.CLValue extMethodId [extMethodClause] [] + where + extMethodId = BS.mkId BS.NoPos (fromString name) + valId = BS.mkId BS.NoPos "val" + + -- ext val = ext_wire := val + extMethodClause :: BS.CClause + extMethodClause = + BS.CClause + [BS.CPVar valId] + [] + (BS.Cwrite + BS.NoPos + (BS.CVar (BS.mkId BS.NoPos (fromString (wireName name)))) + (BS.CVar valId)) + + -- interface + -- trig_guard = ... + -- trig_arg0 = ... + -- ... + -- trig_arg(n-1) = ... + triggerMethodImpls :: UniqueTrigger -> [BS.CDefl] + triggerMethodImpls uniqueTrigger = guardDef : argDefs + where + UniqueTrigger uniqueName (Trigger _name guard args) = uniqueTrigger + + guardDef = mkGenFun (guardName uniqueName) guard Bool + argDefs = map argGen (zip (argNames uniqueName) args) + + argGen :: (String, UExpr) -> BS.CDefl + argGen (argName, UExpr ty expr) = mkGenFun argName expr ty + +-- | Generate a @Types.bs@ file from a 'Spec'. This declares the types +-- of any structs used by the Copilot specification. This is put in a separate +-- file so that larger applications can more easily substitute their own struct +-- definitions if desired. +compileTypesBS :: BluespecSettings -> String -> Spec -> BS.CPackage +compileTypesBS _bsSettings prefix spec = + BS.CPackage + typesId + (Right []) + stdLibImports + [] + structDefs + [] + where + typesId = BS.mkId BS.NoPos $ fromString $ specTypesPkgName prefix + + structDefs = mkTypeDeclns exprs + + exprs = gatherExprs streams triggers + streams = specStreams spec + + -- Remove duplicates due to multiple guards for the same trigger. + triggers = nubBy compareTrigger (specTriggers spec) + + -- Generate type declarations. + mkTypeDeclns :: [UExpr] -> [BS.CDefn] + mkTypeDeclns es = catMaybes $ map mkTypeDecln uTypes + where + uTypes = nub $ concatMap (\(UExpr _ e) -> exprTypes e) es + + mkTypeDecln (UType ty) = case ty of + Struct x -> Just $ mkStructDecln x + _ -> Nothing + +-- | Imports from the Bluespec standard library. +stdLibImports :: [BS.CImport] +stdLibImports = + [ BS.CImpId False $ BS.mkId BS.NoPos "FloatingPoint" + , BS.CImpId False $ BS.mkId BS.NoPos "Vector" + ] + +-- ** Obtain information from Copilot Core Exprs and Types. + +-- | List all types of an expression, returns items uniquely. +exprTypes :: Typeable a => Expr a -> [UType] +exprTypes e = case e of + Const ty _ -> typeTypes ty + Local ty1 ty2 _ e1 e2 -> typeTypes ty1 `union` typeTypes ty2 + `union` exprTypes e1 `union` exprTypes e2 + Var ty _ -> typeTypes ty + Drop ty _ _ -> typeTypes ty + ExternVar ty _ _ -> typeTypes ty + Op1 _ e1 -> exprTypes e1 + Op2 _ e1 e2 -> exprTypes e1 `union` exprTypes e2 + Op3 _ e1 e2 e3 -> exprTypes e1 `union` exprTypes e2 + `union` exprTypes e3 + Label ty _ _ -> typeTypes ty + +-- | List all types of a type, returns items uniquely. +typeTypes :: Typeable a => Type a -> [UType] +typeTypes ty = case ty of + Array ty' -> typeTypes ty' `union` [UType ty] + Struct x -> concatMap (\(Value ty' _) -> typeTypes ty') (toValues x) + `union` [UType ty] + _ -> [UType ty] + +-- | Collect all expression of a list of streams and triggers and wrap them +-- into an UEXpr. +gatherExprs :: [Stream] -> [Trigger] -> [UExpr] +gatherExprs streams triggers = map streamUExpr streams + ++ concatMap triggerUExpr triggers + where + streamUExpr (Stream _ _ expr ty) = UExpr ty expr + triggerUExpr (Trigger _ guard args) = UExpr Bool guard : args + +-- | We consider triggers to be equal, if their names match and the number and +-- types of arguments. +compareTrigger :: Trigger -> Trigger -> Bool +compareTrigger (Trigger name1 _ args1) (Trigger name2 _ args2) + = name1 == name2 && compareArguments args1 args2 + + where + compareArguments :: [UExpr] -> [UExpr] -> Bool + compareArguments [] [] = True + compareArguments [] _ = False + compareArguments _ [] = False + compareArguments (x:xs) (y:ys) = compareUExpr x y && compareArguments xs ys + + compareUExpr :: UExpr -> UExpr -> Bool + compareUExpr (UExpr ty1 _) (UExpr ty2 _) + | Just Refl <- testEquality ty1 ty2 = True + | otherwise = False diff --git a/copilot-bluespec/src/Copilot/Compile/Bluespec/Error.hs b/copilot-bluespec/src/Copilot/Compile/Bluespec/Error.hs new file mode 100644 index 000000000..b3d719da0 --- /dev/null +++ b/copilot-bluespec/src/Copilot/Compile/Bluespec/Error.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE Safe #-} + +-- | +-- Copyright: (c) 2011 National Institute of Aerospace / Galois, Inc. +-- +-- Custom functions to report error messages to users. +module Copilot.Compile.Bluespec.Error + ( impossible ) + where + +-- | Report an error due to a bug in Copilot. +impossible :: String -- ^ Name of the function in which the error was detected. + -> String -- ^ Name of the package in which the function is located. + -> a +impossible function package = + error $ "Impossible error in function " + ++ function ++ ", in package " ++ package + ++ ". Please file an issue at " + ++ "https://github.com/Copilot-Language/copilot/issues" + ++ " or email the maintainers at " diff --git a/copilot-bluespec/src/Copilot/Compile/Bluespec/Expr.hs b/copilot-bluespec/src/Copilot/Compile/Bluespec/Expr.hs new file mode 100644 index 000000000..84a9ffe7a --- /dev/null +++ b/copilot-bluespec/src/Copilot/Compile/Bluespec/Expr.hs @@ -0,0 +1,733 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Translate Copilot Core expressions and operators to Bluespec. +module Copilot.Compile.Bluespec.Expr + ( transExpr + , cIndexVector + , cLit + , constTy + , genVector + ) where + +-- External imports +import Data.Foldable (foldl') +import Data.String (IsString (..)) +import qualified Language.Bluespec.Classic.AST as BS +import qualified Language.Bluespec.Classic.AST.Builtin.Ids as BS +import Numeric.Floating.IEEE.NaN (isSignaling, setPayloadSignaling, setPayload, getPayload) +import GHC.Float (double2Float, castFloatToWord32, castDoubleToWord64, float2Double) + +-- Internal imports: Copilot +import Copilot.Core + +-- Internal imports +import Copilot.Compile.Bluespec.Error (impossible) +import Copilot.Compile.Bluespec.Name +import Copilot.Compile.Bluespec.Type + +-- | Translates a Copilot Core expression into a Bluespec expression. +transExpr :: Expr a -> BS.CExpr +transExpr (Const ty x) = constTy ty x + +transExpr (Local ty1 _ name e1 e2) = + let nameId = BS.mkId BS.NoPos $ fromString name + e1' = transExpr e1 + ty1' = transType ty1 + e2' = transExpr e2 in + BS.Cletrec + [ BS.CLValueSign + (BS.CDef nameId (BS.CQType [] ty1') [BS.CClause [] [] e1']) + [] + ] + e2' + +transExpr (Var _ n) = BS.CVar $ BS.mkId BS.NoPos $ fromString n + +transExpr (Drop _ amount sid) = + let accessVar = streamAccessorName sid + index = BS.LInt $ BS.ilDec $ fromIntegral amount in + BS.CApply (BS.CVar $ BS.mkId BS.NoPos $ fromString accessVar) + [BS.CLit $ BS.CLiteral BS.NoPos index] + +transExpr (ExternVar _ name _) = + BS.CSelect + (BS.CVar $ BS.mkId BS.NoPos $ fromString $ wireName name) + (BS.id_read BS.NoPos) + +transExpr (Label _ _ e) = transExpr e -- ignore label + +transExpr (Op1 op e) = transOp1 op (transExpr e) + +transExpr (Op2 op e1 e2) = transOp2 op (transExpr e1) (transExpr e2) + +transExpr (Op3 op e1 e2 e3) = + transOp3 op (transExpr e1) (transExpr e2) (transExpr e3) + +-- | Translates a Copilot unary operator and its argument into a Bluespec +-- function. +transOp1 :: Op1 a b -> BS.CExpr -> BS.CExpr +transOp1 op e = + case op of + Not -> app BS.idNot + Abs _ty -> app $ BS.mkId BS.NoPos "abs" + Sign ty -> transSign ty e + -- Bluespec's Arith class does not have a `recip` method corresponding to + -- Haskell's `recip` in the `Fractional` class, so we implement it + -- ourselves. + Recip ty -> BS.CApply + (BS.CVar (BS.idSlashAt BS.NoPos)) + [constNumTy ty 1, e] + BwNot _ty -> app $ BS.idInvertAt BS.NoPos + + Cast fromTy toTy -> transCast fromTy toTy e + GetField (Struct _) _ f -> BS.CSelect e $ BS.mkId BS.NoPos $ + fromString $ lowercaseName $ accessorName f + GetField _ _ _ -> impossible "transOp1" "copilot-bluespec" + + -- BDPI-supported operations + Sqrt ty -> appFP ty "sqrt" + Exp ty -> appFP ty "exp" + Log ty -> appFP ty "log" + Acos ty -> appFP ty "acos" + Asin ty -> appFP ty "asin" + Atan ty -> appFP ty "atan" + Cos ty -> appFP ty "cos" + Sin ty -> appFP ty "sin" + Tan ty -> appFP ty "tan" + Acosh ty -> appFP ty "acosh" + Asinh ty -> appFP ty "asinh" + Atanh ty -> appFP ty "atanh" + Cosh ty -> appFP ty "cosh" + Sinh ty -> appFP ty "sinh" + Tanh ty -> appFP ty "tanh" + Ceiling ty -> appFP ty "ceiling" + Floor ty -> appFP ty "floor" + where + app :: BS.Id -> BS.CExpr + app i = BS.CApply (BS.CVar i) [e] + + appFP :: forall t. Type t -> String -> BS.CExpr + appFP ty funPrefix = app $ fpFunId ty funPrefix + +-- | Translates a Copilot binary operator and its arguments into a Bluespec +-- function. +transOp2 :: Op2 a b c -> BS.CExpr -> BS.CExpr -> BS.CExpr +transOp2 op e1 e2 = + case op of + And -> app BS.idAnd + Or -> app $ BS.idOrAt BS.NoPos + Add _ty -> app BS.idPlus + Sub _ty -> app BS.idMinus + Mul _ty -> app $ BS.idStarAt BS.NoPos + Mod _ty -> app $ BS.idPercentAt BS.NoPos + Div _ty -> app $ BS.idSlashAt BS.NoPos + Fdiv _ty -> app $ BS.idSlashAt BS.NoPos + Eq _ -> app BS.idEqual + Ne _ -> app BS.idNotEqual + Le ty -> transLe ty e1 e2 + Ge ty -> transGe ty e1 e2 + Lt ty -> transLt ty e1 e2 + Gt ty -> transGt ty e1 e2 + BwAnd _ -> app $ BS.idBitAndAt BS.NoPos + BwOr _ -> app $ BS.idBitOrAt BS.NoPos + BwXor _ -> app $ BS.idCaretAt BS.NoPos + BwShiftL _ _ -> app $ BS.idLshAt BS.NoPos + BwShiftR _ _ -> app $ BS.idRshAt BS.NoPos + Index _ -> cIndexVector e1 e2 + UpdateField (Struct _) _ f -> + let field :: BS.FString + field = fromString $ lowercaseName $ accessorName f in + BS.CStructUpd e1 [(BS.mkId BS.NoPos field, e2)] + UpdateField _ _ _ -> impossible "transOp2" "copilot-bluespec" + + -- BDPI-supported operations + Pow ty -> appFP ty "pow" + Logb ty -> appFP ty "logb" + Atan2 ty -> appFP ty "atan2" + where + app :: BS.Id -> BS.CExpr + app i = BS.CApply (BS.CVar i) [e1, e2] + + appFP :: forall t. Type t -> String -> BS.CExpr + appFP ty funPrefix = app $ fpFunId ty funPrefix + +-- | Translates a Copilot ternary operator and its arguments into a Bluespec +-- function. +transOp3 :: Op3 a b c d -> BS.CExpr -> BS.CExpr -> BS.CExpr -> BS.CExpr +transOp3 op e1 e2 e3 = + case op of + Mux _ -> BS.Cif BS.NoPos e1 e2 e3 + UpdateArray _ -> cUpdateVector e1 e2 e3 + +-- | Translate @'Sign' e@ in Copilot Core into a Bluespec expression. +-- +-- @signum e@ is translated as: +-- +-- @ +-- if e > 0 then 1 else (if e < 0 then negate 1 else e) +-- @ +-- +-- That is: +-- +-- 1. If @e@ is positive, return @1@. +-- +-- 2. If @e@ is negative, return @-1@. +-- +-- 3. Otherwise, return @e@. This handles the case where @e@ is @0@ when the +-- type is an integral type. If the type is a floating-point type, it also +-- handles the cases where @e@ is @-0@ or @NaN@. +-- +-- This implementation is modeled after how GHC implements 'signum' +-- . +transSign :: Type a -> BS.CExpr -> BS.CExpr +transSign ty e = positiveCase $ negativeCase e + where + -- If @e@ is positive, return @1@, otherwise fall back to the argument. + -- + -- Produces the following code, where @@ is the argument to this + -- function: + -- @ + -- if e > 0 then 1 else + -- @ + positiveCase :: BS.CExpr -- ^ Value returned if @e@ is not positive. + -> BS.CExpr + positiveCase = + BS.Cif BS.NoPos (transGt ty e (constNumTy ty 0)) (constNumTy ty 1) + + -- If @e@ is negative, return @1@, otherwise fall back to the argument. + -- + -- Produces the following code, where @@ is the argument to this + -- function: + -- @ + -- if e < 0 then negate 1 else + -- @ + negativeCase :: BS.CExpr -- ^ Value returned if @e@ is not negative. + -> BS.CExpr + negativeCase = + BS.Cif BS.NoPos (transLt ty e (constNumTy ty 0)) (constNumTy ty (-1)) + +-- | Translate a Copilot @x < y@ expression into Bluespec. We will generate +-- different code depending on whether the arguments have a floating-point type +-- or not. +transLt :: Type a + -- ^ The type of the arguments. + -> BS.CExpr -> BS.CExpr -> BS.CExpr +transLt ty e1 e2 + | typeIsFloating ty + = transLtOrGtFP (BS.mkId BS.NoPos "LT") e1 e2 + | otherwise + = BS.CApply (BS.CVar (BS.idLtAt BS.NoPos)) [e1, e2] + +-- | Translate a Copilot @x > y@ expression into Bluespec. We will generate +-- different code depending on whether the arguments have a floating-point type +-- or not. +transGt :: Type a + -- ^ The type of the arguments. + -> BS.CExpr -> BS.CExpr -> BS.CExpr +transGt ty e1 e2 + | typeIsFloating ty + = transLtOrGtFP (BS.mkId BS.NoPos "GT") e1 e2 + | otherwise + = BS.CApply (BS.CVar (BS.idGtAt BS.NoPos)) [e1, e2] + +-- | Translate a Copilot @x <= y@ expression into Bluespec. We will generate +-- different code depending on whether the arguments have a floating-point type +-- or not. +transLe :: Type a + -- ^ The type of the arguments. + -> BS.CExpr -> BS.CExpr -> BS.CExpr +transLe ty e1 e2 + | typeIsFloating ty + = transLeOrGeFP (BS.mkId BS.NoPos "LT") e1 e2 + | otherwise + = BS.CApply (BS.CVar (BS.idLtEqAt BS.NoPos)) [e1, e2] + +-- | Translate a Copilot @x >= y@ expression into Bluespec. We will generate +-- different code depending on whether the arguments have a floating-point type +-- or not. +transGe :: Type a + -- ^ The type of the arguments. + -> BS.CExpr -> BS.CExpr -> BS.CExpr +transGe ty e1 e2 + | typeIsFloating ty + = transLeOrGeFP (BS.mkId BS.NoPos "GT") e1 e2 + | otherwise + = BS.CApply (BS.CVar (BS.idGtEqAt BS.NoPos)) [e1, e2] + +-- | Translate a Copilot floating-point comparison involving @<@ or @>@ into a +-- Bluespec expression. Specifically, @x < y@ is translated to: +-- +-- @ +-- compareFP x y == LT +-- @ +-- +-- @x > y@ is translated similarly, except that @GT@ is used instead of @LT@. +-- +-- See the comments on 'compareFPExpr' for why we translate floating-point +-- comparison operators this way. +transLtOrGtFP :: BS.Id + -- ^ A @Disorder@ label, which we check against the result of + -- calling @compareFP@. This should be either @LT@ or @GT@. + -> BS.CExpr -> BS.CExpr -> BS.CExpr +transLtOrGtFP disorderLabel e1 e2 = + BS.CApply + (BS.CVar BS.idEqual) + [compareFPExpr e1 e2, BS.CCon disorderLabel []] + +-- | Translate a Copilot floating-point comparison involving @<=@ or @>=@ into +-- a Bluespec expression. Specifically, @x <= y@ is translated to: +-- +-- @ +-- let _c = compareFP x y +-- in (_c == LT) || (_c == EQ) +-- @ +-- +-- @x >= y@ is translated similarly, except that @GT@ is used instead of @LT@. +-- +-- See the comments on 'compareFPExpr' for why we translate floating-point +-- comparison operators this way. +transLeOrGeFP :: BS.Id + -- ^ A @Disorder@ label, which we check against the result of + -- calling @compareFP@. This should be either @LT@ or @GT@. + -> BS.CExpr -> BS.CExpr -> BS.CExpr +transLeOrGeFP disorderLabel e1 e2 = + BS.Cletrec + [BS.CLValue c [BS.CClause [] [] (compareFPExpr e1 e2)] []] + (BS.CApply + (BS.CVar (BS.idOrAt BS.NoPos)) + [ BS.CApply + (BS.CVar BS.idEqual) + [BS.CVar c, BS.CCon disorderLabel []] + , BS.CApply + (BS.CVar BS.idEqual) + [BS.CVar c, BS.CCon (BS.mkId BS.NoPos "EQ") []] + ]) + where + c = BS.mkId BS.NoPos "_c" + +-- | Generate an expression of the form @compareFP x y@. This is used to power +-- the translations of the Copilot @<@, @<=@, @>@, and @>=@ floating-point +-- operators to Bluespec. +-- +-- Translating these operators using @compareFP@ is a somewhat curious design +-- choice, given that Bluespec already defines its own versions of these +-- operators. Unfortunately, we cannot directly use the Bluespec versions of +-- these operators, as they are defined in such a way that they will call +-- @error@ when one of the arguments is a NaN value. This would pose two +-- problems: +-- +-- 1. This would differ from the semantics of Copilot, where @x < y@ will return +-- @False@ (instead of erroring) when one of the arguments is NaN. (Similarly +-- for the other floating-point comparison operators.) +-- +-- 2. Moreover, if you have a Bluespec program that calls @x < y@, where the +-- value of @x@ or @y@ is derived from a register, then @bsc@ will always +-- fail to compile the code. This is because Bluespec must generate hardware +-- for all possible code paths in @<@, and because one of the code paths +-- calls @error@, this will cause compilation to result in an error. (See +-- https://github.com/B-Lang-org/bsc/discussions/711#discussioncomment-10003586 +-- for a more detailed explanation.) +-- +-- As such, we avoid using Bluespec's comparison operators and instead translate +-- Copilot's comparison operators to expressions derived from @compareFP@. +-- Unlike Bluespec's other comparison operators, calling @compareFP@ will never +-- result in an error. +compareFPExpr :: BS.CExpr -> BS.CExpr -> BS.CExpr +compareFPExpr e1 e2 = + BS.CApply + (BS.CVar (BS.mkId BS.NoPos "compareFP")) + [e1, e2] + +-- | Bluespec does not have a general-purpose casting operation, so we must +-- handle casts on a case-by-case basis. +transCast :: Type a -> Type b -> BS.CExpr -> BS.CExpr +transCast fromTy toTy = + case (fromTy, toTy) of + ----- + -- "safe" casts that cannot lose information + ----- + + (Bool, Bool) -> id + (Bool, Word8) -> upcastBool + (Bool, Word16) -> upcastBool + (Bool, Word32) -> upcastBool + (Bool, Word64) -> upcastBool + (Bool, Int8) -> upcastBool + (Bool, Int16) -> upcastBool + (Bool, Int32) -> upcastBool + (Bool, Int64) -> upcastBool + + (Int8, Int8) -> id + (Int8, Int16) -> upcast + (Int8, Int32) -> upcast + (Int8, Int64) -> upcast + (Int16, Int16) -> id + (Int16, Int32) -> upcast + (Int16, Int64) -> upcast + (Int32, Int32) -> id + (Int32, Int64) -> upcast + (Int64, Int64) -> id + + (Word8, Int16) -> unpackPackUpcast Word16 + (Word8, Int32) -> unpackPackUpcast Word32 + (Word8, Int64) -> unpackPackUpcast Word64 + (Word8, Word8) -> id + (Word8, Word16) -> upcast + (Word8, Word32) -> upcast + (Word8, Word64) -> upcast + (Word16, Int32) -> unpackPackUpcast Word32 + (Word16, Int64) -> unpackPackUpcast Word64 + (Word16, Word16) -> id + (Word16, Word32) -> upcast + (Word16, Word64) -> upcast + (Word32, Int64) -> unpackPackUpcast Word64 + (Word32, Word32) -> id + (Word32, Word64) -> upcast + (Word64, Word64) -> id + + ----- + -- "unsafe" casts, which may lose information + ----- + + -- unsigned truncations + (Word64, Word32) -> downcast + (Word64, Word16) -> downcast + (Word64, Word8) -> downcast + (Word32, Word16) -> downcast + (Word32, Word8) -> downcast + (Word16, Word8) -> downcast + + -- signed truncations + (Int64, Int32) -> downcast + (Int64, Int16) -> downcast + (Int64, Int8) -> downcast + (Int32, Int16) -> downcast + (Int32, Int8) -> downcast + (Int16, Int8) -> downcast + + -- signed integer to float + (Int64, Float) -> castIntegralToFloatingPoint + (Int32, Float) -> castIntegralToFloatingPoint + (Int16, Float) -> castIntegralToFloatingPoint + (Int8, Float) -> castIntegralToFloatingPoint + + -- unsigned integer to float + (Word64, Float) -> castIntegralToFloatingPoint + (Word32, Float) -> castIntegralToFloatingPoint + (Word16, Float) -> castIntegralToFloatingPoint + (Word8, Float) -> castIntegralToFloatingPoint + + -- signed integer to double + (Int64, Double) -> castIntegralToFloatingPoint + (Int32, Double) -> castIntegralToFloatingPoint + (Int16, Double) -> castIntegralToFloatingPoint + (Int8, Double) -> castIntegralToFloatingPoint + + -- unsigned integer to double + (Word64, Double) -> castIntegralToFloatingPoint + (Word32, Double) -> castIntegralToFloatingPoint + (Word16, Double) -> castIntegralToFloatingPoint + (Word8, Double) -> castIntegralToFloatingPoint + + -- unsigned to signed conversion + (Word64, Int64) -> unpackPack + (Word32, Int32) -> unpackPack + (Word16, Int16) -> unpackPack + (Word8, Int8) -> unpackPack + + -- signed to unsigned conversion + (Int64, Word64) -> unpackPack + (Int32, Word32) -> unpackPack + (Int16, Word16) -> unpackPack + (Int8, Word8) -> unpackPack + + _ -> impossible "transCast" "copilot-bluespec" + where + -- unpackPack :: (Bits fromTy n, Bits toTy n) => fromTy -> toTy + -- unpackPack e = (unpack (pack e)) :: toTy + -- + -- The most basic cast. Used when fromTy and toTy are both integral types + -- with the same number of bits. + unpackPack :: BS.CExpr -> BS.CExpr + unpackPack e = withTypeAnnotation toTy $ + BS.CApply + (BS.CVar BS.idUnpack) + [BS.CApply (BS.CVar BS.idPack) [e]] + + -- upcastBool :: (Add k 1 n, Bits toTy n) => Bool -> toTy + -- upcastBool b = (unpack (extend (pack b))) :: toTy + -- + -- Cast a Bool to a `Bits 1` value, extend it to `Bits n`, and then + -- convert it back to an integral type. + upcastBool :: BS.CExpr -> BS.CExpr + upcastBool e = withTypeAnnotation toTy $ + BS.CApply + (BS.CVar BS.idUnpack) + [BS.CApply extendExpr [BS.CApply (BS.CVar BS.idPack) [e]]] + + -- upcast :: (BitExtend m n x) => x m -> x n + -- upcast e = (extend e) :: ty + -- + -- Convert a narrower integral type to a wider integral type (e.g., + -- `UInt 8` to `UInt 64` or `Int 8` to `Int 64`). Note that the `extend` + -- operation is smart enough to choose between sign-extension and + -- zero-extension depending on whether `x m` (i.e., fromTy) is a signed + -- or unsigned type, respectively. + upcast :: BS.CExpr -> BS.CExpr + upcast e = withTypeAnnotation toTy $ BS.CApply extendExpr [e] + + -- downcast :: (BitExtend m n x) => x n -> x m + -- downcast e = (truncate e) :: ty + -- + -- Convert a wider integral type to a narrow integral type (e.g., + -- `UInt 64` to `UInt 8` or `Int 64` to `Int 8`) by truncating the most + -- significant bits. + downcast :: BS.CExpr -> BS.CExpr + downcast e = withTypeAnnotation toTy $ BS.CApply truncateExpr [e] + + -- Apply upcast followed by unpackPack. This requires supplying the type to + -- upcast to for type disambiguation purposes. + unpackPackUpcast :: Type a -> BS.CExpr -> BS.CExpr + unpackPackUpcast upcastTy e = unpackPack $ + withTypeAnnotation upcastTy $ BS.CApply extendExpr [e] + + -- castIntegralToFloatingPoint :: (FixedFloatCVT fromTy toTy) => fromTy toTy + -- castIntegralToFloatingPoint e = + -- ((vFixedToFloat e (0 :: UInt 64) Rnd_Nearest_Even).fst) :: tfl + -- + -- While FloatingPoint does have a Bits instance, we don't want to convert + -- an integral type to a FloatingPoint type using the Bits class, as the + -- bit representation of an integral value differs quite a bit from the bit + -- representation of a FloatingPoint value. Instead, we use the + -- special-purpose FixedFloatCVT class for this task. + castIntegralToFloatingPoint :: BS.CExpr -> BS.CExpr + castIntegralToFloatingPoint e = + withTypeAnnotation toTy $ + BS.CSelect + (BS.CApply + (BS.CVar (BS.mkId BS.NoPos "vFixedToFloat")) + [ e + , constNumTy Word64 0 + , fpRM + ]) + BS.idPrimFst + + extendExpr = BS.CVar $ BS.mkId BS.NoPos "extend" + truncateExpr = BS.CVar $ BS.mkId BS.NoPos "truncate" + +-- | Transform a Copilot Core literal, based on its value and type, into a +-- Bluespec expression. +constTy :: Type a -> a -> BS.CExpr +constTy ty = + case ty of + -- The treatment of scalar types is relatively straightforward. Note that + -- Bool is an enum, so we must construct it using a CCon rather than with + -- a CLit. + Bool -> \v -> BS.CCon (if v then BS.idTrue else BS.idFalse) [] + Int8 -> constInt ty . toInteger + Int16 -> constInt ty . toInteger + Int32 -> constInt ty . toInteger + Int64 -> constInt ty . toInteger + Word8 -> constInt ty . toInteger + Word16 -> constInt ty . toInteger + Word32 -> constInt ty . toInteger + Word64 -> constInt ty . toInteger + Float -> constFP ty . nanSafeFloat2Double + Double -> constFP ty + + -- Translating a Copilot array literal to a Bluespec Vector is somewhat + -- involved. Given a Copilot array {x_0, ..., x_(n-1)}, the + -- corresponding Bluespec Vector will look something like: + -- + -- let arr = update (... (update newVector 0 x_0)) (n-1) x_(n-1) + -- + -- We use the `update` function instead of the := syntax (e.g., + -- { array_temp[0] := x; array_temp[1] := y; ...}) so that we can construct + -- a Vector in a pure context. + Array ty' -> constVector ty' . arrayElems + + -- Converting a Copilot struct { field_0 = x_0, ..., field_(n-1) = x_(n-1) } + -- to a Bluespec struct is quite straightforward, given Bluespec's struct + -- initialization syntax. + Struct s -> \v -> + BS.CStruct + (Just True) + (BS.mkId BS.NoPos $ fromString $ uppercaseName $ typeName s) + (map (\(Value ty'' field@(Field val)) -> + ( BS.mkId BS.NoPos $ fromString + $ lowercaseName + $ fieldName field + , constTy ty'' val + )) + (toValues v)) + where + -- Convert a Float to a Double. This function takes care to preserve + -- special floating-point values, such as negative zero, infinity, and NaN + -- values. + nanSafeFloat2Double :: Float -> Double + nanSafeFloat2Double x + -- float2Double does not preserve the payloads of NaN values, so we + -- include special cases for translating NaNs. + | isNaN x && isSignaling x = setPayloadSignaling payload + | isNaN x = setPayload payload + | otherwise = float2Double x + where + payload :: Double + payload = float2Double $ getPayload x + +-- | Transform a list of Copilot Core expressions of a given 'Type' into a +-- Bluespec @Vector@ expression. +constVector :: Type a -> [a] -> BS.CExpr +constVector ty = genVector (\_ -> constTy ty) + +-- | Transform a list of Copilot Core expressions into a Bluespec @Vector@ +-- expression. When invoking @genVector f es@, where @es@ has length @n@, the +-- resulting @Vector@ will consist of +-- @[f 0 (es !! 0), f 1 (es !! 1), ..., f (n-1) (es !! (n-1))]@. +genVector :: (Int -> a -> BS.CExpr) -> [a] -> BS.CExpr +genVector f vec = + snd $ + foldl' + (\(!i, !v) x -> + ( i+1 + , cUpdateVector + v + (cLit (BS.LInt (BS.ilDec (toInteger i)))) + (f i x) + )) + (0, BS.CVar (BS.mkId BS.NoPos "newVector")) + vec + +-- | Translate a literal number of type @ty@ into a Bluespec expression. +-- +-- PRE: The type of PRE is numeric (integer or floating-point), that +-- is, not boolean, struct or array. +constNumTy :: Type a -> Integer -> BS.CExpr +constNumTy ty = + case ty of + Float -> constFP ty . fromInteger + Double -> constFP ty . fromInteger + _ -> constInt ty + +-- | Translate a Copilot integer literal into a Bluespec expression. +constInt :: Type a -> Integer -> BS.CExpr +constInt ty i + -- Bluespec intentionally does not support negative literal syntax (e.g., + -- -42), so we must create negative integer literals using the `negate` + -- function. + | i >= 0 = withTypeAnnotation ty $ cLit $ BS.LInt $ BS.ilDec i + | otherwise = withTypeAnnotation ty $ + BS.CApply + (BS.CVar $ BS.idNegateAt BS.NoPos) + [cLit $ BS.LInt $ BS.ilDec $ negate i] + +-- | Translate a Copilot floating-point literal into a Bluespec expression. +constFP :: Type ty -> Double -> BS.CExpr +constFP ty d + -- Bluespec internally represents all IEEE floating-point values as structs + -- so special symbols have to be called for constructing special values, + -- e.g. NaN, inf, and -0.0. See + -- https://github.com/B-Lang-org/bsc/blob/main/src/Libraries/Base3-Math/FloatingPoint.bsv#L441 + | isInfinite d = BS.CApply + (BS.CVar $ BS.mkId BS.NoPos "infinity") + [ if d < 0 + then BS.CCon BS.idTrue [] + else BS.CCon BS.idFalse [] + ] + + | isNaN d = let + cexpr = BS.CHasType + ( BS.CLit $ BS.CLiteral BS.NoPos $ BS.LInt $ + BS.IntLit Nothing 10 cval + ) + ( BS.CQType [] $ BS.TCon $ + BS.TyCon + (BS.mkId BS.NoPos ctype) + Nothing + BS.TIabstract + ) + cval = case ty of + Float -> fromIntegral $ + castFloatToWord32 $ uncastDoubleNaNToFloat d + Double -> fromIntegral $ + castDoubleToWord64 d + _ -> impossible "constFP" "copilot-bluespec" + ctype = case ty of + Float -> "Bit 32" + Double -> "Bit 64" + _ -> impossible "constFP" "copilot-bluespec" + in BS.CApply (BS.CVar $ BS.mkId BS.NoPos "unpack") [cexpr] + | d == 0 = BS.CApply + (BS.CVar $ BS.mkId BS.NoPos "zero") + [ if isNegativeZero d + then BS.CCon BS.idTrue [] + else BS.CCon BS.idFalse [] + ] + | d > 0 = withTypeAnnotation ty $ cLit $ BS.LReal d + -- Bluespec intentionally does not support negative literal syntax (e.g., + -- -42.5), so we must create negative floating-point literals using the + -- `negate` function. + | otherwise = withTypeAnnotation ty $ + BS.CApply + (BS.CVar $ BS.idNegateAt BS.NoPos) + [cLit $ BS.LReal $ negate d] + +-- Because NaNs are specially placed as bit-representations by `constfp` and `constfp` requires Doubles as inputs, +-- we need to convert NaN doubles safely into NaN floats. GHC Double2Float does not preserve signal nor payload +-- internals of NaNs so in this case we need a special conversion. +uncastDoubleNaNToFloat :: Double -> Float +uncastDoubleNaNToFloat nan = if (isSignaling nan) + then (setPayloadSignaling payload) + else (setPayload payload) + where + payload = double2Float $ getPayload nan + +-- | Create a Bluespec expression consisting of a literal. +cLit :: BS.Literal -> BS.CExpr +cLit = BS.CLit . BS.CLiteral BS.NoPos + +-- | Create a Bluespec expression that indexes into a @Vector@. +cIndexVector :: BS.CExpr -> BS.CExpr -> BS.CExpr +cIndexVector vec idx = + BS.CApply (BS.CVar (BS.mkId BS.NoPos "select")) [vec, idx] + +-- | Create a Bluespec expression that updates a @Vector@ element at a +-- particular index. +cUpdateVector :: BS.CExpr -> BS.CExpr -> BS.CExpr -> BS.CExpr +cUpdateVector vec idx newElem = + BS.CApply + (BS.CVar (BS.mkId BS.NoPos "update")) + [vec, idx, newElem] + +-- | Create a Bluespec identifier for a floating-point function that Bluespec +-- imports using BDPI. +fpFunId :: Type a -> String -> BS.Id +fpFunId ty funPrefix = + BS.mkId BS.NoPos $ fromString $ "bs_fp_" ++ funName + where + funName :: String + funName = + case ty of + Float -> funPrefix ++ "f" + Double -> funPrefix + _ -> impossible "fpFunId" "copilot-bluespec" + +-- | Explicitly annotate an expression with a type signature. This is necessary +-- to prevent expressions from having ambiguous types in certain situations. +withTypeAnnotation :: Type a -> BS.CExpr -> BS.CExpr +withTypeAnnotation ty e = e `BS.CHasType` BS.CQType [] (transType ty) + +-- | True if the type given is a floating point number. +typeIsFloating :: Type a -> Bool +typeIsFloating Float = True +typeIsFloating Double = True +typeIsFloating _ = False + +-- | We assume round-near-even throughout, but this variable can be changed if +-- needed. This matches the behavior of @fpRM@ in @copilot-theorem@'s +-- @Copilot.Theorem.What4.Translate@ module. +fpRM :: BS.CExpr +fpRM = BS.CCon (BS.mkId BS.NoPos "Rnd_Nearest_Even") [] diff --git a/copilot-bluespec/src/Copilot/Compile/Bluespec/External.hs b/copilot-bluespec/src/Copilot/Compile/Bluespec/External.hs new file mode 100644 index 000000000..6d42105bb --- /dev/null +++ b/copilot-bluespec/src/Copilot/Compile/Bluespec/External.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE ExistentialQuantification #-} + +-- | Represent information about externs needed in the generation of Bluespec +-- code for stream declarations and triggers. +module Copilot.Compile.Bluespec.External + ( External(..) + , gatherExts + ) where + +-- External imports +import Data.List (unionBy) + +-- Internal imports: Copilot +import Copilot.Core ( Expr (..), Stream (..), Trigger (..), Type, UExpr (..) ) + +-- | Representation of external variables. +data External = forall a. External + { extName :: String + , extType :: Type a + } + +-- | Collect all external variables from the streams and triggers. +-- +-- Although Copilot specifications can contain also properties and theorems, +-- the Bluespec backend currently only generates code for streams and triggers. +gatherExts :: [Stream] -> [Trigger] -> [External] +gatherExts streams triggers = streamsExts `extUnion` triggersExts + where + streamsExts = foldr (extUnion . streamExts) mempty streams + triggersExts = foldr (extUnion . triggerExts) mempty triggers + + streamExts :: Stream -> [External] + streamExts (Stream _ _ expr _) = exprExts expr + + triggerExts :: Trigger -> [External] + triggerExts (Trigger _ guard args) = guardExts `extUnion` argExts + where + guardExts = exprExts guard + argExts = concatMap uExprExts args + + uExprExts :: UExpr -> [External] + uExprExts (UExpr _ expr) = exprExts expr + + exprExts :: Expr a -> [External] + exprExts (Local _ _ _ e1 e2) = exprExts e1 `extUnion` exprExts e2 + exprExts (ExternVar ty name _) = [External name ty] + exprExts (Op1 _ e) = exprExts e + exprExts (Op2 _ e1 e2) = exprExts e1 `extUnion` exprExts e2 + exprExts (Op3 _ e1 e2 e3) = exprExts e1 `extUnion` exprExts e2 + `extUnion` exprExts e3 + exprExts (Label _ _ e) = exprExts e + exprExts _ = [] + + -- | Union over lists of External, we solely base the equality on the + -- extName's. + extUnion :: [External] -> [External] -> [External] + extUnion = unionBy (\a b -> extName a == extName b) diff --git a/copilot-bluespec/src/Copilot/Compile/Bluespec/FloatingPoint.hs b/copilot-bluespec/src/Copilot/Compile/Bluespec/FloatingPoint.hs new file mode 100644 index 000000000..a1683f1c1 --- /dev/null +++ b/copilot-bluespec/src/Copilot/Compile/Bluespec/FloatingPoint.hs @@ -0,0 +1,171 @@ +-- | Generate definitions that allow importing C implementations of +-- floating-point operations into Bluespec. +module Copilot.Compile.Bluespec.FloatingPoint + ( copilotBluespecFloatingPointBSV + , copilotBluespecFloatingPointC + ) where + +-- | The contents of the generated @BluespecFP.bsv@ file, which contains the +-- @import \"BDPI\"@ declarations needed to use imported C functions in +-- Bluespec. +copilotBluespecFloatingPointBSV :: String +copilotBluespecFloatingPointBSV = + unlines $ + [ "import FloatingPoint::*;" + , "" + ] ++ + concatMap + (\funName -> [importOp1 Float funName, importOp1 Double funName]) + unaryFloatOpNames ++ + concatMap + (\funName -> [importOp2 Float funName, importOp2 Double funName]) + [ "pow" + , "atan2" + , "logb" + ] + where + importOp1 :: FloatType -> String -> String + importOp1 ft funName = + "import \"BDPI\" function " ++ floatTypeName ft ++ " " ++ funNamePrefix + ++ funName ++ floatTypeSuffix ft ++ " (" ++ floatTypeName ft ++ " x);" + + importOp2 :: FloatType -> String -> String + importOp2 ft funName = + "import \"BDPI\" function " ++ floatTypeName ft ++ " " ++ funNamePrefix + ++ funName ++ floatTypeSuffix ft ++ " (" ++ floatTypeName ft ++ " x, " + ++ floatTypeName ft ++ " y);" + + floatTypeName :: FloatType -> String + floatTypeName Float = "Float" + floatTypeName Double = "Double" + +-- | The contents of the generated @bs_fp.c@ file, which contains the C wrapper +-- functions that Bluespec imports. +copilotBluespecFloatingPointC :: String +copilotBluespecFloatingPointC = + unlines $ + [ "#include " + , "" + , defineUnionType Float + , defineUnionType Double + ] ++ + concatMap + (\funName -> [defineOp1 Float funName, defineOp1 Double funName]) + unaryFloatOpNames ++ + concatMap + (\funName -> [defineOp2 Float funName, defineOp2 Double funName]) + [ "pow" + , "atan2" + ] ++ + -- There is no direct C counterpart to the `logb` function, so we implement + -- it in terms of `log`. + map + (\ft -> + defineOp2Skeleton ft "logb" $ + \_cFunName x y -> "log" ++ floatTypeSuffix ft ++ "(" ++ y ++ ") / log" + ++ floatTypeSuffix ft ++ "( " ++ x ++ ")") + [Float, Double] + where + defineUnionType :: FloatType -> String + defineUnionType ft = + unlines + [ "union " ++ unionTypeName ft ++ " {" + , " " ++ integerTypeName ft ++ " i;" + , " " ++ floatTypeName ft ++ " f;" + , "};" + ] + + defineOp1Skeleton :: + FloatType -> String -> (String -> String -> String) -> String + defineOp1Skeleton ft funName mkFloatOp = + let cFunName = funName ++ floatTypeSuffix ft in + unlines + [ integerTypeName ft ++ " " + ++ funNamePrefix ++ cFunName + ++ "(" ++ integerTypeName ft ++ " x) {" + , " union " ++ unionTypeName ft ++ " x_u;" + , " union " ++ unionTypeName ft ++ " r_u;" + , " x_u.i = x;" + , " r_u.f = " ++ mkFloatOp cFunName "x_u.f" ++ ";" + , " return r_u.i;" + , "}" + ] + + defineOp1 :: FloatType -> String -> String + defineOp1 ft funName = + defineOp1Skeleton ft funName $ + \cFunName x -> cFunName ++ "(" ++ x ++ ")" + + defineOp2Skeleton :: + FloatType -> String -> (String -> String -> String -> String) -> String + defineOp2Skeleton ft funName mkFloatOp = + let cFunName = funName ++ floatTypeSuffix ft in + unlines + [ integerTypeName ft ++ " " + ++ funNamePrefix ++ cFunName + ++ "(" ++ integerTypeName ft ++ " x, " ++ integerTypeName ft + ++ " y) {" + , " union " ++ unionTypeName ft ++ " x_u;" + , " union " ++ unionTypeName ft ++ " y_u;" + , " union " ++ unionTypeName ft ++ " r_u;" + , " x_u.i = x;" + , " y_u.i = y;" + , " r_u.f = " ++ mkFloatOp cFunName "x_u.f" "y_u.f" ++ ";" + , " return r_u.i;" + , "}" + ] + + defineOp2 :: FloatType -> String -> String + defineOp2 ft funName = + defineOp2Skeleton ft funName $ + \cFunName x y -> cFunName ++ "(" ++ x ++ ", " ++ y ++ ")" + + integerTypeName :: FloatType -> String + integerTypeName Float = "unsigned int" + integerTypeName Double = "unsigned long long" + + floatTypeName :: FloatType -> String + floatTypeName Float = "float" + floatTypeName Double = "double" + + unionTypeName :: FloatType -> String + unionTypeName Float = "ui_float" + unionTypeName Double = "ull_double" + +-- * Internals + +-- | Are we generating a function for a @float@ or @double@ operation? +data FloatType + = Float + | Double + +-- | The suffix to use in the generated function. +floatTypeSuffix :: FloatType -> String +floatTypeSuffix Float = "f" +floatTypeSuffix Double = "" + +-- | The prefix to use in the generated function. +funNamePrefix :: String +funNamePrefix = "bs_fp_" + +-- | The names of unary floating-point operations. +unaryFloatOpNames :: [String] +unaryFloatOpNames = + [ "exp" + , "log" + , "acos" + , "asin" + , "atan" + , "cos" + , "sin" + , "tan" + , "acosh" + , "asinh" + , "atanh" + , "cosh" + , "sinh" + , "tanh" + , "ceil" + , "floor" + , "sqrt" + ] diff --git a/copilot-bluespec/src/Copilot/Compile/Bluespec/Name.hs b/copilot-bluespec/src/Copilot/Compile/Bluespec/Name.hs new file mode 100644 index 000000000..ebb87f298 --- /dev/null +++ b/copilot-bluespec/src/Copilot/Compile/Bluespec/Name.hs @@ -0,0 +1,115 @@ +-- | Naming of variables and functions in Bluespec. +module Copilot.Compile.Bluespec.Name + ( actionName + , argNames + , generatorName + , guardName + , ifcArgName + , ifcRulesArgName + , indexName + , lowercaseName + , specIfcName + , specIfcPkgName + , specIfcRulesName + , specTypesPkgName + , streamAccessorName + , streamElemName + , streamName + , uppercaseName + , wireName + ) where + +-- External imports +import Data.Char (isLower, isUpper) + +-- External imports: Copilot +import Copilot.Core (Id) + +-- | Turn a specification name into the name of its module interface. +specIfcName :: String -> String +specIfcName prefix = uppercaseName (specIfcPkgName prefix) + +-- | Turn a specification name into the name of the package that declares its +-- module interface. Note that 'specIfcPkgName' is not necessarily the same name +-- as 'specIfcName', as the former does not need to begin with an uppercase +-- letter, but the latter does. +specIfcPkgName :: String -> String +specIfcPkgName prefix = prefix ++ "Ifc" + +-- | Turn a specification name into the name of its rules-specific interface. +specIfcRulesName :: String -> String +specIfcRulesName prefix = uppercaseName (prefix ++ "RulesIfc") + +-- | Turn a specification name into the name of the package that declares its +-- struct types. +specTypesPkgName :: String -> String +specTypesPkgName prefix = prefix ++ "Types" + +-- | Turn a stream id into a stream element name. +streamElemName :: Id -> Int -> String +streamElemName sId n = streamName sId ++ "_" ++ show n + +-- | The name of a variable of type @Ifc@. +ifcArgName :: String +ifcArgName = "ifc" + +-- | The name of a variable of type @RulesIfc@. +ifcRulesArgName :: String +ifcRulesArgName = "ifcRules" + +-- | Create a Bluespec name that must start with an uppercase letter (e.g., a +-- struct or interface name). If the supplied name already begins with an +-- uppercase letter, this function returns the name unchanged. Otherwise, this +-- function prepends a @BS_@ prefix (short for \"Bluespec\") at the front. +uppercaseName :: String -> String +uppercaseName [] = [] +uppercaseName n@(c:_) + | isUpper c = n + | otherwise = "BS_" ++ n + +-- | Create a Bluespec name that must start with a lowercase letter (e.g., a +-- function or method name). If the supplied name already begins with a +-- lowercase letter, this function returns the name unchanged. Otherwise, this +-- function prepends a @bs_@ prefix (short for \"Bluespec\") at the front. +lowercaseName :: String -> String +lowercaseName [] = [] +lowercaseName n@(c:_) + | isLower c = n + | otherwise = "bs_" ++ n + +-- | Turn a stream id into a suitable Bluespec variable name. +streamName :: Id -> String +streamName sId = "s" ++ show sId + +-- | Turn a stream id into the global varname for indices. +indexName :: Id -> String +indexName sId = streamName sId ++ "_idx" + +-- | Turn a stream id into the name of its accessor function +streamAccessorName :: Id -> String +streamAccessorName sId = streamName sId ++ "_get" + +-- | Turn stream id into name of its generator function. +generatorName :: Id -> String +generatorName sId = streamName sId ++ "_gen" + +-- | Turn the name of a trigger into a guard generator. +guardName :: String -> String +guardName name = lowercaseName name ++ "_guard" + +-- | Turn the name of a trigger of external stream into the name of a method +-- that performs a Bluespec @Action@. +actionName :: String -> String +actionName name = lowercaseName name ++ "_action" + +-- | Turn the name of an external stream into a Bluespec @Wire@. +wireName :: String -> String +wireName name = lowercaseName name ++ "_wire" + +-- | Turn a trigger name into a an trigger argument name. +argName :: String -> Int -> String +argName name n = lowercaseName name ++ "_arg" ++ show n + +-- | Enumerate all argument names based on trigger name. +argNames :: String -> [String] +argNames base = map (argName base) [0..] diff --git a/copilot-bluespec/src/Copilot/Compile/Bluespec/Representation.hs b/copilot-bluespec/src/Copilot/Compile/Bluespec/Representation.hs new file mode 100644 index 000000000..d5bc44212 --- /dev/null +++ b/copilot-bluespec/src/Copilot/Compile/Bluespec/Representation.hs @@ -0,0 +1,22 @@ +-- | Bluespec backend specific versions of selected `Copilot.Core` datatypes. +module Copilot.Compile.Bluespec.Representation + ( UniqueTrigger (..) + , UniqueTriggerId + , mkUniqueTriggers + ) + where + +import Copilot.Core ( Trigger (..) ) + +-- | Internal unique name for a trigger. +type UniqueTriggerId = String + +-- | A `Copilot.Core.Trigger` with an unique name. +data UniqueTrigger = UniqueTrigger UniqueTriggerId Trigger + +-- | Given a list of triggers, make their names unique. +mkUniqueTriggers :: [Trigger] -> [UniqueTrigger] +mkUniqueTriggers ts = zipWith mkUnique ts [0..] + where + mkUnique :: Trigger -> Integer -> UniqueTrigger + mkUnique t@(Trigger name _ _) n = UniqueTrigger (name ++ "_" ++ show n) t diff --git a/copilot-bluespec/src/Copilot/Compile/Bluespec/Settings.hs b/copilot-bluespec/src/Copilot/Compile/Bluespec/Settings.hs new file mode 100644 index 000000000..47247b605 --- /dev/null +++ b/copilot-bluespec/src/Copilot/Compile/Bluespec/Settings.hs @@ -0,0 +1,14 @@ +-- | Settings used by the code generator to customize the code. +module Copilot.Compile.Bluespec.Settings + ( BluespecSettings(..) + , mkDefaultBluespecSettings + ) where + +-- | Settings used to customize the code generated. +newtype BluespecSettings = BluespecSettings + { bluespecSettingsOutputDirectory :: FilePath + } + +-- | Default Bluespec settings. Output to the current directory. +mkDefaultBluespecSettings :: BluespecSettings +mkDefaultBluespecSettings = BluespecSettings "." diff --git a/copilot-bluespec/src/Copilot/Compile/Bluespec/Type.hs b/copilot-bluespec/src/Copilot/Compile/Bluespec/Type.hs new file mode 100644 index 000000000..967b695b1 --- /dev/null +++ b/copilot-bluespec/src/Copilot/Compile/Bluespec/Type.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Translate Copilot Core expressions and operators to Bluespec. +module Copilot.Compile.Bluespec.Type + ( transType + , tVector + ) where + +-- External imports +import Data.String (IsString (..)) +import qualified Language.Bluespec.Classic.AST as BS +import qualified Language.Bluespec.Classic.AST.Builtin.Ids as BS +import qualified Language.Bluespec.Classic.AST.Builtin.Types as BS + +-- Internal imports: Copilot +import Copilot.Core + +-- Internal imports +import Copilot.Compile.Bluespec.Name + +-- | Translate a Copilot type to a Bluespec type. +transType :: Type a -> BS.CType +transType ty = case ty of + Bool -> BS.tBool + Int8 -> BS.tInt `BS.TAp` BS.cTNum 8 BS.NoPos + Int16 -> BS.tInt `BS.TAp` BS.cTNum 16 BS.NoPos + Int32 -> BS.tInt `BS.TAp` BS.cTNum 32 BS.NoPos + Int64 -> BS.tInt `BS.TAp` BS.cTNum 64 BS.NoPos + Word8 -> BS.tUInt `BS.TAp` BS.cTNum 8 BS.NoPos + Word16 -> BS.tUInt `BS.TAp` BS.cTNum 16 BS.NoPos + Word32 -> BS.tUInt `BS.TAp` BS.cTNum 32 BS.NoPos + Word64 -> BS.tUInt `BS.TAp` BS.cTNum 64 BS.NoPos + + Float -> BS.TCon $ + BS.TyCon + { BS.tcon_name = BS.mkId BS.NoPos "Float" + , BS.tcon_kind = Just BS.KStar + , BS.tcon_sort = BS.TItype 0 $ tFloatingPoint `BS.TAp` + BS.cTNum 8 BS.NoPos `BS.TAp` + BS.cTNum 23 BS.NoPos + } + Double -> BS.TCon $ + BS.TyCon + { BS.tcon_name = BS.mkId BS.NoPos "Double" + , BS.tcon_kind = Just BS.KStar + , BS.tcon_sort = BS.TItype 0 $ tFloatingPoint `BS.TAp` + BS.cTNum 11 BS.NoPos `BS.TAp` + BS.cTNum 52 BS.NoPos + } + Array ty' -> tVector `BS.TAp` BS.cTNum len BS.NoPos `BS.TAp` transType ty' + where + len = toInteger $ typeLength ty + Struct s -> BS.TCon $ + BS.TyCon + { BS.tcon_name = BS.mkId BS.NoPos $ + fromString $ + uppercaseName $ + typeName s + , BS.tcon_kind = Just BS.KStar + , BS.tcon_sort = + BS.TIstruct BS.SStruct $ + map (\(Value _tu field) -> + BS.mkId BS.NoPos $ + fromString $ + lowercaseName $ + fieldName field) + (toValues s) + } + +-- | The @Vector@ Bluespec data type. +tVector :: BS.CType +tVector = BS.TCon $ + BS.TyCon + { BS.tcon_name = BS.idVector + , BS.tcon_kind = Just (BS.Kfun BS.KNum (BS.Kfun BS.KStar BS.KStar)) + , BS.tcon_sort = + BS.TIdata + { BS.tidata_cons = [BS.mkId BS.NoPos "V"] + , BS.tidata_enum = False + } + } + +-- | The @FloatingPoint@ Bluespec struct type. +tFloatingPoint :: BS.CType +tFloatingPoint = BS.TCon $ + BS.TyCon + { BS.tcon_name = BS.mkId BS.NoPos "FloatingPoint" + , BS.tcon_kind = Just (BS.Kfun BS.KNum (BS.Kfun BS.KNum BS.KStar)) + , BS.tcon_sort = + BS.TIstruct BS.SStruct [ BS.mkId BS.NoPos "sign" + , BS.mkId BS.NoPos "exp" + , BS.mkId BS.NoPos "sfd" + ] + } diff --git a/copilot-bluespec/tests/Main.hs b/copilot-bluespec/tests/Main.hs new file mode 100644 index 000000000..928da7de3 --- /dev/null +++ b/copilot-bluespec/tests/Main.hs @@ -0,0 +1,18 @@ +-- | Test copilot-bluespec. +module Main where + +-- External imports +import Test.Framework (Test, defaultMain) + +-- Internal library modules being tested +import qualified Test.Copilot.Compile.Bluespec + +-- | Run all @copilot-bluespec@ tests. +main :: IO () +main = defaultMain tests + +-- | All @copilot-bluespec@ tests. +tests :: [Test.Framework.Test] +tests = + [ Test.Copilot.Compile.Bluespec.tests + ] diff --git a/copilot-bluespec/tests/Test/Copilot/Compile/Bluespec.hs b/copilot-bluespec/tests/Test/Copilot/Compile/Bluespec.hs new file mode 100644 index 000000000..c6319fafa --- /dev/null +++ b/copilot-bluespec/tests/Test/Copilot/Compile/Bluespec.hs @@ -0,0 +1,1463 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-orphans #-} +-- | Test copilot-bluespec:Copilot.Compile.Bluespec. +module Test.Copilot.Compile.Bluespec + ( tests ) + where + +-- External imports +import Control.Arrow ((&&&)) +import Control.Exception (IOException, catch) +import Control.Monad (when) +import Data.AEq (AEq (..)) +import Data.Bits (Bits, complement) +import Data.Foldable (foldl') +import Data.List (intercalate, stripPrefix) +import Data.List.Extra (stripSuffix) +import Data.Type.Equality (testEquality) +import Data.Typeable (Proxy (..), (:~:) (Refl)) +import GHC.Float (castDoubleToWord64, + castFloatToWord32, + castWord32ToFloat, + castWord64ToDouble) +import GHC.TypeLits (KnownNat, natVal) +import Numeric.IEEE (infinity, nan) +import System.Directory (doesFileExist, + getTemporaryDirectory, + removeDirectoryRecursive, + setCurrentDirectory) +import System.IO (hPutStrLn, stderr) +import System.Posix.Temp (mkdtemp) +import System.Process (callProcess, readProcess) +import System.Random (Random) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.QuickCheck (Arbitrary, Gen, Property, + arbitrary, choose, elements, + forAll, forAllBlind, frequency, + getPositive, ioProperty, once, + oneof, vectorOf, withMaxSuccess, + (.&&.)) +import Test.QuickCheck.Gen (chooseAny, chooseBoundedIntegral) +import Text.ParserCombinators.ReadPrec (minPrec) + +-- External imports: Copilot +import Copilot.Core hiding (Property) + +-- External imports +import Copilot.Compile.Bluespec (bluespecSettingsOutputDirectory, compile, + compileWith, mkDefaultBluespecSettings) + +-- Internal imports +import Test.Copilot.Compile.Bluespec.External (External (extName), gatherExts) + +-- * Constants + +-- | All tests for copilot-bluespec:Copilot.Compile.Bluespec. +tests :: Test.Framework.Test +tests = + testGroup "Copilot.Compile.Bluespec" + [ testGroup "Unit tests" + [ testProperty "Compile specification" testCompile + , testProperty "Compile specification in custom dir" testCompileCustomDir + , testProperty "Run specification" testRun + , testProperty "Run and compare results" testRunCompare + ] + , testGroup "Regression tests" + [ test14 + , test15 + ] + ] + +-- * Individual tests + +-- | Test compiling a spec. +testCompile :: Property +testCompile = once $ ioProperty $ do + tmpDir <- getTemporaryDirectory + setCurrentDirectory tmpDir + + testDir <- mkdtemp "CopilotTest" + setCurrentDirectory testDir + + compile "CopilotTest" spec + r <- compileBluespec "CopilotTest" [] + + setCurrentDirectory tmpDir + removeDirectoryRecursive testDir + + return r + + where + + spec = Spec streams observers triggers properties + + streams = [] + observers = [] + triggers = [ Trigger function guard args ] + properties = [] + + function = "func" + + guard = Const Bool True + + args = [] + +-- | Test compiling a spec in a custom directory. +testCompileCustomDir :: Property +testCompileCustomDir = once $ ioProperty $ do + tmpDir <- getTemporaryDirectory + setCurrentDirectory tmpDir + + testDir <- mkdtemp "CopilotTest" + + compileWith (mkDefaultBluespecSettings + { bluespecSettingsOutputDirectory = testDir }) + "CopilotTest" + spec + + setCurrentDirectory testDir + r <- compileBluespec "CopilotTest" [] + + setCurrentDirectory tmpDir + removeDirectoryRecursive testDir + + return r + + where + + spec = Spec streams observers triggers properties + + streams = [] + observers = [] + triggers = [ Trigger function guard args ] + properties = [] + + function = "nop" + + guard = Const Bool True + + args = [] + +-- | Test compiling a spec and running the resulting program. +-- +-- The actual behavior is ignored. +testRun :: Property +testRun = once $ ioProperty $ do + tmpDir <- getTemporaryDirectory + setCurrentDirectory tmpDir + + testDir <- mkdtemp "CopilotTest" + setCurrentDirectory testDir + + let bluespecProgram = unlines + [ "package Top where" + , "" + , "import CopilotTest" + , "import CopilotTestTypes" + , "" + , "mkTop :: Module Empty" + , "mkTop =" + , " module" + , " copilotTestMod <- mkCopilotTest" + , " addCopilotTestRules copilotTestMod $" + , " interface CopilotTestRulesIfc" + , " nop_action = return ()" + ] + + writeFile "Top.bs" bluespecProgram + + compile "CopilotTest" spec + r <- compileBluespec "Top" ["-g", "mkTop"] + + -- Compile a main program + r2 <- compileExecutable "mkTop" + callProcess "./mkTop" ["-m", "2"] + + setCurrentDirectory tmpDir + removeDirectoryRecursive testDir + + return $ r && r2 + + where + + spec = Spec streams observers triggers properties + + streams = [] + observers = [] + triggers = [ Trigger function guard args ] + properties = [] + + function = "nop" + + guard = Const Bool True + + args = [] + +-- | Test running compiled spec and comparing the results to the +-- expectation. +testRunCompare :: Property +testRunCompare = + -- It takes a pretty long time to run these tests, so we set the maximum + -- number of successful tests to 5 instead of the default (100) for the sake + -- of making the test suite complete in a more reasonable amount of time. + withMaxSuccess 5 $ + testRunCompare1 (arbitraryOpIntegralBool :: Gen (TestCase1 Int8 Bool)) + .&&. testRunCompare1 (arbitraryOpIntegralBool :: Gen (TestCase1 Int16 Bool)) + .&&. testRunCompare1 (arbitraryOpIntegralBool :: Gen (TestCase1 Int32 Bool)) + .&&. testRunCompare1 (arbitraryOpIntegralBool :: Gen (TestCase1 Int64 Bool)) + .&&. testRunCompare1 (arbitraryOpIntegralBool :: Gen (TestCase1 Word8 Bool)) + .&&. testRunCompare1 (arbitraryOpIntegralBool :: Gen (TestCase1 Word16 Bool)) + .&&. testRunCompare1 (arbitraryOpIntegralBool :: Gen (TestCase1 Word32 Bool)) + .&&. testRunCompare1 (arbitraryOpIntegralBool :: Gen (TestCase1 Word64 Bool)) + .&&. testRunCompare1 (arbitraryOpFloatingBool :: Gen (TestCase1 Float Bool)) + .&&. testRunCompare1 (arbitraryOpFloatingBool :: Gen (TestCase1 Double Bool)) + .&&. testRunCompare1 (arbitraryOpStruct :: Gen (TestCase1 MyStruct Int8)) + .&&. testRunCompare2 (arbitraryOp2Struct :: Gen (TestCase2 MyStruct Int8 MyStruct)) + .&&. testRunCompare2 (arbitraryArray2Num :: Gen (TestCase2 (Array 2 Int8) Word32 Int8)) + .&&. testRunCompare2 (arbitraryArray2Num :: Gen (TestCase2 (Array 2 Int16) Word32 Int16)) + .&&. testRunCompare3 (arbitraryArray3Num :: Gen (TestCase3 (Array 2 Int16) Word32 Int16 (Array 2 Int16))) + +-- * Regression tests + +-- | Regression tests for +-- https://github.com/Copilot-Language/copilot-bluespec/issues/14 which ensure +-- that @copilot-bluespec@ generates code for the @signum@ function that adheres +-- to Copilot's @signum@ semantics. +test14 :: Test.Framework.Test +test14 = + testGroup "#14" + [ testProperty "`signum @Int8` generates correct Bluespec code" $ + mkRegressionTest1 (Sign Int8) (fmap signum) + [-2, -1, 0, 1, 2] + , testProperty "`signum @Double` generates correct Bluespec code" $ + mkRegressionTest1 (Sign Double) (fmap signum) + [-nan, -infinity, -2, -1, -0.0, 0, 1, 2, infinity, nan] + ] + +-- | Regression tests for +-- https://github.com/Copilot-Language/copilot-bluespec/issues/15 which ensure +-- that @copilot-bluespec@ generates valid code for comparison operators (('<'), +-- ('<='), ('>'), and ('>=')) that are capable of handling NaN values. +test15 :: Test.Framework.Test +test15 = + testGroup "#15" + [ testProperty "Generates valid (<) code for NaNs" $ + mkRegressionTest2 (Lt Double) (zipWith (<)) vals + , testProperty "Generates valid (<=) code for NaNs" $ + mkRegressionTest2 (Le Double) (zipWith (<=)) vals + , testProperty "Generates valid (>) code for NaNs" $ + mkRegressionTest2 (Gt Double) (zipWith (>)) vals + , testProperty "Generates valid (>=) code for NaNs" $ + mkRegressionTest2 (Ge Double) (zipWith (>=)) vals + ] + where + vals :: [(Double, Double)] + vals = [(0, nan), (nan, 0)] + +-- | Test the behavior of a unary operation (an @'Op1' a b@ value) against its +-- expected behavior (as a Haskell function of type @[a] -> [b]@) using the +-- supplied inputs (of type @[a]@). This function is intended to be used to +-- construct regression tests. +mkRegressionTest1 :: (Typed a, Typed b, + DisplayableInBluespec b, ReadableFromBluespec b, AEq b) + => Op1 a b + -> ([a] -> [b]) + -> [a] + -> Property +mkRegressionTest1 op haskellFun vals = + let spec = alwaysTriggerArg1 (UExpr t2 appliedOp) + appliedOp = Op1 op (ExternVar t1 varName Nothing) + + len = length vals + inputs = filterOutUnusedExts + spec + [ (typeBluespec t1, + fmap (bluespecShow t1) vals, + varName) + ] + outputs = haskellFun vals in + + once $ + testRunCompareArg + inputs len outputs spec (typeBluespec t2) + + where + + t1 = typeOf + t2 = typeOf + + varName = "input1" + +-- | Test the behavior of a binary operation (an @'Op2' a b c@ value) against +-- its expected behavior (as a Haskell function of type @[a] -> [b] -> [c]@) +-- using the supplied inputs (of type @[(a, b)]@). This function is intended to +-- be used to construct regression tests. +mkRegressionTest2 :: (Typed a, Typed b, Typed c, + DisplayableInBluespec c, ReadableFromBluespec c, AEq c) + => Op2 a b c + -> ([a] -> [b] -> [c]) + -> [(a, b)] + -> Property +mkRegressionTest2 op haskellFun vals = + let spec = alwaysTriggerArg1 (UExpr t3 appliedOp) + appliedOp = Op2 op (ExternVar t1 varName1 Nothing) + (ExternVar t2 varName2 Nothing) + + len = length vals + (vals1, vals2) = unzip vals + inputs = filterOutUnusedExts + spec + [ (typeBluespec t1, + fmap (bluespecShow t1) vals1, + varName1) + , (typeBluespec t2, + fmap (bluespecShow t2) vals2, + varName2) + ] + outputs = haskellFun vals1 vals2 in + + once $ + testRunCompareArg + inputs len outputs spec (typeBluespec t3) + + where + + t1 = typeOf + t2 = typeOf + t3 = typeOf + + varName1 = "input1" + varName2 = "input2" + +-- * Random generators + +-- ** Random function generators + +-- | Generator of functions that produce booleans. +arbitraryOpBool :: Typed a => Gen (Fun a Bool, [a] -> [Bool]) +arbitraryOpBool = + frequency + [ (5, arbitraryOp1Any) + , (5, funCompose1 <$> arbitraryOp1Bool <*> arbitraryOpBool) + , (2, funCompose2 <$> arbitraryOp2Bool <*> arbitraryOpBool <*> arbitraryOpBool) + , (1, funCompose2 <$> arbitraryOp2Eq <*> arbitraryOpBool <*> arbitraryOpBool) + ] + +-- | Generator of functions that take Bits and produce booleans. +arbitraryOpBoolBits :: (Typed a, Bits a) => Gen (Fun a Bool, [a] -> [Bool]) +arbitraryOpBoolBits = + frequency + [ (1, funCompose2 <$> arbitraryOp2Eq <*> arbitraryOpBits <*> arbitraryOpBits) + ] + +-- | Generator of functions that take Nums and produce booleans. +arbitaryOpBoolOrdEqNum :: (Typed a, Eq a, Ord a, Num a) + => Gen (Fun a Bool, [a] -> [Bool]) +arbitaryOpBoolOrdEqNum = + frequency + [ (1, funCompose2 <$> arbitraryOp2Eq <*> arbitraryOpNum <*> arbitraryOpNum) + , (1, funCompose2 <$> arbitraryOp2Ord <*> arbitraryOpNum <*> arbitraryOpNum) + ] + +-- | Generator of functions that take Floating point numbers and produce +-- booleans. +arbitraryOpBoolEqNumFloat :: (Typed t, Eq t, Num t, Floating t) + => Gen (Fun t Bool, [t] -> [Bool]) +arbitraryOpBoolEqNumFloat = + frequency + [ (1, funCompose2 <$> arbitraryOp2Eq <*> arbitraryOpNum <*> arbitraryOpFloat) + , (1, funCompose2 <$> arbitraryOp2Eq <*> arbitraryOpFloat <*> arbitraryOpNum) + ] + +-- | Generator of functions that take and produce Bits. +arbitraryOpBits :: (Bits t, Typed t) + => Gen (Fun t t, [t] -> [t]) +arbitraryOpBits = elements + [ (Op1 (BwNot typeOf), fmap complement) + ] + +-- | Generator of functions that take and produce Nums. +arbitraryOpNum :: (Typed t, Num t) => Gen (Fun t t, [t] -> [t]) +arbitraryOpNum = elements + [ (Op1 (Abs typeOf), fmap abs) + , (Op1 (Sign typeOf), fmap signum) + ] + +-- | Generator of functions that take an arrays and indicates and produce +-- elements from the array. +arbitraryArrayIx :: forall t n . (Typed t, KnownNat n, Num t) + => Gen ( Fun2 (Array n t) Word32 t + , [Array n t] -> [Word32] -> [t] + ) +arbitraryArrayIx = return + (Op2 (Index typeOf), zipWith (\x y -> arrayElems x !! fromIntegral y)) + +-- | Generator of functions that take arrays, indices, and values, and then +-- produce new arrays by updating the elements at the indices with the values. +arbitraryArrayUpdate :: forall t n . (Typed t, KnownNat n, Num t) + => Gen ( Fun3 (Array n t) Word32 t (Array n t) + , [Array n t] -> [Word32] -> [t] -> [Array n t] + ) +arbitraryArrayUpdate = return + (Op3 (UpdateArray typeOf), zipWith3 (\x y z -> array (updateAt y z (arrayElems x)))) + where + updateAt :: forall a. Word32 -> a -> [a] -> [a] + updateAt _ _ [] = [] + updateAt 0 x (_ : as) = x : as + updateAt n x (a : as) = a : updateAt (n-1) x as + +-- | Generator of functions that take structs produce fields of the struct. +arbitraryStructField :: Gen ( Fun MyStruct Int8 + , [MyStruct] -> [Int8] + ) +arbitraryStructField = elements + [ (Op1 (GetField typeOf typeOf myStruct1), fmap (unField . myStruct1)) + , (Op1 (GetField typeOf typeOf myStruct2), fmap (unField . myStruct2)) + ] + +-- | Generator of functions that take and produce structs, where the returned +-- structs have one field value updated. +arbitraryStructUpdate :: Gen ( Fun2 MyStruct Int8 MyStruct + , [MyStruct] -> [Int8] -> [MyStruct] + ) +arbitraryStructUpdate = elements + [ ( Op2 (UpdateField typeOf typeOf myStruct1) + , zipWith (\s i -> s { myStruct1 = Field i }) + ) + , ( Op2 (UpdateField typeOf typeOf myStruct2) + , zipWith (\s i -> s { myStruct2 = Field i }) + ) + ] + +-- | Generator of functions on Floating point numbers. +arbitraryOpFloat :: (Floating t, Typed t) => Gen (Fun t t, [t] -> [t]) +arbitraryOpFloat = elements + [ (Op1 (Recip typeOf), fmap recip) + , (Op1 (Exp typeOf), fmap exp) + , (Op1 (Sqrt typeOf), fmap sqrt) + , (Op1 (Log typeOf), fmap log) + , (Op1 (Sin typeOf), fmap sin) + , (Op1 (Tan typeOf), fmap tan) + , (Op1 (Cos typeOf), fmap cos) + , (Op1 (Asin typeOf), fmap asin) + , (Op1 (Atan typeOf), fmap atan) + , (Op1 (Acos typeOf), fmap acos) + , (Op1 (Sinh typeOf), fmap sinh) + , (Op1 (Tanh typeOf), fmap tanh) + , (Op1 (Cosh typeOf), fmap cosh) + , (Op1 (Asinh typeOf), fmap asinh) + , (Op1 (Atanh typeOf), fmap atanh) + , (Op1 (Acosh typeOf), fmap acosh) + ] + +-- | Generator of functions on that produce elements of any type. +arbitraryOp1Any :: forall a b + . (Arbitrary b, Typed a, Typed b) + => Gen (Fun a b, [a] -> [b]) +arbitraryOp1Any = oneof $ + [ (\v -> (\_ -> Const typeOf v, fmap (const v))) <$> arbitrary ] + ++ + rest + where + rest | Just Refl <- testEquality t1 t2 + = [return (id, id)] + | otherwise + = [] + + t1 :: Type a + t1 = typeOf + + t2 :: Type b + t2 = typeOf + +-- | Generator of functions on Booleans. +arbitraryOp1Bool :: Gen (Fun Bool Bool, [Bool] -> [Bool]) +arbitraryOp1Bool = elements + [ (Op1 Not, fmap not) + ] + +-- | Generator of binary functions on Booleans. +arbitraryOp2Bool :: Gen (Fun2 Bool Bool Bool, [Bool] -> [Bool] -> [Bool]) +arbitraryOp2Bool = elements + [ (Op2 And, zipWith (&&)) + , (Op2 Or, zipWith (||)) + ] + +-- | Generator of binary functions that take two Eq elements of the same type +-- and return a Bool. +arbitraryOp2Eq :: (Typed t, Eq t) + => Gen (Fun2 t t Bool, [t] -> [t] -> [Bool]) +arbitraryOp2Eq = elements + [ (Op2 (Eq typeOf), zipWith (==)) + , (Op2 (Ne typeOf), zipWith (/=)) + ] + +-- | Generator of binary functions that take two Ord elements of the same type +-- and return a Bool. +arbitraryOp2Ord :: (Typed t, Ord t) + => Gen (Fun2 t t Bool, [t] -> [t] -> [Bool]) +arbitraryOp2Ord = elements + [ (Op2 (Le typeOf), zipWith (<=)) + , (Op2 (Lt typeOf), zipWith (<)) + , (Op2 (Ge typeOf), zipWith (>=)) + , (Op2 (Gt typeOf), zipWith (>)) + ] + +-- ** Random data generators + +-- | Random array generator. +arbitraryArray :: forall n t . (KnownNat n, Random t) => Gen (Array n t) +arbitraryArray = array <$> vectorOf len chooseAny + where + len :: Int + len = fromIntegral $ natVal (Proxy :: Proxy n) + +-- | Random struct generator. +arbitraryStruct :: Gen MyStruct +arbitraryStruct = do + fld1 <- Field <$> gen + fld2 <- Field <$> gen + return $ MyStruct fld1 fld2 + where + gen :: Gen Int8 + gen = chooseBoundedIntegral (minBound, maxBound) + +-- ** Random test case generators + +-- | Generator for test cases on integral numbers that produce booleans. +arbitraryOpIntegralBool :: (Typed t, Bounded t, Integral t, Bits t) + => Gen (TestCase1 t Bool) +arbitraryOpIntegralBool = frequency + [ (5, mkTestCase1 + arbitraryOpBool + (chooseBoundedIntegral (minBound, maxBound))) + + , (2, mkTestCase1 + arbitraryOpBoolBits + (chooseBoundedIntegral (minBound, maxBound))) + + -- we need to use +1 because certain operations overflow the number + , (2, mkTestCase1 + arbitaryOpBoolOrdEqNum + (chooseBoundedIntegral (minBound + 1, maxBound))) + ] + +-- | Generator for test cases on floating-point numbers that produce booleans. +arbitraryOpFloatingBool :: (Random t, Typed t, Floating t, Eq t) + => Gen (TestCase1 t Bool) +arbitraryOpFloatingBool = oneof + [ mkTestCase1 arbitraryOpBoolEqNumFloat chooseAny + ] + +-- | Generator for test cases on Arrays selection producing values of the +-- array. +arbitraryArray2Num :: forall n a + . (KnownNat n, Num a, Random a, Typed a) + => Gen (TestCase2 (Array n a) Word32 a) +arbitraryArray2Num = oneof + [ mkTestCase2 arbitraryArrayIx arbitraryArray gen + ] + where + gen :: Gen Word32 + gen = choose (0, len - 1) + + len :: Word32 + len = fromIntegral $ natVal (Proxy :: Proxy n) + +-- | Generator for test cases on Arrays which update values of the array. +arbitraryArray3Num :: forall n a + . (KnownNat n, Num a, Random a, Typed a) + => Gen (TestCase3 (Array n a) Word32 a (Array n a)) +arbitraryArray3Num = oneof + [ mkTestCase3 arbitraryArrayUpdate arbitraryArray gen chooseAny + ] + where + gen :: Gen Word32 + gen = choose (0, len - 1) + + len :: Word32 + len = fromIntegral $ natVal (Proxy :: Proxy n) + +-- | Generator for test cases on structs that produce fields of the struct. +arbitraryOpStruct :: Gen (TestCase1 MyStruct Int8) +arbitraryOpStruct = oneof + [ mkTestCase1 + arbitraryStructField + arbitraryStruct + ] + +-- | Generator for test cases that take and produce structs, where the returned +-- structs have one field value updated. +arbitraryOp2Struct :: Gen (TestCase2 MyStruct Int8 MyStruct) +arbitraryOp2Struct = oneof + [ mkTestCase2 + arbitraryStructUpdate + arbitraryStruct + gen + ] + where + gen :: Gen Int8 + gen = chooseBoundedIntegral (minBound, maxBound) + +-- * Semantics + +-- ** Functions + +-- | Unary Copilot function. +type Fun a b = Expr a -> Expr b + +-- | Binary Copilot function. +type Fun2 a b c = Expr a -> Expr b -> Expr c + +-- | Ternary Copilot function. +type Fun3 a b c d = Expr a -> Expr b -> Expr c -> Expr d + +-- | Compose functions, paired with the Haskell functions that define their +-- idealized meaning. +funCompose1 :: (Fun b c, [b] -> [c]) + -> (Fun a b, [a] -> [b]) + -> (Fun a c, [a] -> [c]) +funCompose1 (f1, g1) (f2, g2) = (f1 . f2, g1 . g2) + +-- | Compose a binary function, with two functions, one for each argument. +funCompose2 :: (Fun2 b c d, [b] -> [c] -> [d]) + -> (Fun a b, [a] -> [b]) + -> (Fun a c, [a] -> [c]) + -> (Fun a d, [a] -> [d]) +funCompose2 (f1, g1) (f2, g2) (f3, g3) = + (uncurry f1 . (f2 &&& f3), uncurry g1 . (g2 &&& g3)) + +-- ** Test cases + +-- | Test case specification for specs with one input variable and one output. +data TestCase1 a b = TestCase1 + { wrapTC1Expr :: Spec + -- ^ Specification containing a trigger with an extern of type 'a'. + + , wrapTC1Fun :: [a] -> [b] + -- ^ Function expected to function in the same way as the Spec being + -- tested. + + , wrapTC1CopInp :: (Type a, String, Gen a) + -- ^ Input specification. + -- + -- - The first element contains the type of the input in Bluespec. + -- + -- - The second contains the variable name in Bluespec. + -- + -- - The latter contains a randomized generator for values of the given + -- type. + + , wrapTC1CopOut :: Type b + -- ^ The type of the output in Bluespec. + } + +-- | Test case specification for specs with two input variables and one output. +data TestCase2 a b c = TestCase2 + { wrapTC2Expr :: Spec + -- ^ Specification containing a trigger with an extern of type 'a' and a + -- trigger with an argument of type 'b'. + + , wrapTC2Fun :: [a] -> [b] -> [c] + -- ^ Function expected to function in the same way as the Spec being + -- tested. + + , wrapTC2CopInp1 :: (Type a, String, Gen a) + -- ^ Input specification for the first input. + -- + -- - The first element contains the type of the input in Bluespec. + -- + -- - The second contains the variable name in Bluespec. + -- + -- - The latter contains a randomized generator for values of the given + -- type. + + , wrapTC2CopInp2 :: (Type b, String, Gen b) + -- ^ Input specification for the second input. + -- + -- - The first element contains the type of the input in Bluespec. + -- + -- - The second contains the variable name in Bluespec. + -- + -- - The latter contains a randomized generator for values of the given + -- type. + + , wrapTC2CopOut :: Type c + -- ^ The type of the output in Bluespec. + } + +-- | Test case specification for specs with three input variables and one output. +data TestCase3 a b c d = TestCase3 + { wrapTC3Expr :: Spec + -- ^ Specification containing a trigger with an extern of type 'a', a + -- trigger with an argument of type 'b', and a trigger with an argument of + -- type 'c'. + + , wrapTC3Fun :: [a] -> [b] -> [c] -> [d] + -- ^ Function expected to function in the same way as the Spec being + -- tested. + + , wrapTC3CopInp1 :: (Type a, String, Gen a) + -- ^ Input specification for the first input. + -- + -- - The first element contains the type of the input in Bluespec. + -- + -- - The second contains the variable name in Bluespec. + -- + -- - The latter contains a randomized generator for values of the given + -- type. + + , wrapTC3CopInp2 :: (Type b, String, Gen b) + -- ^ Input specification for the second input. + -- + -- - The first element contains the type of the input in Bluespec. + -- + -- - The second contains the variable name in Bluespec. + -- + -- - The latter contains a randomized generator for values of the given + -- type. + + , wrapTC3CopInp3 :: (Type c, String, Gen c) + -- ^ Input specification for the second input. + -- + -- - The first element contains the type of the input in Bluespec. + -- + -- - The second contains the variable name in Bluespec. + -- + -- - The latter contains a randomized generator for values of the given + -- type. + + , wrapTC3CopOut :: Type d + -- ^ The type of the output in Bluespec. + } + +-- | Generate test cases for expressions that behave like unary functions. +mkTestCase1 :: (Typed a, Typed b) + => Gen (Fun a b, [a] -> [b]) + -> Gen a + -> Gen (TestCase1 a b) +mkTestCase1 genO gen = do + (copilotF, semF) <- genO + + let spec = alwaysTriggerArg1 (UExpr t2 appliedOp) + appliedOp = copilotF (ExternVar t1 varName Nothing) + + return $ + TestCase1 + { wrapTC1Expr = spec + , wrapTC1Fun = semF + , wrapTC1CopInp = ( t1, varName, gen ) + , wrapTC1CopOut = t2 + } + + where + + t1 = typeOf + t2 = typeOf + + varName = "input1" + +-- | Generate test cases for expressions that behave like binary functions. +mkTestCase2 :: (Typed a, Typed b, Typed c) + => Gen (Fun2 a b c, [a] -> [b] -> [c]) + -> Gen a + -> Gen b + -> Gen (TestCase2 a b c) +mkTestCase2 genO genA genB = do + (copilotF, semF) <- genO + + let spec = alwaysTriggerArg1 (UExpr t3 appliedOp) + appliedOp = copilotF (ExternVar t1 varName1 Nothing) + (ExternVar t2 varName2 Nothing) + + return $ + TestCase2 + { wrapTC2Expr = spec + , wrapTC2Fun = semF + , wrapTC2CopInp1 = ( t1, varName1, genA ) + , wrapTC2CopInp2 = ( t2, varName2, genB ) + , wrapTC2CopOut = t3 + } + + where + + t1 = typeOf + t2 = typeOf + t3 = typeOf + + varName1 = "input1" + varName2 = "input2" + +-- | Generate test cases for expressions that behave like ternary functions. +mkTestCase3 :: (Typed a, Typed b, Typed c, Typed d) + => Gen (Fun3 a b c d, [a] -> [b] -> [c] -> [d]) + -> Gen a + -> Gen b + -> Gen c + -> Gen (TestCase3 a b c d) +mkTestCase3 genO genA genB genC = do + (copilotF, semF) <- genO + + let spec = alwaysTriggerArg1 (UExpr t4 appliedOp) + appliedOp = copilotF (ExternVar t1 varName1 Nothing) + (ExternVar t2 varName2 Nothing) + (ExternVar t3 varName3 Nothing) + + return $ + TestCase3 + { wrapTC3Expr = spec + , wrapTC3Fun = semF + , wrapTC3CopInp1 = ( t1, varName1, genA ) + , wrapTC3CopInp2 = ( t2, varName2, genB ) + , wrapTC3CopInp3 = ( t3, varName3, genC ) + , wrapTC3CopOut = t4 + } + + where + + t1 = typeOf + t2 = typeOf + t3 = typeOf + t4 = typeOf + + varName1 = "input1" + varName2 = "input2" + varName3 = "input3" + +-- | Test running a compiled Bluespec program and comparing the results. +testRunCompare1 :: (Show a, Typed a, + DisplayableInBluespec b, ReadableFromBluespec b, + AEq b, Typed b) + => Gen (TestCase1 a b) -> Property +testRunCompare1 ops = + forAllBlind ops $ \testCase -> + let (TestCase1 + { wrapTC1Expr = copilotSpec + , wrapTC1Fun = haskellFun + , wrapTC1CopInp = inputVar + , wrapTC1CopOut = outputType + }) = testCase + (bluespecTypeInput, bluespecInputName, gen) = inputVar + + in forAll (getPositive <$> arbitrary) $ \len -> + + forAll (vectorOf len gen) $ \vals -> do + + let inputs = filterOutUnusedExts + copilotSpec + [ (typeBluespec bluespecTypeInput, + fmap (bluespecShow bluespecTypeInput) vals, + bluespecInputName) + ] + outputs = haskellFun vals + + testRunCompareArg + inputs len outputs copilotSpec (typeBluespec outputType) + +-- | Test running a compiled Bluespec program and comparing the results. +testRunCompare2 :: (Show a1, Typed a1, Show a2, Typed a2, + DisplayableInBluespec b, ReadableFromBluespec b, + AEq b, Typed b) + => Gen (TestCase2 a1 a2 b) -> Property +testRunCompare2 ops = + forAllBlind ops $ \testCase -> + let (TestCase2 + { wrapTC2Expr = copilotSpec + , wrapTC2Fun = haskellFun + , wrapTC2CopInp1 = inputVar1 + , wrapTC2CopInp2 = inputVar2 + , wrapTC2CopOut = outputType + }) = + testCase + + (bluespecTypeInput1, bluespecInputName1, gen1) = inputVar1 + (bluespecTypeInput2, bluespecInputName2, gen2) = inputVar2 + + in forAll (getPositive <$> arbitrary) $ \len -> + forAll (vectorOf len gen1) $ \vals1 -> + forAll (vectorOf len gen2) $ \vals2 -> do + let inputs = filterOutUnusedExts + copilotSpec + [ (typeBluespec bluespecTypeInput1, + fmap (bluespecShow bluespecTypeInput1) vals1, + bluespecInputName1) + , (typeBluespec bluespecTypeInput2, + fmap (bluespecShow bluespecTypeInput2) vals2, + bluespecInputName2) + ] + outputs = haskellFun vals1 vals2 + + testRunCompareArg + inputs len outputs copilotSpec (typeBluespec outputType) + +-- | Test running a compiled Bluespec program and comparing the results. +testRunCompare3 :: (Show a1, Typed a1, Show a2, Typed a2, Show a3, Typed a3, + DisplayableInBluespec b, ReadableFromBluespec b, + AEq b, Typed b) + => Gen (TestCase3 a1 a2 a3 b) -> Property +testRunCompare3 ops = + forAllBlind ops $ \testCase -> + let (TestCase3 + { wrapTC3Expr = copilotSpec + , wrapTC3Fun = haskellFun + , wrapTC3CopInp1 = inputVar1 + , wrapTC3CopInp2 = inputVar2 + , wrapTC3CopInp3 = inputVar3 + , wrapTC3CopOut = outputType + }) = + testCase + + (bluespecTypeInput1, bluespecInputName1, gen1) = inputVar1 + (bluespecTypeInput2, bluespecInputName2, gen2) = inputVar2 + (bluespecTypeInput3, bluespecInputName3, gen3) = inputVar3 + + in forAll (getPositive <$> arbitrary) $ \len -> + forAll (vectorOf len gen1) $ \vals1 -> + forAll (vectorOf len gen2) $ \vals2 -> + forAll (vectorOf len gen3) $ \vals3 -> do + let inputs = filterOutUnusedExts + copilotSpec + [ (typeBluespec bluespecTypeInput1, + fmap (bluespecShow bluespecTypeInput1) vals1, + bluespecInputName1) + , (typeBluespec bluespecTypeInput2, + fmap (bluespecShow bluespecTypeInput2) vals2, + bluespecInputName2) + , (typeBluespec bluespecTypeInput3, + fmap (bluespecShow bluespecTypeInput3) vals3, + bluespecInputName3) + ] + outputs = haskellFun vals1 vals2 vals3 + + testRunCompareArg + inputs len outputs copilotSpec (typeBluespec outputType) + +-- | Test running a compiled Bluespec program and comparing the results, when +-- the program produces one output as an argument to a trigger that always +-- fires. +-- +-- PRE: all lists (second argument) of inputs have the length given as second +-- argument. +-- +-- PRE: the monitoring code this is linked against uses the function +-- @printBack@ with exactly one argument to pass the results. +testRunCompareArg :: forall b + . (DisplayableInBluespec b, ReadableFromBluespec b, AEq b) + => [(String, [String], String)] + -> Int + -> [b] + -> Spec + -> String + -> Property +testRunCompareArg inputs numInputs vals spec outputType = + ioProperty $ do + tmpDir <- getTemporaryDirectory + setCurrentDirectory tmpDir + + -- Operate in temporary directory + testDir <- mkdtemp "CopilotTest" + setCurrentDirectory testDir + + -- Produce wrapper program + let bluespecProgram = + testRunCompareArgBluespecProgram (Proxy :: Proxy b) inputs outputType + writeFile "Top.bs" bluespecProgram + + -- Produce copilot monitoring code + compile "CopilotTest" spec + r <- compileBluespec "Top" ["-g", "mkTop"] + + -- Compile main program + r2 <- compileExecutable "mkTop" + + -- Print result so far (for debugging purposes only) + {- + print r2 + print testDir + -} + + -- Run the program and compare the results. Note that we use (===) (using + -- the `AEq` class from the `ieee754` package) rather than (==) (using the + -- `Eq` class), as the former allows us to use exact equality comparisons + -- for floating-point types. This lets us ensure that we are handling NaN + -- and -0.0 values correctly. + out <- readProcess "./mkTop" ["-m", show (numInputs + 2)] "" + let outNums = readFromBluespec <$> lines out + comparison = outNums === vals + + -- Only clean up if the test succeeded; otherwise, we want to inspect it. + when comparison $ do + -- Remove temporary directory + setCurrentDirectory tmpDir + removeDirectoryRecursive testDir + + return $ r && r2 && comparison + +-- | Return a wrapper Bluespec program that runs for a number of clock cycles, +-- updating external stream registers on every cycle, running the monitors, and +-- publishing the results of any outputs. +testRunCompareArgBluespecProgram + :: DisplayableInBluespec b + => Proxy b + -> [(String, [String], String)] + -> String + -> String +testRunCompareArgBluespecProgram proxy inputs outputType = unlines $ + [ "package Top where" + , "" + , "import FloatingPoint" + , "import Vector" + , "" + , "import CopilotTest" + , "import CopilotTestTypes" + , "" + ] + ++ inputVecDecls ++ + [ "" + , "mkTop :: Module Empty" + , "mkTop =" + , " module" + , " copilotTestMod <- mkCopilotTest" + ] + ++ inputRegs ++ + [ " i :: Reg (Bit 64) <- mkReg 0" + , " ready :: Reg Bool <- mkReg False" + , "" + , " addCopilotTestRules copilotTestMod $" + , " interface CopilotTestRulesIfc" + , " printBack_action :: " ++ outputType ++ " -> Action" + , " printBack_action output = $display " ++ printBackDisplayArgs + , " when ready" + ] + ++ inputMethods ++ + [ "" + , " rules" + , " \"inputs\": when True ==> do" + ] + ++ inputUpdates ++ + [ " i := i + 1" + , " ready := True" + ] + where + printBackDisplayArgs :: String + printBackDisplayArgs = unwords (displayInBluespec proxy "output") + + inputVecDecls :: [String] + inputVecDecls = + concatMap + (\(bluespecType, _varName, _regName, inputVecName, inputVals) -> + [ inputVecName ++ " :: Vector " ++ show (length inputVals) ++ + " (" ++ bluespecType ++ ")" + , inputVecName ++ " = " ++ genVector inputVals + ]) + vars + + inputRegs :: [String] + inputRegs = + map + (\(bluespecType, _varName, regName, _inputVecName, _inputVals) -> + " " ++ regName ++ " :: Reg (" ++ bluespecType ++ ") <- mkRegU") + vars + + inputMethods :: [String] + inputMethods = + map + (\(_bluespecType, varName, regName, _inputVecName, _inputVals) -> + " " ++ varName ++ "_action = return " ++ regName) + vars + + inputUpdates :: [String] + inputUpdates = + map + (\(_bluespecType, _varName, regName, inputVecName, _inputVals) -> + " " ++ regName ++ " := select " ++ inputVecName ++ " i") + vars + + vars = map oneInput inputs + oneInput (bluespecTypeInput, inputVals, bluespecInputName) = + (bluespecTypeInput, inputVarName, inputRegVarName, inputVecVarName, + inputVals) + where + inputVarName = bluespecInputName + inputRegVarName = bluespecInputName ++ "Impl" + inputVecVarName = bluespecInputName ++ "Inputs" + +-- * Auxiliary functions + +-- ** Specs handling + +-- | Build a 'Spec' that triggers at every step, passing the given expression +-- as argument, and execution a function 'printBack'. +alwaysTriggerArg1 :: UExpr -> Spec +alwaysTriggerArg1 = triggerArg1 (Const Bool True) + + where + + -- | Build a 'Spec' that triggers based on a given boolean stream, passing + -- the given expression as argument, and execution a function 'printBack'. + triggerArg1 :: Expr Bool -> UExpr -> Spec + triggerArg1 guard expr = Spec streams observers triggers properties + + where + + streams = [] + observers = [] + properties = [] + + triggers = [ Trigger function guard args ] + function = "printBack" + args = [ expr ] + +-- | Filter out any elements in the input list (of type @[(a, b, String)]@) +-- whose first element (the name of an external stream) does not correspond to +-- the name of an external stream in the supplied 'Spec'. For example, a Copilot +-- source program may declare external streams, but if none of them are used in +-- the 'Spec', then the 'Spec' value itself will not contain any external stream +-- definitions. As a result, we want to ensure that the input list also does not +-- contain any external streams. +filterOutUnusedExts :: Spec -> [(a, b, String)] -> [(a, b, String)] +filterOutUnusedExts spec = filter (\(_, _, name) -> name `elem` extNames) + where + extNames = map extName $ gatherExts (specStreams spec) (specTriggers spec) + +-- ** Compilation of Bluespec programs + +-- | Compile a Bluespec file given its basename. +compileBluespec :: String -> [String] -> IO Bool +compileBluespec baseName extraArgs = do + result <- catch (do callProcess "bsc" $ extraArgs ++ + [ "-sim", "-quiet", "-u", + -- We suppress the G0023 warning, + -- which arises due to the `nop` + -- triggers defined above. See the + -- DESIGN.md document for more + -- details on what these warning + -- codes mean. + "-suppress-warnings", "G0023:S0080", + baseName ++ ".bs" ] + return True + ) + (\e -> do + hPutStrLn stderr $ + "copilot-bluespec: error: compileBluespec: " + ++ "cannot compile " ++ baseName ++ ".bs with bsc" + hPutStrLn stderr $ + "copilot-bluespec: exception: " ++ show (e :: IOException) + return False + ) + if result + then doesFileExist $ baseName ++ ".bo" + else return False + +-- | Compile a Bluespec file into an executable given its basename. +compileExecutable :: String -> IO Bool +compileExecutable topExe = do + result <- catch (do callProcess "bsc" [ "-sim", "-quiet" + , "-e", topExe + , "-o", topExe + , "bs_fp.c" + ] + return True + ) + (\e -> do + hPutStrLn stderr $ + "copilot-bluespec: error: compileExecutable: " + ++ "cannot compile " ++ topExe ++ " with bsc" + hPutStrLn stderr $ + "copilot-bluespec: exception: " + ++ show (e :: IOException) + return False + ) + if result + then doesFileExist topExe + else return False + +-- ** Interfacing between Haskell and Bluespec + +-- | Bluespec type used to store values of a given type. +typeBluespec :: Typed a => Type a -> String +typeBluespec Bool = "Bool" +typeBluespec Int8 = "Int 8" +typeBluespec Int16 = "Int 16" +typeBluespec Int32 = "Int 32" +typeBluespec Int64 = "Int 64" +typeBluespec Word8 = "UInt 8" +typeBluespec Word16 = "UInt 16" +typeBluespec Word32 = "UInt 32" +typeBluespec Word64 = "UInt 64" +typeBluespec Float = "Float" +typeBluespec Double = "Double" +typeBluespec t@(Array tE) = + "Vector " ++ show (typeLength t) ++ "(" ++ typeBluespec tE ++ ")" +typeBluespec (Struct s) = typeName s + +-- | Show a value of a given type in Bluespec. +bluespecShow :: Type a -> a -> String +bluespecShow Bool x = show x +bluespecShow Int8 x = bluespecShowIntegral x +bluespecShow Int16 x = bluespecShowIntegral x +bluespecShow Int32 x = bluespecShowIntegral x +bluespecShow Int64 x = bluespecShowIntegral x +bluespecShow Word8 x = bluespecShowIntegral x +bluespecShow Word16 x = bluespecShowIntegral x +bluespecShow Word32 x = bluespecShowIntegral x +bluespecShow Word64 x = bluespecShowIntegral x +bluespecShow Float x = bluespecShowRealFloat 32 castFloatToWord32 x +bluespecShow Double x = bluespecShowRealFloat 64 castDoubleToWord64 x +bluespecShow (Array tE) x = genVector $ map (bluespecShow tE) $ arrayElems x +bluespecShow (Struct s) x = + typeName s + ++ "{ " + ++ intercalate ";" + (map + (\(Value fldTy fld@(Field val)) -> + fieldName fld ++ " = " ++ bluespecShow fldTy val) + (toValues x)) + ++ "}" + +-- | Show a value of a integral type (e.g., 'Int8' or 'Word8'). +bluespecShowIntegral :: (Integral a, Num a, Ord a, Show a) => a -> String +bluespecShowIntegral x + | x >= 0 = show x + -- Bluespec Haskell doesn't have negative integer literals, so something like + -- "-42" won't parse. Instead, we must rely on Bluespec's `negate` function. + -- + -- We must be careful to negate an Integer literal rather than than a + -- fixed-precision literal. For instance, suppose we wanted to display + -- (-128 :: Int8). We wouldn't want to do this by displaying `negate 128`, + -- since 128 isn't a valid Int8 value—the maximum Int8 value is 127! + -- Instead, we want to display `fromInteger (negate 128)`, where 128 is an + -- Integer. This way, `negate` can turn `128` to `-128` without issues. + | otherwise = "fromInteger (negate " ++ show (abs (toInteger x)) ++ ")" + +-- | Show a value of a floating-point type (e.g., 'Float' or 'Double'). We make +-- sure to convert NaN and infinity values to the corresponding Bluespec +-- @FloatingPoint@ functions that construct these values. +bluespecShowRealFloat :: + (Num float, Ord float, RealFloat float, Show float, Show word) + => Int + -> (float -> word) + -> float + -> String +bluespecShowRealFloat floatSizeInBits castFloatToWord float + -- We want to ensure that NaN values are correctly translated to Bluespec, + -- bit by bit. We have two mechanisms to do so. On the Haskell side, we have + -- `ieee754`'s `nanWithPayload` function, and on the Bluespec side, we have + -- `FloatingPoint`'s `nanQuiet` function. Unfortunately, their arguments are + -- of different types, and it isn't quite clear how to express one function + -- in terms of the other. + -- + -- To avoid this problem, we take a more indirect approach: we first cast + -- the Haskell floating-point value to a word and then `unpack` the word to + -- a floating-point value on the Bluespec side. It's somewhat verbose, but + -- it gets the job done reliably. + | isNaN float + = "unpack (" ++ show (castFloatToWord float) ++ + " :: Bit " ++ show floatSizeInBits ++ ")" + + | isInfinite float + = "infinity " ++ show floatIsNeg + + | floatIsNeg + = "negate " ++ show (abs float) + + | otherwise + = show float + where + floatIsNeg = (float < 0) || isNegativeZero float + +-- | Given a list of elements as arguments, show a @Vector@ expression. For +-- example, @'genVector' [\"27\", \"42\"]@ will return +-- @\"updateVector (updateVector newVector 0 27) 1 42)\"@. +genVector :: [String] -> String +genVector vals = + snd $ + foldl' + (\(!i, !v) x -> + (i+1, "update (" ++ v ++ ") " ++ show i ++ " (" ++ x ++ ")")) + (0 :: Int, "newVector") + vals + +-- | Display a value of a given type in Bluespec using @$display@. +class DisplayableInBluespec a where + displayInBluespec :: + proxy a -- ^ The type of the value. + -> String -- ^ The name of the Bluespec variable. + -> [String] -- ^ All arguments that are passed to @$display@. + +-- | Most Bluespec types can be displayed using @fshow@. +fshowDisplay :: proxy a -> String -> [String] +fshowDisplay _ output = ["(fshow " ++ output ++ ")"] + +-- | We display floating-point numbers by converting them to an integer and +-- printing them in hexadecimal (using the @%x@ modifier). This somewhat unusual +-- choice is motivated by the fact that this output is easier to parse than the +-- @fshow@ output. +hexFloatDisplay :: proxy a -> String -> [String] +hexFloatDisplay _ output = ["\"%x\"", output] + +instance DisplayableInBluespec Bool where + displayInBluespec = fshowDisplay + +instance DisplayableInBluespec Int8 where + displayInBluespec = fshowDisplay + +instance DisplayableInBluespec Int16 where + displayInBluespec = fshowDisplay + +instance DisplayableInBluespec Int32 where + displayInBluespec = fshowDisplay + +instance DisplayableInBluespec Int64 where + displayInBluespec = fshowDisplay + +instance DisplayableInBluespec Word8 where + displayInBluespec = fshowDisplay + +instance DisplayableInBluespec Word16 where + displayInBluespec = fshowDisplay + +instance DisplayableInBluespec Word32 where + displayInBluespec = fshowDisplay + +instance DisplayableInBluespec Word64 where + displayInBluespec = fshowDisplay + +instance DisplayableInBluespec Float where + displayInBluespec = hexFloatDisplay + +instance DisplayableInBluespec Double where + displayInBluespec = hexFloatDisplay + +instance DisplayableInBluespec a => DisplayableInBluespec (Array n a) where + displayInBluespec = fshowDisplay + +-- | @copilot-bluespec@–generated structs currently do not have @FShow@ +-- instances. (Perhaps they should: see +-- https://github.com/Copilot-Language/copilot-bluespec/issues/12) +-- In lieu of this, we manually define the same code that would be used in a +-- derived @FShow@ instance. +instance DisplayableInBluespec MyStruct where + displayInBluespec _ output = + [ "\"MyStruct { myStruct1 = %d ; myStruct2 = %d }\"" + , output ++ ".myStruct1" + , output ++ ".myStruct2" + ] + +-- | Read a value of a given type in Bluespec. +class ReadableFromBluespec a where + readFromBluespec :: String -> a + +instance ReadableFromBluespec Bool where + readFromBluespec = read + +instance ReadableFromBluespec Int8 where + readFromBluespec = read + +instance ReadableFromBluespec Int16 where + readFromBluespec = read + +instance ReadableFromBluespec Int32 where + readFromBluespec = read + +instance ReadableFromBluespec Int64 where + readFromBluespec = read + +instance ReadableFromBluespec Word8 where + readFromBluespec = read + +instance ReadableFromBluespec Word16 where + readFromBluespec = read + +instance ReadableFromBluespec Word32 where + readFromBluespec = read + +instance ReadableFromBluespec Word64 where + readFromBluespec = read + +-- We print out floating-point values in hexadecimal (see `hexFloatDisplay` +-- above), so we parse them accordingly here. + +instance ReadableFromBluespec Float where + readFromBluespec s = castWord32ToFloat $ read $ "0x" ++ s + +instance ReadableFromBluespec Double where + readFromBluespec s = castWord64ToDouble $ read $ "0x" ++ s + +instance (KnownNat n, ReadableFromBluespec a) => ReadableFromBluespec (Array n a) where + readFromBluespec s0 + | Just s1 <- stripPrefix "" s1 + = array $ map readFromBluespec $ words s2 + | otherwise + = error $ "Unexpected Vector fshow output: " ++ s0 + +instance ReadableFromBluespec MyStruct where + readFromBluespec str = + case readsEither (readsStruct minPrec) str of + Left err -> error err + Right ms -> ms + +-- | Attempt to read a value of type @a@. If successful, return 'Right' with +-- the read value. Otherwise, return @'Left' err@, where @err@ is an error +-- message describing what went wrong. +readsEither :: ReadS a -> String -> Either String a +readsEither readIt s = + case [ x | (x,"") <- readIt s ] of + [x] -> Right x + [] -> Left $ "readsEither: no parse: " ++ s + _ -> Left $ "readsEither: ambiguous parse: " ++ s + +-- ** Orphan instances for Arrays + +instance Eq a => Eq (Array n a) where + a1 == a2 = arrayElems a1 == arrayElems a2 + +instance AEq a => AEq (Array n a) where + a1 === a2 = arrayElems a1 === arrayElems a2 + +-- ** A simple struct definition for unit testing purposes + +data MyStruct = MyStruct + { myStruct1 :: Field "myStruct1" Int8 + , myStruct2 :: Field "myStruct2" Int8 + } + +-- | Like a derived @Eq@ instance, except that this looks through 'Field's. +instance Eq MyStruct where + MyStruct (Field f1a) (Field f2a) == MyStruct (Field f1b) (Field f2b) = + f1a == f1b && f2a == f2b +instance AEq MyStruct + +-- | Like a derived @Read@ instance, except that this adds 'Field' wrappers as +-- needed. +readsStruct :: Int -> ReadS MyStruct +readsStruct p = readParen (p > 10) $ \s -> do + ("MyStruct", s1) <- lex s + ("{", s2) <- lex s1 + ("myStruct1", s3) <- lex s2 + ("=", s4) <- lex s3 + (f1, s5) <- readsPrec 0 s4 + (";", s6) <- lex s5 + ("myStruct2", s7) <- lex s6 + ("=", s8) <- lex s7 + (f2, s9) <- readsPrec 0 s8 + ("}", s10) <- lex s9 + pure (MyStruct (Field f1) (Field f2), s10) + +instance Struct MyStruct where + typeName _ = "MyStruct" + toValues ms = [ Value Int8 (myStruct1 ms) + , Value Int8 (myStruct2 ms) + ] + +instance Typed MyStruct where + typeOf = Struct (MyStruct (Field 0) (Field 0)) + +-- | Unwrap a 'Field' to obtain the underlying value. +unField :: Field s t -> t +unField (Field val) = val diff --git a/copilot-bluespec/tests/Test/Copilot/Compile/Bluespec/External.hs b/copilot-bluespec/tests/Test/Copilot/Compile/Bluespec/External.hs new file mode 100644 index 000000000..01b1038bb --- /dev/null +++ b/copilot-bluespec/tests/Test/Copilot/Compile/Bluespec/External.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE ExistentialQuantification #-} + +-- | This is a duplicate version of @Copilot.Compile.Bluespec.External@ that is +-- specific to the test suite. Ideally, we would move this into a common library +-- that is shared between both @copilot-bluespec@ and @copilot-c99@ so that we +-- can avoid this duplication. See +-- https://github.com/Copilot-Language/copilot-bluespec/issues/3. +-- +-- Represent information about externs needed in the generation of Bluespec +-- code for stream declarations and triggers. +module Test.Copilot.Compile.Bluespec.External + ( External(..) + , gatherExts + ) where + +-- External imports +import Data.List (unionBy) + +-- External imports: Copilot +import Copilot.Core ( Expr (..), Stream (..), Trigger (..), Type, UExpr (..) ) + +-- | Representation of external variables. +data External = forall a. External + { extName :: String + , extType :: Type a + } + +-- | Collect all external variables from the streams and triggers. +-- +-- Although Copilot specifications can contain also properties and theorems, +-- the Bluespec backend currently only generates code for streams and triggers. +gatherExts :: [Stream] -> [Trigger] -> [External] +gatherExts streams triggers = streamsExts `extUnion` triggersExts + where + streamsExts = foldr (extUnion . streamExts) mempty streams + triggersExts = foldr (extUnion . triggerExts) mempty triggers + + streamExts :: Stream -> [External] + streamExts (Stream _ _ expr _) = exprExts expr + + triggerExts :: Trigger -> [External] + triggerExts (Trigger _ guard args) = guardExts `extUnion` argExts + where + guardExts = exprExts guard + argExts = concatMap uExprExts args + + uExprExts :: UExpr -> [External] + uExprExts (UExpr _ expr) = exprExts expr + + exprExts :: Expr a -> [External] + exprExts (Local _ _ _ e1 e2) = exprExts e1 `extUnion` exprExts e2 + exprExts (ExternVar ty name _) = [External name ty] + exprExts (Op1 _ e) = exprExts e + exprExts (Op2 _ e1 e2) = exprExts e1 `extUnion` exprExts e2 + exprExts (Op3 _ e1 e2 e3) = exprExts e1 `extUnion` exprExts e2 + `extUnion` exprExts e3 + exprExts (Label _ _ e) = exprExts e + exprExts _ = [] + + -- | Union over lists of External, we solely base the equality on the + -- extName's. + extUnion :: [External] -> [External] -> [External] + extUnion = unionBy (\a b -> extName a == extName b) diff --git a/copilot-c99/CHANGELOG b/copilot-c99/CHANGELOG index 88dd603b5..b53dcc838 100644 --- a/copilot-c99/CHANGELOG +++ b/copilot-c99/CHANGELOG @@ -1,4 +1,131 @@ -2021-10-19 +2026-11-07 + * Version bump (4.8.2). (#792) + +2026-09-07 + * Version bump (4.8.1). (#760) + +2026-07-07 + * Version bump (4.8). (#745) + +2026-05-07 + * Version bump (4.7.1). (#730) + +2026-03-07 + * Version bump (4.7). (#714) + * Raise error when compiling empty arrays or structs. (#695) + +2026-01-07 + * Version bump (4.6.1). (#705) + +2025-11-07 + * Version bump (4.6). (#679) + +2025-09-07 + * Version bump (4.5.1). (#666) + +2025-07-07 + * Version bump (4.5). (#642) + +2025-05-07 + * Version bump (4.4). (#618) + +2025-03-07 + * Version bump (4.3). (#604) + +2025-01-07 + * Version bump (4.2). (#577) + * Remove uses of Copilot.Core.Expr.UExpr.uExprType. (#565) + * Allow using same trigger name in multiple declarations. (#296) + * Bump upper version constraint on filepath. (#570) + +2024-11-07 + * Version bump (4.1). (#561) + * Standardize changelog format. (#550) + +2024-09-07 + * Version bump (4.0). (#532) + * Add support for array updates. (#36) + +2024-07-07 + * Version bump (3.20). (#522) + * Add support for struct field updates. (#520) + +2024-05-07 + * Version bump (3.19.1). (#512) + +2024-03-07 + * Version bump (3.19). (#504) + +2024-01-07 + * Version bump (3.18.1). (#493) + +2024-01-07 + * Version bump (3.18). (#487) + * Change return type of main generated for tests. (#468) + * Print constants in tests using portable suffixes. (#471) + * Pass output arrays as arguments to trigger argument functions. (#431) + * Compliance with MISRA C 2023 / MISRA C 2012. (#472) + +2023-11-07 + * Version bump (3.17). (#466) + * Replace uses of deprecated functions. (#457) + +2023-09-07 + * Version bump (3.16.1). (#455) + * Clean code. (#453) + +2023-07-07 + * Version bump (3.16). (#448) + * Introduce testing infrastructure. (#413) + +2023-05-07 + * Version bump (3.15). (#438) + +2023-03-07 + * Version bump (3.14). (#422) + +2023-01-07 + * Version bump (3.13). (#406) + * Declare local array variables in generated guards as pointers. (#401) + * Use pointer to pass output array as argument to generators. (#386) + +2022-11-07 + * Version bump (3.12). (#389) + * Removed deprecated flag from cabal file. (#380) + * Generate type declarations in separate header file. (#373) + +2022-09-07 + * Version bump (3.11). (#376) + * Update to support language-c99-0.2.0. (#371) + * Fix error handling buffers in generated code for 'step'. (#314) + +2022-07-07 + * Version bump (3.10). (#356) + * Remove unnecessary dependencies from Cabal package. (#323) + * Remove duplicated compiler option. (#328) + * Pass structs by reference, not value, in handlers. (#305) + * Relax version bounds of dependencies. (#335) + * Update repo info in cabal file. (#333) + +2022-05-06 + * Version bump (3.9). (#320) + * Compliance with style guide (partial). (#316) + * Translate math operations taking type into account. (#263) + * Fix issue with delays of streams of structs or arrays. (#276) + * Fix issue in C99 implementation of signum. (#278) + +2022-03-07 + * Version bump (3.8). (#298) + * Hide internal modules deprecated in Copilot 3.5. (#289) + * Mark package as uncurated to avoid modification. (#288) + +2022-01-07 + * Version bump (3.7). (#287) + * Guard against empty specs. (#274) + * Make typetypes respect dependency order. (#275) + +2021-11-07 + * Version bump (3.6). (#264) * Introduce new ops atan2, ceiling, floor. (#246) * Allow customizing output directory. (#255) * Fix outdated/broken links. (#252) @@ -28,31 +155,31 @@ * Completed the documentation. (#171) 2020-12-06 - * Version bump (3.2). - * Implemented arrays in test driver (#176). - * Fixed nested array initialisation bug (#173). - * Fixed length of buffer allocation for n-dimensional arrays (#174). - * Fixed printing of long ints in test suite (#177). - * Fixed printing of unsigned ints in test suite (#177). - * Fixed '-Wsequence-point' warnings from GCC (#179). - * Split Property.hs (#180). - * Removed 'Test' from module paths (#181). - * Made compiletest take compiler options as an argument (#182). - * Fixed problem with property and empty string in driver CSV (#183). - * Added comma to output of driver to match the interpreter (#184). - * Implemented basic quickcheck based testing (#185). + * Version bump (3.2). (#65) + * Implemented arrays in test driver. (#176) + * Fixed nested array initialisation bug. (#173) + * Fixed length of buffer allocation for n-dimensional arrays. (#174) + * Fixed printing of long ints in test suite. (#177) + * Fixed printing of unsigned ints in test suite. (#177) + * Fixed '-Wsequence-point' warnings from GCC. (#179) + * Split Property.hs. (#180) + * Removed 'Test' from module paths. (#181) + * Made compiletest take compiler options as an argument. (#182) + * Fixed problem with property and empty string in driver CSV. (#183) + * Added comma to output of driver to match the interpreter. (#184) + * Implemented basic quickcheck based testing. (#185) 2020-03-30 - * Version bump (3.1.2) + * Version bump (3.1.2). (#187) * Fixed bug where stream buffers are updated too soon. (#188) * Updated description of cabal package. (#192) 2019-12-23 - * Version bump (3.1.1). - * Fixed bug with constant structs and arrays.(#200). + * Version bump (3.1.1). (#191) + * Fixed bug with constant structs and arrays. (#200) 2019-11-22 - * Version bump (3.1). - * Remove ExternFun (#207). - * Fix bug in code generation for local expression (#198). - * Implement code generation for labels (trivially) (#199). + * Version bump (3.1). (#46) + * Remove ExternFun. (#207) + * Fix bug in code generation for local expression. (#198) + * Implement code generation for labels (trivially). (#199) diff --git a/copilot-c99/copilot-c99.cabal b/copilot-c99/copilot-c99.cabal index 67bfc7b6b..7e1e3d17a 100644 --- a/copilot-c99/copilot-c99.cabal +++ b/copilot-c99/copilot-c99.cabal @@ -1,6 +1,6 @@ cabal-version : >= 1.10 name : copilot-c99 -version : 3.5 +version : 4.8.2 synopsis : A compiler for Copilot targeting C99. description : This package is a back-end from Copilot to C. @@ -27,39 +27,71 @@ author : Frank Dedden , Alwyn Goodloe , Ivan Perez +x-curation: uncurated + source-repository head type: git - location: git://github.com/Copilot-Language/copilot.git - subdir: lib/copilot-c99 + location: https://github.com/Copilot-Language/copilot.git + subdir: copilot-c99 library default-language : Haskell2010 hs-source-dirs : src - -- The following -Wno-deprecations is temprary and related to issue - -- https://github.com/Copilot-Language/copilot/issues/237 - -- It should be removed in a future version, when this library hides - -- internal modules. - ghc-options : -Wall -fwarn-tabs -Wno-deprecations + ghc-options : -Wall build-depends : base >= 4.9 && < 5 - , containers >= 0.4 && < 0.7 , directory >= 1.3 && < 1.4 - , filepath >= 1.4 && < 1.5 - , mtl >= 2.2 && < 2.3 + , filepath >= 1.4 && < 1.6 + , mtl >= 2.2 && < 2.4 , pretty >= 1.1 && < 1.2 - , copilot-core >= 3.5 && < 3.6 - , language-c99 >= 0.1.1 && < 0.2 - , language-c99-util >= 0.1.1 && < 0.2 - , language-c99-simple >= 0.1.1 && < 0.2 + , copilot-core >= 4.8.2 && < 4.9 + , language-c99 >= 0.2.0 && < 0.3 + , language-c99-simple >= 0.3 && < 0.4 exposed-modules : Copilot.Compile.C99 - , Copilot.Compile.C99.Translate - , Copilot.Compile.C99.Util - , Copilot.Compile.C99.CodeGen - , Copilot.Compile.C99.External - , Copilot.Compile.C99.Compile - , Copilot.Compile.C99.Settings - - other-modules : Copilot.Compile.C99.Compile.Internal - , Copilot.Compile.C99.Settings.Internal + + other-modules : Copilot.Compile.C99.Expr + , Copilot.Compile.C99.Type + , Copilot.Compile.C99.Error + , Copilot.Compile.C99.Name + , Copilot.Compile.C99.CodeGen + , Copilot.Compile.C99.External + , Copilot.Compile.C99.Compile + , Copilot.Compile.C99.Settings + , Copilot.Compile.C99.Representation + +test-suite unit-tests + type: + exitcode-stdio-1.0 + + main-is: + Main.hs + + other-modules: + Test.Copilot.Compile.C99 + + build-depends: + base + , directory + , HUnit + , QuickCheck + , pretty + , process + , random + , test-framework + , test-framework-hunit + , test-framework-quickcheck2 + , unix + + , copilot-core + , copilot-c99 + + hs-source-dirs: + tests + + default-language: + Haskell2010 + + ghc-options: + -Wall diff --git a/copilot-c99/src/Copilot/Compile/C99.hs b/copilot-c99/src/Copilot/Compile/C99.hs index 41b64c71c..e03f1b644 100644 --- a/copilot-c99/src/Copilot/Compile/C99.hs +++ b/copilot-c99/src/Copilot/Compile/C99.hs @@ -6,5 +6,6 @@ module Copilot.Compile.C99 , mkDefaultCSettings ) where -import Copilot.Compile.C99.Compile.Internal -import Copilot.Compile.C99.Settings.Internal +-- Internal imports +import Copilot.Compile.C99.Compile ( compile, compileWith ) +import Copilot.Compile.C99.Settings ( CSettings (..), mkDefaultCSettings ) diff --git a/copilot-c99/src/Copilot/Compile/C99/CodeGen.hs b/copilot-c99/src/Copilot/Compile/C99/CodeGen.hs index 61bb68ca9..ce822e558 100644 --- a/copilot-c99/src/Copilot/Compile/C99/CodeGen.hs +++ b/copilot-c99/src/Copilot/Compile/C99/CodeGen.hs @@ -1,179 +1,347 @@ {-# LANGUAGE GADTs #-} -{-# LANGUAGE ScopedTypeVariables #-} -- | High-level translation of Copilot Core into C99. module Copilot.Compile.C99.CodeGen - {-# DEPRECATED "This module will be hidden in future versions." #-} - where + ( + -- * Externs + mkExtCpyDecln + , mkExtDecln + + -- * Type declarations + , mkStructDecln + , mkStructForwDecln -import Control.Monad.State (runState) -import Data.List (union, unzip4) -import Data.Typeable (Typeable) + -- * Ring buffers + , mkBuffDecln + , mkIndexDecln + , mkAccessDecln + -- * Stream generators + , mkGenFun + , mkGenFunArray + + -- * Monitor processing + , mkStep + ) + where + +-- External imports +import Control.Monad.State ( runState ) +import Data.List ( unzip4 ) +import qualified Data.List.NonEmpty as NonEmpty import qualified Language.C99.Simple as C -import Copilot.Core -import Copilot.Compile.C99.Util -import Copilot.Compile.C99.External -import Copilot.Compile.C99.Settings -import Copilot.Compile.C99.Translate +-- Internal imports: Copilot +import Copilot.Core ( Expr (..), Id, Stream (..), Struct (..), Trigger (..), + Type (..), UExpr (..), Value (..), fieldName, typeSize ) --- | Write a declaration for a generator function. -gendecln :: String -> Type a -> C.Decln -gendecln name ty = C.FunDecln Nothing cty name [] where - cty = C.decay $ transtype ty +-- Internal imports +import Copilot.Compile.C99.Error ( impossible ) +import Copilot.Compile.C99.Expr ( constArray, transExpr ) +import Copilot.Compile.C99.External ( External (..) ) +import Copilot.Compile.C99.Name ( argNames, argTempNames, + generatorName, guardName, + indexName, streamAccessorName, + streamName ) +import Copilot.Compile.C99.Settings ( CSettings, + cSettingsStepFunctionName ) +import Copilot.Compile.C99.Type ( transType ) +import Copilot.Compile.C99.Representation ( UniqueTrigger (..) ) --- | Write a generator function for a stream. -genfun :: String -> Expr a -> Type a -> C.FunDef -genfun name expr ty = C.FunDef cty name [] cvars [C.Return $ Just cexpr] where - cty = C.decay $ transtype ty - (cexpr, cvars) = runState (transexpr expr) mempty +-- * Externs -- | Make a extern declaration of a variable. -mkextdecln :: External -> C.Decln -mkextdecln (External name _ ty) = decln where - decln = C.VarDecln (Just C.Extern) cty name Nothing - cty = transtype ty +mkExtDecln :: External -> C.Decln +mkExtDecln (External name _ ty) = decln + where + decln = C.VarDecln (Just C.Extern) cTy name Nothing + cTy = transType ty -- | Make a declaration for a copy of an external variable. -mkextcpydecln :: External -> C.Decln -mkextcpydecln (External name cpyname ty) = decln where - cty = transtype ty - decln = C.VarDecln (Just C.Static) cty cpyname Nothing +mkExtCpyDecln :: External -> C.Decln +mkExtCpyDecln (External _name cpyName ty) = decln + where + decln = C.VarDecln (Just C.Static) cTy cpyName Nothing + cTy = transType ty + +-- * Type declarations + +-- | Write a struct declaration based on its definition. +mkStructDecln :: Struct a => Type a -> C.Decln +mkStructDecln (Struct x) = C.TypeDecln struct + where + struct = C.TypeSpec $ C.StructDecln (Just $ typeName x) fields + fields = NonEmpty.fromList $ map mkField (toValues x) + + mkField :: Value a -> C.FieldDecln + mkField (Value ty field) = C.FieldDecln (transType ty) (fieldName field) + +-- | Write a forward struct declaration. +mkStructForwDecln :: Struct a => Type a -> C.Decln +mkStructForwDecln (Struct x) = C.TypeDecln struct + where + struct = C.TypeSpec $ C.Struct (typeName x) + +-- * Ring buffers -- | Make a C buffer variable and initialise it with the stream buffer. -mkbuffdecln :: Id -> Type a -> [a] -> C.Decln -mkbuffdecln sid ty xs = C.VarDecln (Just C.Static) cty name initvals where - name = streamname sid - cty = C.Array (transtype ty) (Just $ C.LitInt $ fromIntegral buffsize) - buffsize = length xs - initvals = Just $ C.InitArray $ map (C.InitExpr . constty ty) xs +mkBuffDecln :: Id -> Type a -> [a] -> C.Decln +mkBuffDecln sId ty xs = C.VarDecln (Just C.Static) cTy name initVals + where + name = streamName sId + cTy = C.Array (transType ty) (Just $ C.LitInt $ fromIntegral buffSize) + buffSize = length xs + initVals = Just $ C.InitList $ constArray ty xs -- | Make a C index variable and initialise it to 0. -mkindexdecln :: Id -> C.Decln -mkindexdecln sid = C.VarDecln (Just C.Static) cty name initval where - name = indexname sid - cty = C.TypeSpec $ C.TypedefName "size_t" - initval = Just $ C.InitExpr $ C.LitInt 0 - --- | Define an accessor functions for the ring buffer associated with a stream -mkaccessdecln :: Id -> Type a -> [a] -> C.FunDef -mkaccessdecln sid ty xs = C.FunDef cty name params [] [C.Return (Just expr)] +mkIndexDecln :: Id -> C.Decln +mkIndexDecln sId = C.VarDecln (Just C.Static) cTy name initVal where - cty = C.decay $ transtype ty - name = streamaccessorname sid - bufflength = C.LitInt $ fromIntegral $ length xs + name = indexName sId + cTy = C.TypeSpec $ C.TypedefName "size_t" + initVal = Just $ C.InitExpr $ C.LitInt 0 + +-- | Define an accessor functions for the ring buffer associated with a stream. +mkAccessDecln :: Id -> Type a -> [a] -> C.FunDef +mkAccessDecln sId ty xs = + C.FunDef static cTy name params [] [C.Return (Just expr)] + where + static = Just C.Static + cTy = C.decay $ transType ty + name = streamAccessorName sId + + -- We cast the buffer length to a size_t to make sure that there are no + -- implicit conversions. This is a requirement for compliance with MISRA C + -- (Rule 10.4). + buffLength = C.Cast sizeT $ C.LitInt $ fromIntegral $ length xs + sizeT = C.TypeName $ C.TypeSpec $ C.TypedefName "size_t" params = [C.Param (C.TypeSpec $ C.TypedefName "size_t") "x"] - index = (C.Ident (indexname sid) C..+ C.Ident "x") C..% bufflength - expr = C.Index (C.Ident (streamname sid)) index - --- | Writes the step function, that updates all streams. -mkstep :: CSettings -> [Stream] -> [Trigger] -> [External] -> C.FunDef -mkstep cSettings streams triggers exts = - C.FunDef void (cSettingsStepFunctionName cSettings) [] declns stmts where - - void = C.TypeSpec C.Void - stmts = map mkexcopy exts - ++ map mktriggercheck triggers - ++ tmpassigns - ++ bufferupdates - ++ indexupdates - (declns, tmpassigns, bufferupdates, indexupdates) = - unzip4 $ map mkupdateglobals streams - - -- Write code to update global stream buffers and index. - mkupdateglobals :: Stream -> (C.Decln, C.Stmt, C.Stmt, C.Stmt) - mkupdateglobals (Stream sid buff expr ty) = - (tmpdecln, tmpassign, bufferupdate, indexupdate) - where - tmpdecln = C.VarDecln Nothing cty tmp_var Nothing + index = (C.Ident (indexName sId) C..+ C.Ident "x") C..% buffLength + expr = C.Index (C.Ident (streamName sId)) index - tmpassign = case ty of - Array _ -> C.Expr $ memcpy (C.Ident tmp_var) val size - where - size = C.LitInt $ fromIntegral $ tysize ty - _ -> C.Expr $ C.Ident tmp_var C..= val +-- * Stream generators + +-- | Write a generator function for a stream. +mkGenFun :: String -> Expr a -> Type a -> C.FunDef +mkGenFun name expr ty = + C.FunDef static cTy name [] cVars stmts + where + static = Just C.Static + cTy = C.decay $ transType ty + (cExpr, state') = runState (transExpr expr) (0, mempty, mempty) + (_, cVars, stmts') = state' + stmts = stmts' ++ [C.Return $ Just cExpr] + +-- | Write a generator function for a stream that returns an array. +mkGenFunArray :: String -> String -> Expr a -> Type a -> C.FunDef +mkGenFunArray name nameArg expr ty@(Array _) = + C.FunDef static funType name [ outputParam ] varDecls stmts + where + static = Just C.Static + funType = C.TypeSpec C.Void + + -- The output value is an array + outputParam = C.Param cArrayType nameArg + cArrayType = transType ty + + -- Statements to execute as part of the generator. They include statements + -- related to calculating the values of intermediate expressions, and + -- statements related to copying the final value to the destination array. + stmts = stmts' ++ [ copyStmt ] + + -- Output value, variable declarations needed, and other statements that + -- must be executed to calculate intermediate values. + (cExpr, state') = runState (transExpr expr) (0, mempty, mempty) + (_, varDecls, stmts') = state' + + -- Copy expression to output argument. + copyStmt = C.Expr $ memcpy (C.Ident nameArg) cExpr size + size = C.LitInt (fromIntegral $ typeSize ty) + C..* C.SizeOfType (C.TypeName $ tyElemName ty) + +mkGenFunArray _name _nameArg _expr _ty = + impossible "mkGenFunArray" "copilot-c99" + +-- * Monitor processing + +-- | Define the step function that updates all streams. +mkStep :: CSettings -> [Stream] -> [UniqueTrigger] -> [External] -> C.FunDef +mkStep cSettings streams triggers exts = + C.FunDef Nothing void (cSettingsStepFunctionName cSettings) [] declns stmts + where + void = C.TypeSpec C.Void + + declns = streamDeclns + ++ concat triggerDeclns + + stmts = map mkExCopy exts + ++ triggerStmts + ++ tmpAssigns + ++ bufferUpdates + ++ indexUpdates + + (streamDeclns, tmpAssigns, bufferUpdates, indexUpdates) = + unzip4 $ map mkUpdateGlobals streams + (triggerDeclns, triggerStmts) = + unzip $ map mkTriggerCheck triggers + + -- Update the value of a variable with the result of calling a function that + -- generates the next value in a stream expression. If the type of the + -- variable is an array, then we cannot perform a direct C assignment, so + -- we instead pass the variable as an output array to the function. + updateVar :: C.Ident -> C.Ident -> Type a -> C.Expr + updateVar varName genName (Array _) = + C.Funcall (C.Ident genName) [C.Ident varName] + updateVar varName genName _ = + C.AssignOp C.Assign (C.Ident varName) (C.Funcall (C.Ident genName) []) + + -- Write code to update global stream buffers and index. + mkUpdateGlobals :: Stream -> (C.Decln, C.Stmt, C.Stmt, C.Stmt) + mkUpdateGlobals (Stream sId buff _expr ty) = + (tmpDecln, tmpAssign, bufferUpdate, indexUpdate) + where + tmpDecln = C.VarDecln Nothing cTy tmpVar Nothing - bufferupdate = case ty of - Array _ -> C.Expr $ memcpy dest (C.Ident tmp_var) size + tmpAssign = C.Expr $ updateVar tmpVar (generatorName sId) ty + + bufferUpdate = case ty of + Array _ -> C.Expr $ memcpy dest (C.Ident tmpVar) size + where + dest = C.Index buffVar indexVar + size = C.LitInt + (fromIntegral $ typeSize ty) + C..* C.SizeOfType (C.TypeName (tyElemName ty)) + _ -> C.Expr $ + C.Index buffVar indexVar C..= C.Ident tmpVar + + indexUpdate = C.Expr $ indexVar C..= (incIndex C..% buffLength) where - dest = C.Index buff_var index_var - size = C.LitInt $ fromIntegral $ tysize ty - _ -> C.Expr $ C.Index buff_var index_var C..= (C.Ident tmp_var) + -- We cast the buffer length and the literal one to a size_t to + -- make sure that there are no implicit conversions. This is a + -- requirement for compliance with MISRA C (Rule 10.4). + buffLength = C.Cast sizeT $ C.LitInt $ fromIntegral $ length buff + incIndex = indexVar C..+ C.Cast sizeT (C.LitInt 1) + sizeT = C.TypeName $ C.TypeSpec $ C.TypedefName "size_t" + + tmpVar = streamName sId ++ "_tmp" + buffVar = C.Ident $ streamName sId + indexVar = C.Ident $ indexName sId + cTy = transType ty + + -- Make code that copies an external variable to its local one. + mkExCopy :: External -> C.Stmt + mkExCopy (External name cpyName ty) = C.Expr $ case ty of + Array _ -> memcpy exVar locVar size + where + exVar = C.Ident cpyName + locVar = C.Ident name + size = C.LitInt (fromIntegral $ typeSize ty) + C..* C.SizeOfType (C.TypeName (tyElemName ty)) - indexupdate = C.Expr $ index_var C..= (incindex C..% bufflength) + _ -> C.Ident cpyName C..= C.Ident name + + -- Make if-statement to check the guard, call the handler if necessary. + -- This returns two things: + -- + -- * A list of Declns for temporary variables, one for each argument that + -- the handler function accepts. For example, if a handler function takes + -- three arguments, the list of Declns might look something like this: + -- + -- @ + -- int8_t handler_arg_temp0; + -- int16_t handler_arg_temp1; + -- struct s handler_arg_temp2; + -- @ + -- + -- * A Stmt representing the if-statement. Continuing the example above, + -- the if-statement would look something like this: + -- + -- @ + -- if (handler_guard()) { + -- handler_arg_temp0 = handler_arg0(); + -- handler_arg_temp1 = handler_arg1(); + -- handler_arg_temp2 = handler_arg2(); + -- handler(handler_arg_temp0, handler_arg_temp1, &handler_arg_temp2); + -- } + -- @ + -- + -- We create temporary variables because: + -- + -- 1. We want to pass structs by reference intead of by value. To this end, + -- we use C's & operator to obtain a reference to a temporary variable + -- of a struct type and pass that to the handler function. + -- + -- 2. Assigning a struct to a temporary variable defensively ensures that + -- any modifications that the handler called makes to the struct argument + -- will not affect the internals of the monitoring code. + mkTriggerCheck :: UniqueTrigger -> ([C.Decln], C.Stmt) + mkTriggerCheck (UniqueTrigger uniqueName (Trigger name _guard args)) = + (aTmpDeclns, triggerCheckStmt) + where + aTmpDeclns :: [C.Decln] + aTmpDeclns = zipWith declare args aTempNames where - bufflength = C.LitInt $ fromIntegral $ length buff - incindex = index_var C..+ C.LitInt 1 - - tmp_var = streamname sid ++ "_tmp" - buff_var = C.Ident $ streamname sid - index_var = C.Ident $ indexname sid - val = C.Funcall (C.Ident $ generatorname sid) [] - cty = transtype ty - - -- Make code that copies an external variable to its local one. - mkexcopy :: External -> C.Stmt - mkexcopy (External name cpyname ty) = C.Expr $ case ty of - Array _ -> memcpy exvar locvar size where - exvar = C.Ident cpyname - locvar = C.Ident name - size = C.LitInt $ fromIntegral $ tysize ty - _ -> C.Ident cpyname C..= C.Ident name - - -- Make if-statement to check the guard, call the trigger if necessary. - mktriggercheck :: Trigger -> C.Stmt - mktriggercheck (Trigger name guard args) = C.If guard' firetrigger where - guard' = C.Funcall (C.Ident $ guardname name) [] - firetrigger = [C.Expr $ C.Funcall (C.Ident name) args'] where - args' = take (length args) (map argcall (argnames name)) - argcall name = C.Funcall (C.Ident name) [] - - -- Write a call to the memcpy function. - memcpy :: C.Expr -> C.Expr -> C.Expr -> C.Expr - memcpy dest src size = C.Funcall (C.Ident "memcpy") [dest, src, size] + declare :: UExpr -> C.Ident -> C.Decln + declare (UExpr ty _) tmpVar = + C.VarDecln Nothing (transType ty) tmpVar Nothing + triggerCheckStmt :: C.Stmt + triggerCheckStmt = C.If guard' fireTrigger + where + guard' = C.Funcall (C.Ident $ guardName uniqueName) [] --- | Write a struct declaration based on its definition. -mkstructdecln :: Struct a => Type a -> C.Decln -mkstructdecln (Struct x) = C.TypeDecln struct where - struct = C.TypeSpec $ C.StructDecln (Just $ typename x) fields - fields = map mkfield (toValues x) + -- The body of the if-statement. This consists of statements that + -- assign the values of the temporary variables, following by a + -- final statement that passes the temporary variables to the + -- handler function. + -- Note that we call 'name' here instead of 'uniqueName', as 'name' + -- is the name of the actual external function. + fireTrigger = map C.Expr argAssigns + ++ [C.Expr $ + C.Funcall (C.Ident name) + (zipWith passArg aTempNames args)] + where + -- List of assignments of values of temporary variables. + argAssigns :: [C.Expr] + argAssigns = zipWith3 assign aTempNames aArgNames args - mkfield :: Value a -> C.FieldDecln - mkfield (Value ty field) = C.FieldDecln (transtype ty) (fieldname field) + assign :: C.Ident -> C.Ident -> UExpr -> C.Expr + assign aTempName aArgName (UExpr ty _) = + updateVar aTempName aArgName ty --- | Write a forward struct declaration. -mkstructforwdecln :: Struct a => Type a -> C.Decln -mkstructforwdecln (Struct x) = C.TypeDecln struct where - struct = C.TypeSpec $ C.Struct (typename x) - --- | List all types of an expression, returns items uniquely. -exprtypes :: Typeable a => Expr a -> [UType] -exprtypes e = case e of - Const ty _ -> typetypes ty - Local ty1 ty2 _ e1 e2 -> typetypes ty1 `union` typetypes ty2 - `union` exprtypes e1 `union` exprtypes e2 - Var ty _ -> typetypes ty - Drop ty _ _ -> typetypes ty - ExternVar ty _ _ -> typetypes ty - Op1 _ e1 -> exprtypes e1 - Op2 _ e1 e2 -> exprtypes e1 `union` exprtypes e2 - Op3 _ e1 e2 e3 -> exprtypes e1 `union` exprtypes e2 `union` exprtypes e3 - Label ty _ _ -> typetypes ty - --- | List all types of a type, returns items uniquely. -typetypes :: Typeable a => Type a -> [UType] -typetypes ty = case ty of - Array ty' -> [UType ty] `union` typetypes ty' - Struct x -> [UType ty] `union` map (\(Value ty' _) -> UType ty') (toValues x) - _ -> [UType ty] - --- | Collect all expression of a list of streams and triggers and wrap them --- into an UEXpr. -gatherexprs :: [Stream] -> [Trigger] -> [UExpr] -gatherexprs streams triggers = map streamexpr streams - ++ concatMap triggerexpr triggers where - streamexpr (Stream _ _ expr ty) = UExpr ty expr - triggerexpr (Trigger _ guard args) = UExpr Bool guard : args + aArgNames :: [C.Ident] + aArgNames = take (length args) (argNames uniqueName) + + -- Build an expression to pass a temporary variable as argument + -- to a trigger handler. + -- + -- We need to pass a reference to the variable in some cases, + -- so we also need the type of the expression, which is enclosed + -- in the second argument, an UExpr. + passArg :: String -> UExpr -> C.Expr + passArg aTempName (UExpr ty _) = + case ty of + -- Special case for Struct to pass reference to temporary + -- struct variable to handler. (See the comments for + -- mktriggercheck for details.) + Struct _ -> C.UnaryOp C.Ref $ C.Ident aTempName + _ -> C.Ident aTempName + + aTempNames :: [String] + aTempNames = take (length args) (argTempNames uniqueName) + +-- * Auxiliary functions + +-- Write a call to the memcpy function. +memcpy :: C.Expr -> C.Expr -> C.Expr -> C.Expr +memcpy dest src size = C.Funcall (C.Ident "memcpy") [dest, src, size] +-- Translate a Copilot type to a C99 type, handling arrays especially. +-- +-- If the given type is an array (including multi-dimensional arrays), the +-- type is that of the elements in the array. Otherwise, it is just the +-- equivalent representation of the given type in C. +tyElemName :: Type a -> C.Type +tyElemName ty = case ty of + Array ty' -> tyElemName ty' + _ -> transType ty diff --git a/copilot-c99/src/Copilot/Compile/C99/Compile.hs b/copilot-c99/src/Copilot/Compile/C99/Compile.hs index 2a06ee385..1467af403 100644 --- a/copilot-c99/src/Copilot/Compile/C99/Compile.hs +++ b/copilot-c99/src/Copilot/Compile/C99/Compile.hs @@ -1,11 +1,310 @@ +{-# LANGUAGE GADTs #-} -- | Compile Copilot specifications to C99 code. module Copilot.Compile.C99.Compile - {-# DEPRECATED "This module will be hidden in future versions." #-} ( compile , compileWith - , CSettings(..) - , mkDefaultCSettings ) where -import Copilot.Compile.C99.Compile.Internal -import Copilot.Compile.C99.Settings.Internal +-- External imports +import Data.List ( nub, nubBy, union ) +import Data.Maybe ( mapMaybe ) +import Data.Type.Equality ( testEquality, (:~:)(Refl) ) +import Data.Typeable ( Typeable ) +import Language.C99.Pretty ( pretty ) +import qualified Language.C99.Simple as C +import System.Directory ( createDirectoryIfMissing ) +import System.Exit ( exitFailure ) +import System.FilePath ( () ) +import System.IO ( hPutStrLn, stderr ) +import Text.PrettyPrint ( render ) + +-- Internal imports: Copilot +import Copilot.Core ( Expr (..), Spec (..), Stream (..), Struct (..), + Trigger (..), Type (..), UExpr (..), UType (..), + Value (..) ) + +-- Internal imports +import Copilot.Compile.C99.CodeGen ( mkAccessDecln, mkBuffDecln, + mkExtCpyDecln, mkExtDecln, + mkGenFun, mkGenFunArray, + mkIndexDecln, mkStep, + mkStructDecln, mkStructForwDecln ) +import Copilot.Compile.C99.External ( External, gatherExts ) +import Copilot.Compile.C99.Name ( argNames, generatorName, + generatorOutputArgName, guardName ) +import Copilot.Compile.C99.Settings ( CSettings, + cSettingsOutputDirectory, + cSettingsStepFunctionName, + mkDefaultCSettings ) +import Copilot.Compile.C99.Type ( transType ) +import Copilot.Compile.C99.Representation ( UniqueTrigger (..), + mkUniqueTriggers ) + +-- | Compile a specification to a .h and a .c file. +-- +-- The first argument is the settings for the C code generated. +-- +-- The second argument is used as prefix for the .h and .c files generated. +compileWith :: CSettings -> String -> Spec -> IO () +compileWith cSettings prefix spec + | null triggers + = do hPutStrLn stderr $ + "Copilot error: attempt at compiling empty specification.\n" + ++ "You must define at least one trigger to generate C monitors." + exitFailure + + | incompatibleTriggers triggers + = do hPutStrLn stderr $ + "Copilot error: attempt at compiling specification with conflicting " + ++ "trigger definitions.\n" + ++ "Multiple triggers have the same name, but different argument " + ++ "types.\n" + exitFailure + + | otherwise + = do let cFile = render $ pretty $ C.translate $ compileC cSettings spec + hFile = render $ pretty $ C.translate $ compileH cSettings spec + typeDeclnsFile = safeCRender $ compileTypeDeclns cSettings spec + + cMacros = unlines [ "#include " + , "#include " + , "#include " + , "#include " + , "#include " + , "" + , "#include \"" ++ prefix ++ "_types.h\"" + , "#include \"" ++ prefix ++ ".h\"" + , "" + ] + + let dir = cSettingsOutputDirectory cSettings + createDirectoryIfMissing True dir + writeFile (dir prefix ++ ".c") $ cMacros ++ cFile + writeFile (dir prefix ++ ".h") hFile + writeFile (dir prefix ++ "_types.h") typeDeclnsFile + where + triggers = specTriggers spec + + -- Check that two triggers do no conflict, that is: if their names are + -- equal, the types of their arguments should be equal as well. + incompatibleTriggers :: [Trigger] -> Bool + incompatibleTriggers = pairwiseAny conflict + where + conflict :: Trigger -> Trigger -> Bool + conflict t1@(Trigger name1 _ _) t2@(Trigger name2 _ _) = + name1 == name2 && not (compareTrigger t1 t2) + + -- True if the function holds for any pair of elements. We assume that + -- the function is commutative. + pairwiseAny :: (a -> a -> Bool) -> [a] -> Bool + pairwiseAny _ [] = False + pairwiseAny _ (_:[]) = False + pairwiseAny f (x:xs) = any (f x) xs || pairwiseAny f xs + +-- | Compile a specification to a .h and a .c file. +-- +-- The first argument is used as prefix for the .h and .c files generated. +compile :: String -> Spec -> IO () +compile = compileWith mkDefaultCSettings + +-- | Generate the .c file from a 'Spec'. +-- +-- The generated C file has the following structure: +-- +-- * Include .h file. +-- * Declarations of global buffers and indices. +-- * Generator functions for streams, guards and trigger arguments. +-- * Declaration of the @step()@ function. +compileC :: CSettings -> Spec -> C.TransUnit +compileC cSettings spec = C.TransUnit declns funs + where + declns = mkExts exts + ++ mkGlobals streams + + funs = mkGenFuns streams uniqueTriggers + ++ [mkStep cSettings streams uniqueTriggers exts] + + streams = specStreams spec + triggers = specTriggers spec + uniqueTriggers = mkUniqueTriggers triggers + exts = gatherExts streams triggers + + -- Make declarations for copies of external variables. + mkExts :: [External] -> [C.Decln] + mkExts = map mkExtCpyDecln + + -- Make buffer and index declarations for streams. + mkGlobals :: [Stream] -> [C.Decln] + mkGlobals streamList = map buffDecln streamList + ++ map indexDecln streamList + where + buffDecln (Stream sId buff _ ty) = mkBuffDecln sId ty buff + indexDecln (Stream sId _ _ _ ) = mkIndexDecln sId + + -- Make generator functions, including trigger arguments. + mkGenFuns :: [Stream] -> [UniqueTrigger] -> [C.FunDef] + mkGenFuns streamList triggerList = map accessDecln streamList + ++ map streamGen streamList + ++ concatMap triggerGen triggerList + where + accessDecln :: Stream -> C.FunDef + accessDecln (Stream sId buff _ ty) = mkAccessDecln sId ty buff + + streamGen :: Stream -> C.FunDef + streamGen (Stream sId _ expr ty) = + exprGen (generatorName sId) (generatorOutputArgName sId) expr ty + + triggerGen :: UniqueTrigger -> [C.FunDef] + triggerGen (UniqueTrigger uniqueName (Trigger _name guard args)) = guardDef : argDefs + where + guardDef = mkGenFun (guardName uniqueName) guard Bool + argDefs = zipWith argGen (argNames uniqueName) args + + argGen :: String -> UExpr -> C.FunDef + argGen argName (UExpr ty expr) = + exprGen argName (argName ++ "_output") expr ty + + -- Create a function that calculates the current value generated by an + -- expression `expr` of type `ty`. The generator treats arrays + -- specially, and the function takes an output array as a parameter. + -- The second identifier `outputArrName` is not used if `expr` is not an + -- array. + exprGen :: C.Ident -> C.Ident -> Expr a -> Type a -> C.FunDef + exprGen funName outputArrName expr ty@(Array _) = + mkGenFunArray funName outputArrName expr ty + exprGen funName _ expr ty = + mkGenFun funName expr ty + +-- | Generate the .h file from a 'Spec'. +compileH :: CSettings -> Spec -> C.TransUnit +compileH cSettings spec = C.TransUnit declns [] + where + declns = mkStructForwDeclns exprs + ++ mkExts exts + ++ extFunDeclns triggers + ++ [stepDecln] + + exprs = gatherExprs streams triggers + exts = gatherExts streams triggers + streams = specStreams spec + + -- Remove duplicates due to multiple guards for the same trigger. + triggers = nubBy compareTrigger (specTriggers spec) + + mkStructForwDeclns :: [UExpr] -> [C.Decln] + mkStructForwDeclns es = mapMaybe mkDecln uTypes + where + mkDecln (UType ty) = case ty of + Struct _ -> Just $ mkStructForwDecln ty + _ -> Nothing + + uTypes = nub $ concatMap (\(UExpr _ e) -> exprTypes e) es + + -- Make declarations for external variables. + mkExts :: [External] -> [C.Decln] + mkExts = map mkExtDecln + + extFunDeclns :: [Trigger] -> [C.Decln] + extFunDeclns = map extFunDecln + where + extFunDecln :: Trigger -> C.Decln + extFunDecln (Trigger name _ args) = C.FunDecln Nothing cTy name params + where + cTy = C.TypeSpec C.Void + params = zipWith mkParam (argNames name) args + + mkParam paramName (UExpr ty _) = C.Param (mkParamTy ty) paramName + + -- Special case for Struct, to pass struct arguments by reference. + -- Arrays are also passed by reference, but using C's array type + -- does that automatically. + mkParamTy ty = + case ty of + Struct _ -> C.Ptr (transType ty) + _ -> transType ty + + -- Declaration for the step function. + stepDecln :: C.Decln + stepDecln = C.FunDecln Nothing (C.TypeSpec C.Void) + (cSettingsStepFunctionName cSettings) [] + +-- | Generate a C translation unit that contains all type declarations needed +-- by the Copilot specification. +compileTypeDeclns :: CSettings -> Spec -> C.TransUnit +compileTypeDeclns _cSettings spec = C.TransUnit declns [] + where + declns = mkTypeDeclns exprs + + exprs = gatherExprs streams triggers + streams = specStreams spec + triggers = specTriggers spec + + -- Generate type declarations. + mkTypeDeclns :: [UExpr] -> [C.Decln] + mkTypeDeclns es = mapMaybe mkTypeDecln uTypes + where + uTypes = nub $ concatMap (\(UExpr _ e) -> exprTypes e) es + + mkTypeDecln (UType ty) = case ty of + Struct _ -> Just $ mkStructDecln ty + _ -> Nothing + +-- * Auxiliary definitions + +-- | Render a C.TransUnit to a String, accounting for the case in which the +-- translation unit is empty. +safeCRender :: C.TransUnit -> String +safeCRender (C.TransUnit [] []) = "" +safeCRender transUnit = render $ pretty $ C.translate transUnit + +-- ** Obtain information from Copilot Core Exprs and Types. + +-- | List all types of an expression, returns items uniquely. +exprTypes :: Typeable a => Expr a -> [UType] +exprTypes e = case e of + Const ty _ -> typeTypes ty + Local ty1 ty2 _ e1 e2 -> typeTypes ty1 `union` typeTypes ty2 + `union` exprTypes e1 `union` exprTypes e2 + Var ty _ -> typeTypes ty + Drop ty _ _ -> typeTypes ty + ExternVar ty _ _ -> typeTypes ty + Op1 _ e1 -> exprTypes e1 + Op2 _ e1 e2 -> exprTypes e1 `union` exprTypes e2 + Op3 _ e1 e2 e3 -> exprTypes e1 `union` exprTypes e2 + `union` exprTypes e3 + Label ty _ _ -> typeTypes ty + +-- | List all types of a type, returns items uniquely. +typeTypes :: Typeable a => Type a -> [UType] +typeTypes ty = case ty of + Array ty' -> typeTypes ty' `union` [UType ty] + Struct x -> concatMap (\(Value ty' _) -> typeTypes ty') (toValues x) + `union` [UType ty] + _ -> [UType ty] + +-- | Collect all expression of a list of streams and triggers and wrap them +-- into an UEXpr. +gatherExprs :: [Stream] -> [Trigger] -> [UExpr] +gatherExprs streams triggers = map streamUExpr streams + ++ concatMap triggerUExpr triggers + where + streamUExpr (Stream _ _ expr ty) = UExpr ty expr + triggerUExpr (Trigger _ guard args) = UExpr Bool guard : args + +-- | We consider triggers to be equal, if their names match and the number and +-- types of arguments. +compareTrigger :: Trigger -> Trigger -> Bool +compareTrigger (Trigger name1 _ args1) (Trigger name2 _ args2) + = name1 == name2 && compareArguments args1 args2 + + where + compareArguments :: [UExpr] -> [UExpr] -> Bool + compareArguments [] [] = True + compareArguments [] _ = False + compareArguments _ [] = False + compareArguments (x:xs) (y:ys) = compareUExpr x y && compareArguments xs ys + + compareUExpr :: UExpr -> UExpr -> Bool + compareUExpr (UExpr ty1 _) (UExpr ty2 _) + | Just Refl <- testEquality ty1 ty2 = True + | otherwise = False diff --git a/copilot-c99/src/Copilot/Compile/C99/Compile/Internal.hs b/copilot-c99/src/Copilot/Compile/C99/Compile/Internal.hs deleted file mode 100644 index e2e0d6f41..000000000 --- a/copilot-c99/src/Copilot/Compile/C99/Compile/Internal.hs +++ /dev/null @@ -1,150 +0,0 @@ --- | Compile Copilot specifications to C99 code. -module Copilot.Compile.C99.Compile.Internal - ( compile - , compileWith - ) where - -import Text.PrettyPrint (render) -import Data.List (nub) -import Data.Maybe (catMaybes) -import System.Directory (createDirectoryIfMissing) -import System.FilePath (()) - -import Language.C99.Pretty (pretty) -import qualified Language.C99.Simple as C - -import Copilot.Core -import Copilot.Compile.C99.Util -import Copilot.Compile.C99.External -import Copilot.Compile.C99.Settings.Internal -import Copilot.Compile.C99.Translate -import Copilot.Compile.C99.CodeGen - --- | Compile a specification to a .h and a .c file. --- --- The first argument is the settings for the C code generated. --- --- The second argument is used as prefix for the .h and .c files generated. -compileWith :: CSettings -> String -> Spec -> IO () -compileWith cSettings prefix spec = do - let cfile = render $ pretty $ C.translate $ compilec cSettings spec - hfile = render $ pretty $ C.translate $ compileh cSettings spec - - -- TODO: find a nicer solution using annotated AST's - -- Should figure out exactly which headers are needed, based on what - -- is used. - cmacros = unlines [ "#include " - , "#include " - , "#include " - , "#include " - , "#include " - , "" - , "#include \"" ++ prefix ++ ".h\"" - , "" - ] - - let dir = cSettingsOutputDirectory cSettings - createDirectoryIfMissing True dir - writeFile (dir prefix ++ ".c") $ cmacros ++ cfile - writeFile (dir prefix ++ ".h") hfile - --- | Compile a specification to a .h and a .c file. --- --- The first argument is used as prefix for the .h and .c files generated. -compile :: String -> Spec -> IO () -compile = compileWith mkDefaultCSettings - --- | Generate the .c file from a 'Spec'. --- --- The generated C file has the following structure: --- --- * Include .h file. --- * Declarations of global buffers and indices. --- * Generator functions for streams, guards and trigger arguments. --- * Declaration of the @step()@ function. -compilec :: CSettings -> Spec -> C.TransUnit -compilec cSettings spec = C.TransUnit declns funs where - streams = specStreams spec - triggers = specTriggers spec - exts = gatherexts streams triggers - exprs = gatherexprs streams triggers - - declns = mkstructdeclns exprs ++ mkexts exts ++ mkglobals streams - funs = genfuns streams triggers ++ [mkstep cSettings streams triggers exts] - - -- Write struct datatypes - mkstructdeclns :: [UExpr] -> [C.Decln] - mkstructdeclns es = catMaybes $ map mkdecln utypes where - mkdecln (UType ty) = case ty of - Struct x -> Just $ mkstructdecln ty - _ -> Nothing - - utypes = nub $ concatMap (\(UExpr _ e) -> exprtypes e) es - - -- Make declarations for copies of external variables. - mkexts :: [External] -> [C.Decln] - mkexts exts = map mkextcpydecln exts - - -- Make buffer and index declarations for streams. - mkglobals :: [Stream] -> [C.Decln] - mkglobals streams = map buffdecln streams ++ map indexdecln streams where - buffdecln (Stream sid buff _ ty) = mkbuffdecln sid ty buff - indexdecln (Stream sid _ _ _ ) = mkindexdecln sid - - -- Make generator functions, including trigger arguments. - genfuns :: [Stream] -> [Trigger] -> [C.FunDef] - genfuns streams triggers = map accessdecln streams - ++ map streamgen streams - ++ concatMap triggergen triggers where - - accessdecln :: Stream -> C.FunDef - accessdecln (Stream sid buff _ ty) = mkaccessdecln sid ty buff - - streamgen :: Stream -> C.FunDef - streamgen (Stream sid _ expr ty) = genfun (generatorname sid) expr ty - - triggergen :: Trigger -> [C.FunDef] - triggergen (Trigger name guard args) = guarddef : argdefs where - guarddef = genfun (guardname name) guard Bool - argdefs = map arggen (zip (argnames name) args) - - arggen :: (String, UExpr) -> C.FunDef - arggen (argname, UExpr ty expr) = genfun argname expr ty - --- | Generate the .h file from a 'Spec'. -compileh :: CSettings -> Spec -> C.TransUnit -compileh cSettings spec = C.TransUnit declns [] where - streams = specStreams spec - triggers = specTriggers spec - exts = gatherexts streams triggers - exprs = gatherexprs streams triggers - - declns = mkstructforwdeclns exprs - ++ mkexts exts - ++ extfundeclns triggers - ++ [stepdecln] - - mkstructforwdeclns :: [UExpr] -> [C.Decln] - mkstructforwdeclns es = catMaybes $ map mkdecln utypes where - mkdecln (UType ty) = case ty of - Struct x -> Just $ mkstructforwdecln ty - _ -> Nothing - - utypes = nub $ concatMap (\(UExpr _ e) -> exprtypes e) es - - -- Make declarations for external variables. - mkexts :: [External] -> [C.Decln] - mkexts = map mkextdecln - - extfundeclns :: [Trigger] -> [C.Decln] - extfundeclns triggers = map extfundecln triggers where - extfundecln :: Trigger -> C.Decln - extfundecln (Trigger name _ args) = C.FunDecln Nothing cty name params where - cty = C.TypeSpec C.Void - params = map mkparam $ zip (argnames name) args - mkparam (name, UExpr ty _) = C.Param (transtype ty) name - - -- Declaration for the step function. - stepdecln :: C.Decln - stepdecln = C.FunDecln Nothing (C.TypeSpec C.Void) - (cSettingsStepFunctionName cSettings) [] diff --git a/copilot-c99/src/Copilot/Compile/C99/Error.hs b/copilot-c99/src/Copilot/Compile/C99/Error.hs new file mode 100644 index 000000000..8ab2de608 --- /dev/null +++ b/copilot-c99/src/Copilot/Compile/C99/Error.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE Safe #-} + +-- | +-- Copyright: (c) 2011 National Institute of Aerospace / Galois, Inc. +-- +-- Custom functions to report error messages to users. +module Copilot.Compile.C99.Error + ( impossible + , errorEmptyStruct + , errorZeroLengthArray + ) + where + +-- | Report an error due to a bug in Copilot. +impossible :: String -- ^ Name of the function in which the error was detected. + -> String -- ^ Name of the package in which the function is located. + -> a +impossible function package = + error $ "Impossible error in function " + ++ function ++ ", in package " ++ package + ++ ". Please file an issue at " + ++ "https://github.com/Copilot-Language/copilot/issues" + ++ " or email the maintainers at " + +-- | Report an error when attempting to compile a zero-length array to C99. +-- C99 does not support zero-length arrays, so Copilot cannot compile +-- specifications that use them. +errorZeroLengthArray :: a +errorZeroLengthArray = + error "copilot-c99: Cannot compile zero-length arrays to C99.\n" + +-- | Report an error when attempting to compile an empty struct to C99. +-- C99 does not support empty structs, so Copilot cannot compile +-- specifications that use them. +errorEmptyStruct :: a +errorEmptyStruct = + error "copilot-c99: Cannot compile empty structs to C99.\n" diff --git a/copilot-c99/src/Copilot/Compile/C99/Expr.hs b/copilot-c99/src/Copilot/Compile/C99/Expr.hs new file mode 100644 index 000000000..fec731fbf --- /dev/null +++ b/copilot-c99/src/Copilot/Compile/C99/Expr.hs @@ -0,0 +1,490 @@ +{-# LANGUAGE GADTs #-} + +-- | Translate Copilot Core expressions and operators to C99. +module Copilot.Compile.C99.Expr + ( transExpr + , constArray + ) + where + +-- External imports +import Control.Monad.State ( State, get, modify ) +import qualified Data.List.NonEmpty as NonEmpty +import qualified Language.C99.Simple as C + +-- Internal imports: Copilot +import Copilot.Core ( Array, Expr (..), Field (..), Op1 (..), Op2 (..), + Op3 (..), Type (..), Value (..), accessorName, + arrayElems, toValues, typeLength, typeSize ) + +-- Internal imports +import Copilot.Compile.C99.Error ( impossible, errorEmptyStruct, errorZeroLengthArray ) +import Copilot.Compile.C99.Name ( exCpyName, streamAccessorName ) +import Copilot.Compile.C99.Type ( transLocalVarDeclType, transType, + transTypeName ) + +-- | Translates a Copilot Core expression into a C99 expression. +transExpr :: Expr a -> State FunEnv C.Expr +transExpr (Const ty x) = return $ constTy ty x + +transExpr (Local ty1 _ name e1 e2) = do + e1' <- transExpr e1 + let cTy1 = transLocalVarDeclType ty1 + initExpr = Just $ C.InitExpr e1' + + -- Add new decl to the tail of the fun env + modify (\(i, x, y) + -> (i, x ++ [C.VarDecln Nothing cTy1 name initExpr], y) + ) + + transExpr e2 + +transExpr (Var _ n) = return $ C.Ident n + +transExpr (Drop _ amount sId) = do + let accessVar = streamAccessorName sId + index = C.LitInt (fromIntegral amount) + return $ funCall accessVar [index] + +transExpr (ExternVar _ name _) = return $ C.Ident (exCpyName name) + +transExpr (Label _ _ e) = transExpr e -- ignore label + +transExpr (Op1 op e) = do + e' <- transExpr e + return $ transOp1 op e' + +transExpr (Op2 (UpdateField ty1@(Struct _) ty2 f) e1 e2) = do + -- Translating a struct update Op requires initializing a variable to the + -- "old" value, updating the field, and returning the new value. + e1' <- transExpr e1 + e2' <- transExpr e2 + + -- Variable to hold the updated struct + (i, _, _) <- get + let varName = "_v" ++ show i + modify (\(i, x, y) -> (i + 1, x, y)) + + -- Add new var decl + let initDecl = C.VarDecln Nothing cTy1 varName Nothing + cTy1 = transLocalVarDeclType ty1 + modify (\(i, x, y) -> (i, x ++ [initDecl], y)) + + -- Initialize the var to the same value as the original struct + let initStmt = C.Expr + $ C.AssignOp + C.Assign + (C.Ident varName) + e1' + + -- Update field f with given value e2. + let updateStmt = case ty2 of + Array _ -> C.Expr $ memcpy dest e2' size + where + dest = C.Dot (C.Ident varName) (accessorName f) + size = C.LitInt + (fromIntegral $ typeSize ty2) + C..* C.SizeOfType (C.TypeName (tyElemName ty2)) + + _ -> C.Expr + $ C.AssignOp + C.Assign + (C.Dot (C.Ident varName) (accessorName f)) + e2' + + modify (\(i, x, y) -> (i, x, y ++ [ initStmt, updateStmt ])) + + return $ C.Ident varName + +transExpr (Op2 op e1 e2) = do + e1' <- transExpr e1 + e2' <- transExpr e2 + return $ transOp2 op e1' e2' + +transExpr e@(Op3 (UpdateArray arrTy@(Array ty2)) e1 e2 e3) = do + e1' <- transExpr e1 + e2' <- transExpr e2 + e3' <- transExpr e3 + + -- Variable to hold the updated array + (i, _, _) <- get + let varName = "_v" ++ show i + modify (\(i, x, y) -> (i + 1, x, y)) + + -- Add new var decl + let initDecl = C.VarDecln Nothing cTy1 varName Nothing + cTy1 = transType arrTy + modify (\(i, x, y) -> (i, x ++ [initDecl], y)) + + let size :: Type (Array n t) -> C.Expr + size arrTy@(Array ty) = C.LitInt (fromIntegral $ typeLength arrTy) + C..* C.SizeOfType (C.TypeName $ transType ty) + + -- Initialize the var to the same value as the original array + let initStmt = C.Expr $ memcpy (C.Ident varName) e1' (size arrTy) + + -- Update element of array + let updateStmt = case ty2 of + Array _ -> C.Expr $ memcpy dest e3' size + where + dest = C.Index (C.Ident varName) e2' + size = C.LitInt + (fromIntegral $ typeSize ty2) + C..* C.SizeOfType (C.TypeName (tyElemName ty2)) + + _ -> C.Expr + $ C.AssignOp + C.Assign + (C.Index (C.Ident varName) e2') + e3' + + modify (\(i, x, y) -> (i, x, y ++ [ initStmt, updateStmt ])) + + return $ C.Ident varName + +transExpr (Op3 op e1 e2 e3) = do + e1' <- transExpr e1 + e2' <- transExpr e2 + e3' <- transExpr e3 + return $ transOp3 op e1' e2' e3' + +-- | Translates a Copilot unary operator and its argument into a C99 +-- expression. +transOp1 :: Op1 a b -> C.Expr -> C.Expr +transOp1 op e = + -- There are three types of ways in which a function in Copilot Core can be + -- translated into C: + -- + -- 1) Direct translation (perfect 1-to-1 mapping) + -- 2) Type-directed translation (1-to-many mapping, choice based on type) + -- 3) Desugaring/complex (expands to complex expression) + case op of + Not -> (C..!) e + Abs ty -> transAbs ty e + Sign ty -> transSign ty e + Recip ty -> constNumTy ty 1 C../ e + Acos ty -> funCall (specializeMathFunName ty "acos") [e] + Asin ty -> funCall (specializeMathFunName ty "asin") [e] + Atan ty -> funCall (specializeMathFunName ty "atan") [e] + Cos ty -> funCall (specializeMathFunName ty "cos") [e] + Sin ty -> funCall (specializeMathFunName ty "sin") [e] + Tan ty -> funCall (specializeMathFunName ty "tan") [e] + Acosh ty -> funCall (specializeMathFunName ty "acosh") [e] + Asinh ty -> funCall (specializeMathFunName ty "asinh") [e] + Atanh ty -> funCall (specializeMathFunName ty "atanh") [e] + Cosh ty -> funCall (specializeMathFunName ty "cosh") [e] + Sinh ty -> funCall (specializeMathFunName ty "sinh") [e] + Tanh ty -> funCall (specializeMathFunName ty "tanh") [e] + Exp ty -> funCall (specializeMathFunName ty "exp") [e] + Log ty -> funCall (specializeMathFunName ty "log") [e] + Sqrt ty -> funCall (specializeMathFunName ty "sqrt") [e] + Ceiling ty -> funCall (specializeMathFunName ty "ceil") [e] + Floor ty -> funCall (specializeMathFunName ty "floor") [e] + BwNot _ -> (C..~) e + Cast _ ty -> C.Cast (transTypeName ty) e + GetField (Struct _) _ f -> C.Dot e (accessorName f) + +-- | Translates a Copilot binary operator and its arguments into a C99 +-- expression. +-- +-- PRE: op is not a struct update operation (i.e., 'UpdateField'). +transOp2 :: Op2 a b c -> C.Expr -> C.Expr -> C.Expr +transOp2 op e1 e2 = case op of + And -> e1 C..&& e2 + Or -> e1 C..|| e2 + Add _ -> e1 C..+ e2 + Sub _ -> e1 C..- e2 + Mul _ -> e1 C..* e2 + Mod _ -> e1 C..% e2 + Div _ -> e1 C../ e2 + Fdiv _ -> e1 C../ e2 + Pow ty -> funCall (specializeMathFunName ty "pow") [e1, e2] + Logb ty -> funCall (specializeMathFunName ty "log") [e2] C../ + funCall (specializeMathFunName ty "log") [e1] + Atan2 ty -> funCall (specializeMathFunName ty "atan2") [e1, e2] + Eq _ -> e1 C..== e2 + Ne _ -> e1 C..!= e2 + Le _ -> e1 C..<= e2 + Ge _ -> e1 C..>= e2 + Lt _ -> e1 C..< e2 + Gt _ -> e1 C..> e2 + BwAnd _ -> e1 C..& e2 + BwOr _ -> e1 C..| e2 + BwXor _ -> e1 C..^ e2 + BwShiftL _ _ -> e1 C..<< e2 + BwShiftR _ _ -> e1 C..>> e2 + Index _ -> C.Index e1 e2 + UpdateField _ _ _ -> impossible "transOp2" "copilot-c99" + +-- | Translates a Copilot ternary operator and its arguments into a C99 +-- expression. +transOp3 :: Op3 a b c d -> C.Expr -> C.Expr -> C.Expr -> C.Expr +transOp3 op e1 e2 e3 = case op of + Mux _ -> C.Cond e1 e2 e3 + UpdateArray _ -> impossible "transOp3" "copilot-c99" + +-- | Translate @'Abs' e@ in Copilot Core into a C99 expression. +-- +-- This function produces a portable implementation of abs in C99 that works +-- for the type given, provided that the output fits in a variable of the same +-- type (which may not be true, for example, for signed integers in the lower +-- end of their type range). If the absolute value is out of range, the +-- behavior is undefined. +-- +-- PRE: The type given is a Num type (floating-point number, or a +-- signed/unsigned integer of fixed size). +transAbs :: Type a -> C.Expr -> C.Expr +transAbs ty e + -- Abs for floats/doubles is called fabs in C99's math.h. + | typeIsFloating ty + = funCall (specializeMathFunName ty "fabs") [e] + + -- C99 provides multiple implementations of abs, depending on the type of + -- the arguments. For integers, it provides C99 abs, labs, and llabs, which + -- take, respectively, an int, a long int, and a long long int. + -- + -- However, the code produced by Copilot uses types with fixed width (e.g., + -- int16_t), and there is no guarantee that, for example, 32-bit int or + -- 64-bit int will fit in a C int (only guaranteed to be 16 bits). + -- Consequently, this function provides a portable version of abs for signed + -- and unsigned ints implemented using shift and xor. For example, for a + -- value x of type int32_t, the absolute value is: + -- (x + (x >> sizeof(int32_t)-1)) ^ (x >> sizeof(int32_t)-1)) + | otherwise + = (e C..+ (e C..>> tyBitSizeMinus1)) C..^ (e C..>> tyBitSizeMinus1) + where + -- Size of an integer type in bits, minus one. It's easier to hard-code + -- them than to try and generate the right expressions in C using sizeof. + -- + -- PRE: the type 'ty' is a signed or unsigned integer type. + tyBitSizeMinus1 :: C.Expr + tyBitSizeMinus1 = case ty of + Int8 -> C.LitInt 7 + Int16 -> C.LitInt 15 + Int32 -> C.LitInt 31 + Int64 -> C.LitInt 63 + Word8 -> C.LitInt 7 + Word16 -> C.LitInt 15 + Word32 -> C.LitInt 31 + Word64 -> C.LitInt 63 + _ -> impossible + "transAbs" + "copilot-c99" + "Abs applied to unexpected types." + +-- | Translate @'Sign' e@ in Copilot Core into a C99 expression. +-- +-- Sign is is translated as @e > 0 ? 1 : (e < 0 ? -1 : e)@, that is: +-- +-- 1. If @e@ is positive, return @1@. +-- +-- 2. If @e@ is negative, return @-1@. +-- +-- 3. Otherwise, return @e@. This handles the case where @e@ is @0@ when the +-- type is an integral type. If the type is a floating-point type, it also +-- handles the cases where @e@ is @-0@ or @NaN@. +-- +-- This implementation is modeled after how GHC implements 'signum' +-- . +transSign :: Type a -> C.Expr -> C.Expr +transSign ty e = positiveCase $ negativeCase e + where + -- If @e@ is positive, return @1@, otherwise fall back to argument. + -- + -- Produces the following code, where @@ is the argument to this + -- function: + -- @ + -- e > 0 ? 1 : + -- @ + positiveCase :: C.Expr -- ^ Value returned if @e@ is not positive. + -> C.Expr + positiveCase = + C.Cond (C.BinaryOp C.GT e (constNumTy ty 0)) (constNumTy ty 1) + + -- If @e@ is negative, return @1@, otherwise fall back to argument. + -- + -- Produces the following code, where @@ is the argument to this + -- function: + -- @ + -- e < 0 ? -1 : + -- @ + negativeCase :: C.Expr -- ^ Value returned if @e@ is not negative. + -> C.Expr + negativeCase = + C.Cond (C.BinaryOp C.LT e (constNumTy ty 0)) (constNumTy ty (-1)) + +-- | Transform a Copilot Core literal, based on its value and type, into a C99 +-- literal. +constTy :: Type a -> a -> C.Expr +constTy ty = case ty of + Bool -> C.LitBool + Int8 -> explicitTy ty . C.LitInt . fromIntegral + Int16 -> explicitTy ty . C.LitInt . fromIntegral + Int32 -> explicitTy ty . C.LitInt . fromIntegral + Int64 -> explicitTy ty . C.LitInt . fromIntegral + Word8 -> explicitTy ty . C.LitInt . fromIntegral + Word16 -> explicitTy ty . C.LitInt . fromIntegral + Word32 -> explicitTy ty . C.LitInt . fromIntegral + Word64 -> explicitTy ty . C.LitInt . fromIntegral + Float -> explicitTy ty . C.LitFloat + Double -> explicitTy ty . C.LitDouble + Struct _ -> C.InitVal (transTypeName ty) . constStruct . toValues + Array ty' -> C.InitVal (transTypeName ty) . constArray ty' . arrayElems + +-- | Transform a Copilot Core literal, based on its value and type, into a C99 +-- initializer. +constInit :: Type a -> a -> C.Init +constInit ty val = case ty of + -- We include two special cases for Struct and Array to avoid using constTy + -- on them. + -- + -- In the default case (i.e., InitExpr (constTy ty val)), constant + -- initializations are explicitly cast. However, doing so 1) may result in + -- incorrect values for arrays, and 2) will be considered a non-constant + -- expression in the case of arrays and structs, and thus not allowed as the + -- initialization value for a global variable. + -- + -- In particular, wrt. (1), for example, the nested array: + -- [[0, 1], [2, 3]] :: Array 2 (Array 2 Int32) + -- + -- with explicit casts, will be initialized in C as: + -- { (int32_t[2]){(int32_t)(0), (int32_t)(1)}, + -- (int32_t[2]){(int32_t)(2), (int32_t)(3)} } + -- + -- Due to the additional (int32_t[2]) casts, a C compiler will interpret the + -- whole expression as an array of two int32_t's (as opposed to a nested + -- array). This can either lead to compile-time errors (if you're lucky) or + -- incorrect runtime semantics (if you're unlucky). + Array ty' -> C.InitList $ constArray ty' $ arrayElems val + + -- We use InitArray to initialize a struct because the syntax used for + -- initializing arrays and structs is compatible. For instance, {1, 2} works + -- both for initializing an int array of length 2 as well as a struct with + -- two int fields, although the two expressions are conceptually different + -- (structs can also be initialized as { .a = 1, .b = 2}. + Struct _ -> C.InitList $ constStruct (toValues val) + _ -> C.InitExpr $ constTy ty val + +-- | Transform a Copilot Core struct field into a C99 initializer. +constFieldInit :: Value a -> C.InitItem +constFieldInit (Value ty (Field val)) = C.InitItem Nothing $ constInit ty val + +-- | Transform a Copilot Struct, based on the struct fields, into a list of C99 +-- initializer values. +-- +-- Raises an error if the struct is empty, as C99 does not support structs with +-- no fields. +constStruct :: [Value a] -> NonEmpty.NonEmpty C.InitItem +constStruct val = case val of + [] -> errorEmptyStruct + _ -> NonEmpty.fromList $ map constFieldInit val + +-- | Transform a Copilot Array, based on the element values and their type, +-- into a list of C99 initializer values. +-- +-- Raises an error if the array is empty, as C99 does not support zero-length +-- arrays. +constArray :: Type a -> [a] -> NonEmpty.NonEmpty C.InitItem +constArray ty xs = case xs of + [] -> errorZeroLengthArray + _ -> NonEmpty.fromList $ map (C.InitItem Nothing . constInit ty) xs + +-- | Explicitly cast a C99 value to a type. +explicitTy :: Type a -> C.Expr -> C.Expr +explicitTy ty = C.Cast (transTypeName ty) + +-- Translate a literal number of type @ty@ into a C99 literal. +-- +-- PRE: The type of PRE is numeric (integer or floating-point), that +-- is, not boolean, struct or array. +constNumTy :: Type a -> Integer -> C.Expr +constNumTy ty = + case ty of + Float -> C.LitFloat . fromInteger + Double -> C.LitDouble . fromInteger + _ -> C.LitInt + +-- | Provide a specialized function name in C99 for a function given the type +-- of its arguments, and its "family" name. +-- +-- C99 provides multiple variants of the same conceptual function, based on the +-- types. Depending on the function, common variants exist for signed/unsigned +-- arguments, long or short types, float or double. The C99 standard uses the +-- same mechanism to name most such functions: the default variant works for +-- double, and there are additional variants for float and long double. For +-- example, the sin function operates on double, while sinf operates on float, +-- and sinl operates on long double. +-- +-- This function only knows how to provide specialized names for functions in +-- math.h that provide a default version for a double argument and vary for +-- floats. It won't change the function name given if the variation is based on +-- the return type, if the function is defined elsewhere, or for other types. +specializeMathFunName :: Type a -> String -> String +specializeMathFunName ty s + -- The following function pattern matches based on the variants available + -- for a specific function. + -- + -- Do not assume that a function you need implemented follows the same + -- standard as others: check whether it is present in the standard. + | isMathFPArgs s + , Float <- ty + = s ++ "f" + + | otherwise + = s + where + -- True if the function family name is part of math.h and follows the + -- standard rule of providing multiple variants for floating point numbers + -- based on the type of their arguments. + -- + -- Note: nan is not in this list because the names of its variants are + -- determined by the return type. + -- + -- For details, see: + -- "B.11 Mathematics " in the C99 standard + isMathFPArgs :: String -> Bool + isMathFPArgs = flip elem + [ "acos", "asin", "atan", "atan2", "cos", "sin" + , "tan", "acosh", "asinh", "atanh", "cosh", "sinh" + , "tanh", "exp", "exp2", "expm1", "frexp", "ilogb" + , "ldexp", "log", "log10", "log1p", "log2", "logb" + , "modf", "scalbn", "scalbln", "cbrt", "fabs", "hypot" + , "pow", "sqrt", "erf", "erfc", "lgamma", "tgamma" + , "ceil", "floor", "nearbyint", "rint", "lrint", "llrint" + , "round", "lround", "llround", "trunc", "fmod", "remainder" + , "remquo", "copysign", "nextafter", "nexttoward", "fdim" + , "fmax", "fmin", "fma" + ] + +-- * Auxiliary functions + +-- | True if the type given is a floating point number. +typeIsFloating :: Type a -> Bool +typeIsFloating Float = True +typeIsFloating Double = True +typeIsFloating _ = False + +-- | Auxiliary type used to collect all the declarations of all the variables +-- used in a function to be generated, since variable declarations are always +-- listed first at the top of the function body. +type FunEnv = (Int, [C.Decln], [C.Stmt]) + +-- | Define a C expression that calls a function with arguments. +funCall :: C.Ident -- ^ Function name + -> [C.Expr] -- ^ Arguments + -> C.Expr +funCall name = C.Funcall (C.Ident name) + +-- Write a call to the memcpy function. +memcpy :: C.Expr -> C.Expr -> C.Expr -> C.Expr +memcpy dest src size = C.Funcall (C.Ident "memcpy") [dest, src, size] + +-- Translate a Copilot type to a C99 type, handling arrays especially. +-- +-- If the given type is an array (including multi-dimensional arrays), the +-- type is that of the elements in the array. Otherwise, it is just the +-- equivalent representation of the given type in C. +tyElemName :: Type a -> C.Type +tyElemName ty = case ty of + Array ty' -> tyElemName ty' + _ -> transType ty diff --git a/copilot-c99/src/Copilot/Compile/C99/External.hs b/copilot-c99/src/Copilot/Compile/C99/External.hs index 9ef023d08..8d8080451 100644 --- a/copilot-c99/src/Copilot/Compile/C99/External.hs +++ b/copilot-c99/src/Copilot/Compile/C99/External.hs @@ -3,52 +3,60 @@ -- | Represent information about externs needed in the generation of C99 code -- for stream declarations and triggers. module Copilot.Compile.C99.External - {-# DEPRECATED "This module will be hidden in future versions." #-} + ( External(..) + , gatherExts + ) where +-- External imports import Data.List (unionBy) -import Copilot.Core -import Copilot.Compile.C99.Util +-- Internal imports: Copilot +import Copilot.Core ( Expr (..), Stream (..), Trigger (..), Type, UExpr (..) ) + +-- Internal imports +import Copilot.Compile.C99.Name ( exCpyName ) -- | Representation of external variables. data External = forall a. External - { extname :: String - , extcpyname :: String - , exttype :: Type a + { extName :: String + , extCpyName :: String + , extType :: Type a } --- | Union over lists of External, we solely base the equality on the --- extname's. -extunion :: [External] -> [External] -> [External] -extunion = unionBy (\a b -> extname a == extname b) - -- | Collect all external variables from the streams and triggers. -- -- Although Copilot specifications can contain also properties and theorems, -- the C99 backend currently only generates code for streams and triggers. -gatherexts :: [Stream] -> [Trigger] -> [External] -gatherexts streams triggers = streamsexts `extunion` triggersexts where - streamsexts = foldr extunion mempty $ map streamexts streams - triggersexts = foldr extunion mempty $ map triggerexts triggers - - streamexts :: Stream -> [External] - streamexts (Stream _ _ expr _) = exprexts expr - - triggerexts :: Trigger -> [External] - triggerexts (Trigger _ guard args) = guardexts `extunion` argexts where - guardexts = exprexts guard - argexts = concat $ map uexprexts args - - uexprexts :: UExpr -> [External] - uexprexts (UExpr _ expr) = exprexts expr - - exprexts :: Expr a -> [External] - exprexts expr = let rec = exprexts in case expr of - Local _ _ _ e1 e2 -> rec e1 `extunion` rec e2 - ExternVar ty name _ -> [External name (excpyname name) ty] - Op1 _ e -> rec e - Op2 _ e1 e2 -> rec e1 `extunion` rec e2 - Op3 _ e1 e2 e3 -> rec e1 `extunion` rec e2 `extunion` rec e3 - Label _ _ e -> rec e - _ -> [] +gatherExts :: [Stream] -> [Trigger] -> [External] +gatherExts streams triggers = streamsExts `extUnion` triggersExts + where + streamsExts = foldr (extUnion . streamExts) mempty streams + triggersExts = foldr (extUnion . triggerExts) mempty triggers + + streamExts :: Stream -> [External] + streamExts (Stream _ _ expr _) = exprExts expr + + triggerExts :: Trigger -> [External] + triggerExts (Trigger _ guard args) = guardExts `extUnion` argExts + where + guardExts = exprExts guard + argExts = concatMap uExprExts args + + uExprExts :: UExpr -> [External] + uExprExts (UExpr _ expr) = exprExts expr + + exprExts :: Expr a -> [External] + exprExts (Local _ _ _ e1 e2) = exprExts e1 `extUnion` exprExts e2 + exprExts (ExternVar ty name _) = [External name (exCpyName name) ty] + exprExts (Op1 _ e) = exprExts e + exprExts (Op2 _ e1 e2) = exprExts e1 `extUnion` exprExts e2 + exprExts (Op3 _ e1 e2 e3) = exprExts e1 `extUnion` exprExts e2 + `extUnion` exprExts e3 + exprExts (Label _ _ e) = exprExts e + exprExts _ = [] + + -- | Union over lists of External, we solely base the equality on the + -- extName's. + extUnion :: [External] -> [External] -> [External] + extUnion = unionBy (\a b -> extName a == extName b) diff --git a/copilot-c99/src/Copilot/Compile/C99/Name.hs b/copilot-c99/src/Copilot/Compile/C99/Name.hs new file mode 100644 index 000000000..bebaf6bea --- /dev/null +++ b/copilot-c99/src/Copilot/Compile/C99/Name.hs @@ -0,0 +1,61 @@ +-- | Naming of variables and functions in C. +module Copilot.Compile.C99.Name + ( argNames + , argTempNames + , exCpyName + , generatorName + , generatorOutputArgName + , guardName + , indexName + , streamAccessorName + , streamName + ) + where + +-- External imports: Copilot +import Copilot.Core (Id) + +-- | Turn a stream id into a suitable C variable name. +streamName :: Id -> String +streamName sId = "s" ++ show sId + +-- | Turn a stream id into the global varname for indices. +indexName :: Id -> String +indexName sId = streamName sId ++ "_idx" + +-- | Turn a stream id into the name of its accessor function +streamAccessorName :: Id -> String +streamAccessorName sId = streamName sId ++ "_get" + +-- | Add a postfix for copies of external variables the name. +exCpyName :: String -> String +exCpyName name = name ++ "_cpy" + +-- | Turn stream id into name of its generator function. +generatorName :: Id -> String +generatorName sId = streamName sId ++ "_gen" + +-- | Turn stream id into name of its output argument array. +generatorOutputArgName :: Id -> String +generatorOutputArgName sId = streamName sId ++ "_output" + +-- | Turn the name of a trigger into a guard generator. +guardName :: String -> String +guardName name = name ++ "_guard" + +-- | Turn a trigger name into a trigger argument name. +argName :: String -> Int -> String +argName name n = name ++ "_arg" ++ show n + +-- | Turn a handler function name into a name for a temporary variable for a +-- handler argument. +argTempName :: String -> Int -> String +argTempName name n = name ++ "_arg_temp" ++ show n + +-- | Enumerate all argument names based on trigger name. +argNames :: String -> [String] +argNames base = map (argName base) [0..] + +-- | Enumerate all temporary variable names based on handler function name. +argTempNames :: String -> [String] +argTempNames base = map (argTempName base) [0..] diff --git a/copilot-c99/src/Copilot/Compile/C99/Representation.hs b/copilot-c99/src/Copilot/Compile/C99/Representation.hs new file mode 100644 index 000000000..886808a8a --- /dev/null +++ b/copilot-c99/src/Copilot/Compile/C99/Representation.hs @@ -0,0 +1,21 @@ +-- | C99 backend specific versions of selected `Copilot.Core` datatypes. +module Copilot.Compile.C99.Representation + ( UniqueTrigger (..) + , UniqueTriggerId + , mkUniqueTriggers + ) + where + +import Copilot.Core ( Trigger (..) ) + +-- | Internal unique name for a trigger. +type UniqueTriggerId = String + +-- | A `Copilot.Core.Trigger` with an unique name. +data UniqueTrigger = UniqueTrigger UniqueTriggerId Trigger + +-- | Given a list of triggers, make their names unique. +mkUniqueTriggers :: [Trigger] -> [UniqueTrigger] +mkUniqueTriggers ts = zipWith mkUnique ts [0..] + where + mkUnique t@(Trigger name _ _) n = UniqueTrigger (name ++ "_" ++ show n) t diff --git a/copilot-c99/src/Copilot/Compile/C99/Settings.hs b/copilot-c99/src/Copilot/Compile/C99/Settings.hs index 265885e92..bb52271ae 100644 --- a/copilot-c99/src/Copilot/Compile/C99/Settings.hs +++ b/copilot-c99/src/Copilot/Compile/C99/Settings.hs @@ -1,8 +1,16 @@ -- | Settings used by the code generator to customize the code. module Copilot.Compile.C99.Settings - {-# DEPRECATED "This module will be hidden in future versions." #-} - (module Copilot.Compile.C99.Settings.Internal) - where + ( CSettings(..) + , mkDefaultCSettings + ) + where -import Copilot.Compile.C99.Settings.Internal +-- | Settings used to customize the code generated. +data CSettings = CSettings + { cSettingsStepFunctionName :: String + , cSettingsOutputDirectory :: FilePath + } +-- | Default settings with a step function called @step@. +mkDefaultCSettings :: CSettings +mkDefaultCSettings = CSettings "step" "." diff --git a/copilot-c99/src/Copilot/Compile/C99/Settings/Internal.hs b/copilot-c99/src/Copilot/Compile/C99/Settings/Internal.hs deleted file mode 100644 index 4e936acc2..000000000 --- a/copilot-c99/src/Copilot/Compile/C99/Settings/Internal.hs +++ /dev/null @@ -1,12 +0,0 @@ --- | Settings used by the code generator to customize the code. -module Copilot.Compile.C99.Settings.Internal where - --- | Settings used to customize the code generated. -data CSettings = CSettings - { cSettingsStepFunctionName :: String - , cSettingsOutputDirectory :: FilePath - } - --- | Default settings with a step function called @step@. -mkDefaultCSettings :: CSettings -mkDefaultCSettings = CSettings "step" "." diff --git a/copilot-c99/src/Copilot/Compile/C99/Translate.hs b/copilot-c99/src/Copilot/Compile/C99/Translate.hs deleted file mode 100644 index 3d2fd0e66..000000000 --- a/copilot-c99/src/Copilot/Compile/C99/Translate.hs +++ /dev/null @@ -1,169 +0,0 @@ -{-# LANGUAGE GADTs #-} - --- | Translate Copilot Core expressions and operators to C99. -module Copilot.Compile.C99.Translate - {-# DEPRECATED "This module will be hidden in future versions." #-} - where - -import Control.Monad.State - -import Copilot.Core -import Copilot.Compile.C99.Util - -import qualified Language.C99.Simple as C - --- | Translates a Copilot Core expression into a C99 expression. -transexpr :: Expr a -> State FunEnv C.Expr -transexpr (Const ty x) = return $ constty ty x - -transexpr (Local ty1 _ name e1 e2) = do - e1' <- transexpr e1 - let cty1 = transtype ty1 - init = Just $ C.InitExpr e1' - statetell [C.VarDecln Nothing cty1 name init] - - transexpr e2 - -transexpr (Var _ n) = return $ C.Ident n - -transexpr (Drop _ amount sid) = do - let accessvar = streamaccessorname sid - index = C.LitInt (fromIntegral amount) - return $ funcall accessvar [index] - -transexpr (ExternVar _ name _) = return $ C.Ident (excpyname name) - -transexpr (Label _ _ e) = transexpr e -- ignore label - -transexpr (Op1 op e) = do - e' <- transexpr e - return $ transop1 op e' - -transexpr (Op2 op e1 e2) = do - e1' <- transexpr e1 - e2' <- transexpr e2 - return $ transop2 op e1' e2' - -transexpr (Op3 op e1 e2 e3) = do - e1' <- transexpr e1 - e2' <- transexpr e2 - e3' <- transexpr e3 - return $ transop3 op e1' e2' e3' - - --- | Translates a Copilot unary operator and its argument into a C99 --- expression. -transop1 :: Op1 a b -> C.Expr -> C.Expr -transop1 op e = case op of - Not -> (C..!) e - Abs _ -> funcall "abs" [e] - Sign _ -> funcall "copysign" [C.LitDouble 1.0, e] - Recip _ -> C.LitDouble 1.0 C../ e - Exp _ -> funcall "exp" [e] - Sqrt _ -> funcall "sqrt" [e] - Log _ -> funcall "log" [e] - Sin _ -> funcall "sin" [e] - Tan _ -> funcall "tan" [e] - Cos _ -> funcall "cos" [e] - Asin _ -> funcall "asin" [e] - Atan _ -> funcall "atan" [e] - Acos _ -> funcall "acos" [e] - Sinh _ -> funcall "sinh" [e] - Tanh _ -> funcall "tanh" [e] - Cosh _ -> funcall "cosh" [e] - Asinh _ -> funcall "asinh" [e] - Atanh _ -> funcall "atanh" [e] - Acosh _ -> funcall "acosh" [e] - Ceiling _ -> funcall "ceil" [e] - Floor _ -> funcall "floor" [e] - BwNot _ -> (C..~) e - Cast _ ty -> C.Cast (transtypename ty) e - GetField (Struct _) _ f -> C.Dot e (accessorname f) - --- | Translates a Copilot binary operator and its arguments into a C99 --- expression. -transop2 :: Op2 a b c -> C.Expr -> C.Expr -> C.Expr -transop2 op e1 e2 = case op of - And -> e1 C..&& e2 - Or -> e1 C..|| e2 - Add _ -> e1 C..+ e2 - Sub _ -> e1 C..- e2 - Mul _ -> e1 C..* e2 - Mod _ -> e1 C..% e2 - Div _ -> e1 C../ e2 - Fdiv _ -> e1 C../ e2 - Pow _ -> funcall "pow" [e1, e2] - Logb _ -> funcall "log" [e2] C../ funcall "log" [e1] - Atan2 _ -> funcall "atan2" [e1, e2] - Eq _ -> e1 C..== e2 - Ne _ -> e1 C..!= e2 - Le _ -> e1 C..<= e2 - Ge _ -> e1 C..>= e2 - Lt _ -> e1 C..< e2 - Gt _ -> e1 C..> e2 - BwAnd _ -> e1 C..& e2 - BwOr _ -> e1 C..| e2 - BwXor _ -> e1 C..^ e2 - BwShiftL _ _ -> e1 C..<< e2 - BwShiftR _ _ -> e1 C..>> e2 - Index _ -> C.Index e1 e2 - --- | Translates a Copilot ternary operator and its arguments into a C99 --- expression. -transop3 :: Op3 a b c d -> C.Expr -> C.Expr -> C.Expr -> C.Expr -transop3 op e1 e2 e3 = case op of - Mux _ -> C.Cond e1 e2 e3 - --- | Transform a Copilot Core literal, based on its value and type, into a C99 --- literal. -constty :: Type a -> a -> C.Expr -constty ty = case ty of - Bool -> C.LitBool - Int8 -> explicitty ty . C.LitInt . fromIntegral - Int16 -> explicitty ty . C.LitInt . fromIntegral - Int32 -> explicitty ty . C.LitInt . fromIntegral - Int64 -> explicitty ty . C.LitInt . fromIntegral - Word8 -> explicitty ty . C.LitInt . fromIntegral - Word16 -> explicitty ty . C.LitInt . fromIntegral - Word32 -> explicitty ty . C.LitInt . fromIntegral - Word64 -> explicitty ty . C.LitInt . fromIntegral - Float -> explicitty ty . C.LitFloat - Double -> explicitty ty . C.LitDouble - Struct _ -> \v -> C.InitVal (transtypename ty) (map fieldinit (toValues v)) - where - fieldinit (Value ty (Field val)) = C.InitExpr $ constty ty val - Array ty' -> \v -> C.InitVal (transtypename ty) (vals v) - where - vals v = constarray ty' (arrayelems v) - - constarray :: Type a -> [a] -> [C.Init] - constarray ty xs = case ty of - Array ty' -> constarray ty' (concatMap arrayelems xs) - _ -> map (C.InitExpr . constty ty) xs - - --- | Explicitly cast a C99 value to a type. -explicitty :: Type a -> C.Expr -> C.Expr -explicitty ty = C.Cast (transtypename ty) - --- | Translate a Copilot type to a C99 type. -transtype :: Type a -> C.Type -transtype ty = case ty of - Bool -> C.TypeSpec $ C.TypedefName "bool" - Int8 -> C.TypeSpec $ C.TypedefName "int8_t" - Int16 -> C.TypeSpec $ C.TypedefName "int16_t" - Int32 -> C.TypeSpec $ C.TypedefName "int32_t" - Int64 -> C.TypeSpec $ C.TypedefName "int64_t" - Word8 -> C.TypeSpec $ C.TypedefName "uint8_t" - Word16 -> C.TypeSpec $ C.TypedefName "uint16_t" - Word32 -> C.TypeSpec $ C.TypedefName "uint32_t" - Word64 -> C.TypeSpec $ C.TypedefName "uint64_t" - Float -> C.TypeSpec C.Float - Double -> C.TypeSpec C.Double - Array ty' -> C.Array (transtype ty') length where - length = Just $ C.LitInt $ fromIntegral $ tylength ty - Struct s -> C.TypeSpec $ C.Struct (typename s) - --- | Translate a Copilot type intro a C typename -transtypename :: Type a -> C.TypeName -transtypename ty = C.TypeName $ transtype ty diff --git a/copilot-c99/src/Copilot/Compile/C99/Type.hs b/copilot-c99/src/Copilot/Compile/C99/Type.hs new file mode 100644 index 000000000..525fccea9 --- /dev/null +++ b/copilot-c99/src/Copilot/Compile/C99/Type.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE GADTs #-} + +-- | Translate Copilot Core expressions and operators to C99. +module Copilot.Compile.C99.Type + ( transType + , transLocalVarDeclType + , transTypeName + ) + where + +-- External imports +import qualified Language.C99.Simple as C + +-- Internal imports: Copilot +import Copilot.Core ( Struct (..), Type (..), typeLength, + typeName ) +import Copilot.Compile.C99.Error ( errorEmptyStruct, errorZeroLengthArray ) + +-- | Translate a Copilot type to a C99 type. +transType :: Type a -> C.Type +transType ty = case ty of + Bool -> C.TypeSpec $ C.TypedefName "bool" + Int8 -> C.TypeSpec $ C.TypedefName "int8_t" + Int16 -> C.TypeSpec $ C.TypedefName "int16_t" + Int32 -> C.TypeSpec $ C.TypedefName "int32_t" + Int64 -> C.TypeSpec $ C.TypedefName "int64_t" + Word8 -> C.TypeSpec $ C.TypedefName "uint8_t" + Word16 -> C.TypeSpec $ C.TypedefName "uint16_t" + Word32 -> C.TypeSpec $ C.TypedefName "uint32_t" + Word64 -> C.TypeSpec $ C.TypedefName "uint64_t" + Float -> C.TypeSpec C.Float + Double -> C.TypeSpec C.Double + Array ty' | typeLength ty == 0 -> errorZeroLengthArray + | otherwise -> C.Array (transType ty') len + where + len = Just $ C.LitInt $ fromIntegral $ typeLength ty + Struct s | null (toValues s) -> errorEmptyStruct + | otherwise -> C.TypeSpec $ C.Struct (typeName s) + +-- | Translate a Copilot type to a valid (local) variable declaration C99 type. +-- +-- If the type denotes an array, translate it to a pointer to whatever the +-- array holds. This special case is needed when the type is used for a local +-- variable declaration. We treat global variables differently (we generate +-- list initializers). +transLocalVarDeclType :: Type a -> C.Type +transLocalVarDeclType (Array ty') = C.Ptr $ transType ty' +transLocalVarDeclType ty = transType ty + +-- | Translate a Copilot type intro a C typename +transTypeName :: Type a -> C.TypeName +transTypeName ty = C.TypeName $ transType ty diff --git a/copilot-c99/src/Copilot/Compile/C99/Util.hs b/copilot-c99/src/Copilot/Compile/C99/Util.hs deleted file mode 100644 index ec62ad2b7..000000000 --- a/copilot-c99/src/Copilot/Compile/C99/Util.hs +++ /dev/null @@ -1,64 +0,0 @@ --- | Auxiliary helper functions to generate C99 code. -module Copilot.Compile.C99.Util - {-# DEPRECATED "This module will be hidden in future versions." #-} - where - -import Control.Monad.State - -import Copilot.Core (Id) -import qualified Language.C99.Simple.AST as C - --- | Auxiliary type used to collect all the declarations of all the variables --- used in a function to be generated, since variable declarations are always --- listed first at the top of the function body. -type FunEnv = [C.Decln] - --- | `tell` equivalent for `State`. -statetell :: Monoid m => m -> State m () -statetell m = modify ((flip mappend) m) - --- | Generate fresh variable name based on a given one. -fresh :: String -> [String] -> String -fresh name used = head $ dropWhile (flip elem used) (name:freshnames) where - freshnames = (name ++).show <$> [0..] - --- | Collect all the names from a list of C99 declarations. -names :: [C.Decln] -> [String] -names ds = map match ds where - match (C.VarDecln _ _ name _) = name - --- | Turn a stream id into a suitable C variable name. -streamname :: Id -> String -streamname sid = "s" ++ show sid - --- | Turn a stream id into the global varname for indices. -indexname :: Id -> String -indexname sid = streamname sid ++ "_idx" - --- | Turn a stream id into the name of its accessor function -streamaccessorname :: Id -> String -streamaccessorname sid = streamname sid ++ "_get" - --- | Add a postfix for copies of external variables the name. -excpyname :: String -> String -excpyname name = name ++ "_cpy" - --- | Turn stream id into name of its generator function. -generatorname :: Id -> String -generatorname sid = streamname sid ++ "_gen" - --- | Turn the name of a trigger into a guard generator. -guardname :: String -> String -guardname name = name ++ "_guard" - --- | Turn a trigger name into a an trigger argument name. -argname :: String -> Int -> String -argname name n = name ++ "_arg" ++ show n - --- | Enumerate all argument names based on trigger name. -argnames :: String -> [String] -argnames base = [aname | n <- [0..], let aname = argname base n] - --- | Define a C expression that calls a function with arguments. -funcall :: C.Ident -> [C.Expr] -> C.Expr -funcall name args = C.Funcall (C.Ident name) args diff --git a/copilot-c99/tests/Main.hs b/copilot-c99/tests/Main.hs new file mode 100644 index 000000000..57ea63bdc --- /dev/null +++ b/copilot-c99/tests/Main.hs @@ -0,0 +1,18 @@ +-- | Test copilot-c99. +module Main where + +-- External imports +import Test.Framework (Test, defaultMain) + +-- Internal library modules being tested +import qualified Test.Copilot.Compile.C99 + +-- | Run all unit tests on copilot-c99. +main :: IO () +main = defaultMain tests + +-- | All unit tests in copilot-c99. +tests :: [Test.Framework.Test] +tests = + [ Test.Copilot.Compile.C99.tests + ] diff --git a/copilot-c99/tests/Test/Copilot/Compile/C99.hs b/copilot-c99/tests/Test/Copilot/Compile/C99.hs new file mode 100644 index 000000000..b02fc23ae --- /dev/null +++ b/copilot-c99/tests/Test/Copilot/Compile/C99.hs @@ -0,0 +1,1042 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | Test copilot-c99:Copilot.Compile.C99. +module Test.Copilot.Compile.C99 + ( tests ) + where + +-- External imports +import Control.Arrow ((&&&)) +import Control.Exception (ErrorCall (..), IOException, catch, + try) +import Control.Monad (unless, when) +import Data.Bits (Bits, complement) +import Data.List (intercalate, isSubsequenceOf) +import Data.Type.Equality (testEquality) +import Data.Typeable (Proxy (..), (:~:) (Refl)) +import GHC.TypeLits (KnownNat, natVal) +import System.Directory (doesFileExist, + getTemporaryDirectory, + removeDirectory, removeFile, + setCurrentDirectory) +import System.IO (hPutStrLn, stderr) +import System.Posix.Temp (mkdtemp) +import System.Process (callProcess, readProcess) +import System.Random (Random) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.HUnit (Assertion, assertFailure) +import Test.QuickCheck (Arbitrary, Gen, Property, + arbitrary, choose, elements, + forAll, forAllBlind, frequency, + getPositive, ioProperty, oneof, + vectorOf, (.&&.)) +import Test.QuickCheck.Gen (chooseAny, chooseBoundedIntegral) + +-- External imports: Copilot +import Copilot.Core hiding (Property) +import Copilot.Core.Type.Array (array) + +-- External imports: Modules being tested +import Copilot.Compile.C99 (cSettingsOutputDirectory, compile, compileWith, + mkDefaultCSettings) + +-- * Constants + +-- | All unit tests for copilot-core:Copilot.Core.Type. +tests :: Test.Framework.Test +tests = + testGroup "Copilot.Compile.C99" + [ testProperty "Compile specification" testCompile + , testProperty "Compile specification in custom dir" testCompileCustomDir + , testProperty "Run specification" testRun + , testProperty "Run and compare results" testRunCompare + , testCase "Reject empty arrays and structs" testRejectEmpties + ] + +-- * Individual tests + +-- | Test compiling a spec. +testCompile :: Property +testCompile = ioProperty $ do + tmpDir <- getTemporaryDirectory + setCurrentDirectory tmpDir + + testDir <- mkdtemp "copilot_test_" + setCurrentDirectory testDir + + compile "copilot_test" spec + r <- compileC "copilot_test" + + -- Remove file produced by GCC + removeFile "copilot_test.o" + + -- Remove files produced by Copilot + removeFile "copilot_test.c" + removeFile "copilot_test.h" + removeFile "copilot_test_types.h" + + setCurrentDirectory tmpDir + removeDirectory testDir + + return r + + where + + spec = Spec streams observers triggers properties + + streams = [ Stream 0 [1] (Const Int8 1) Int8] + observers = [] + triggers = [ Trigger function guard args ] + properties = [] + + function = "func" + + guard = Const Bool True + + args = [] + +-- | Test compiling a spec in a custom directory. +testCompileCustomDir :: Property +testCompileCustomDir = ioProperty $ do + tmpDir <- getTemporaryDirectory + setCurrentDirectory tmpDir + + testDir <- mkdtemp "copilot_test_" + + compileWith (mkDefaultCSettings { cSettingsOutputDirectory = testDir }) + "copilot_test" + spec + + setCurrentDirectory testDir + r <- compileC "copilot_test" + + -- Remove file produced by GCC + removeFile "copilot_test.o" + + -- Remove files produced by Copilot + removeFile "copilot_test.c" + removeFile "copilot_test.h" + removeFile "copilot_test_types.h" + + setCurrentDirectory tmpDir + removeDirectory testDir + + return r + + where + + spec = Spec streams observers triggers properties + + streams = [ Stream 0 [1] (Const Int8 1) Int8] + observers = [] + triggers = [ Trigger function guard args ] + properties = [] + + function = "nop" + + guard = Const Bool True + + args = [] + +data Empty = Empty + +instance Struct Empty where + typeName _ = "" + toValues _ = [] + +instance Typed Empty where + typeOf = Struct Empty + +-- | Test that compiling a spec with an empty array or struct raises an error. +-- C99 does not support zero-length arrays or structs without fields, so Copilot +-- should report an error during compilation. +testRejectEmpties :: Assertion +testRejectEmpties = do + tmpDir <- getTemporaryDirectory + setCurrentDirectory tmpDir + + r1 <- try (compile "copilot_test" $ spec t1) :: IO (Either ErrorCall ()) + unless (isErrZeroArray r1) $ assertFailure "Const zero-length array" + + r2 <- try (compile "copilot_test" $ spec t2) :: IO (Either ErrorCall ()) + unless (isErrZeroArray r2) $ assertFailure "Extern zero-length array" + + r3 <- try (compile "copilot_test" $ spec t3) :: IO (Either ErrorCall ()) + unless (isErrEmptyStruct r3) $ assertFailure "Const empty struct" + + r4 <- try (compile "copilot_test" $ spec t4) :: IO (Either ErrorCall ()) + unless (isErrEmptyStruct r4) $ assertFailure "Extern empty struct" + + where + + spec a = Spec streams observers (triggers a) properties + + streams = [] + observers = [] + triggers a = [ Trigger "trig" (Const Bool True) a ] + properties = [] + + t1 = [ UExpr arrTy (Const arrTy (array [])) ] + t2 = [ UExpr arrTy (ExternVar arrTy "arrs" Nothing) ] + t3 = [ UExpr structTy (Const structTy Empty) ] + t4 = [ UExpr structTy (ExternVar structTy "structs" Nothing) ] + + arrTy :: Type (Array 0 Bool) + arrTy = Array Bool + + structTy :: Type Empty + structTy = Struct Empty + + isErrZeroArray :: Either ErrorCall a -> Bool + isErrZeroArray e = case e of + Left (ErrorCall msg) -> "zero-length array" `isSubsequenceOf` msg + _ -> False + + isErrEmptyStruct :: Either ErrorCall a -> Bool + isErrEmptyStruct e = case e of + Left (ErrorCall msg) -> "empty struct" `isSubsequenceOf` msg + _ -> False + +-- | Test compiling a spec and running the resulting program. +-- +-- The actual behavior is ignored. +testRun :: Property +testRun = ioProperty $ do + tmpDir <- getTemporaryDirectory + setCurrentDirectory tmpDir + + testDir <- mkdtemp "copilot_test_" + setCurrentDirectory testDir + + compile "copilot_test" spec + r <- compileC "copilot_test" + + let cProgram = unlines + [ "#include \"copilot_test.h\"" + , "" + , "void nop () {" + , "}" + , "" + , "int main () {" + , " step();" + , "}" + ] + + writeFile "main.c" cProgram + + -- Compile a main program + r2 <- compileExecutable "main" [ "copilot_test.o" ] + callProcess "./main" [] + + -- Remove file produced by GCC + removeFile "copilot_test.o" + removeFile "main" + + -- Remove files produced "by hand" + removeFile "main.c" + + -- Remove files produced by Copilot + removeFile "copilot_test.c" + removeFile "copilot_test.h" + removeFile "copilot_test_types.h" + + setCurrentDirectory tmpDir + removeDirectory testDir + + return $ r && r2 + + where + + spec = Spec streams observers triggers properties + + streams = [ Stream 0 [1] (Const Int8 1) Int8] + observers = [] + triggers = [ Trigger function guard args ] + properties = [] + + function = "nop" + + guard = Const Bool True + + args = [] + +-- | Test running compiled spec and comparing the results to the +-- expectation. +testRunCompare :: Property +testRunCompare = + testRunCompare1 (arbitraryOpIntegralBool :: Gen (TestCase1 Int8 Bool)) + .&&. testRunCompare1 (arbitraryOpIntegralBool :: Gen (TestCase1 Int16 Bool)) + .&&. testRunCompare1 (arbitraryOpIntegralBool :: Gen (TestCase1 Int32 Bool)) + .&&. testRunCompare1 (arbitraryOpIntegralBool :: Gen (TestCase1 Int64 Bool)) + .&&. testRunCompare1 (arbitraryOpIntegralBool :: Gen (TestCase1 Word8 Bool)) + .&&. testRunCompare1 (arbitraryOpIntegralBool :: Gen (TestCase1 Word16 Bool)) + .&&. testRunCompare1 (arbitraryOpIntegralBool :: Gen (TestCase1 Word32 Bool)) + .&&. testRunCompare1 (arbitraryOpIntegralBool :: Gen (TestCase1 Word64 Bool)) + .&&. testRunCompare1 (arbitraryOpFloatingBool :: Gen (TestCase1 Float Bool)) + .&&. testRunCompare1 (arbitraryOpFloatingBool :: Gen (TestCase1 Double Bool)) + .&&. testRunCompare2 (arbitraryArrayNum :: Gen (TestCase2 (Array 2 Int8) Word32 Int8)) + .&&. testRunCompare2 (arbitraryArrayNum :: Gen (TestCase2 (Array 2 Int16) Word32 Int16)) + +-- * Random generators + +-- ** Random function generators + +-- | Generator of functions that produce booleans. +arbitraryOpBool :: Typed a => Gen (Fun a Bool, [a] -> [Bool]) +arbitraryOpBool = + frequency + [ (5, arbitraryOp1Any) + , (5, funCompose1 <$> arbitraryOp1Bool <*> arbitraryOpBool) + , (2, funCompose2 <$> arbitraryOp2Bool <*> arbitraryOpBool <*> arbitraryOpBool) + , (1, funCompose2 <$> arbitraryOp2Eq <*> arbitraryOpBool <*> arbitraryOpBool) + , (1, funCompose2 <$> arbitraryOp2Ord <*> arbitraryOpBool <*> arbitraryOpBool) + ] + +-- | Generator of functions that take Bits and produce booleans. +arbitraryOpBoolBits :: (Typed a, Bits a) => Gen (Fun a Bool, [a] -> [Bool]) +arbitraryOpBoolBits = + frequency + [ (1, funCompose2 <$> arbitraryOp2Eq <*> arbitraryOpBits <*> arbitraryOpBits) + ] + +-- | Generator of functions that take Nums and produce booleans. +arbitaryOpBoolOrdEqNum :: (Typed a, Eq a, Ord a, Num a) + => Gen (Fun a Bool, [a] -> [Bool]) +arbitaryOpBoolOrdEqNum = + frequency + [ (1, funCompose2 <$> arbitraryOp2Eq <*> arbitraryOpNum <*> arbitraryOpNum) + , (1, funCompose2 <$> arbitraryOp2Ord <*> arbitraryOpNum <*> arbitraryOpNum) + ] + +-- | Generator of functions that take Floating point numbers and produce +-- booleans. +arbitraryOpBoolEqNumFloat :: (Typed t, Eq t, Num t, Floating t) + => Gen (Fun t Bool, [t] -> [Bool]) +arbitraryOpBoolEqNumFloat = + frequency + [ (1, funCompose2 <$> arbitraryOp2Eq <*> arbitraryOpNum <*> arbitraryOpFloat) + , (1, funCompose2 <$> arbitraryOp2Eq <*> arbitraryOpFloat <*> arbitraryOpNum) + ] + +-- | Generator of functions that take and produce Bits. +arbitraryOpBits :: (Bits t, Typed t) + => Gen (Fun t t, [t] -> [t]) +arbitraryOpBits = elements + [ (Op1 (BwNot typeOf), fmap complement) + ] + +-- | Generator of functions that take and produce Nums. +arbitraryOpNum :: (Typed t, Num t) => Gen (Fun t t, [t] -> [t]) +arbitraryOpNum = elements + [ (Op1 (Abs typeOf), fmap abs) + , (Op1 (Sign typeOf), fmap signum) + ] + +-- | Generator of functions that take an arrays and indicates and produce +-- elements from the array. +arbitraryArrayIx :: forall t n . (Typed t, KnownNat n, Num t) + => Gen ( Fun2 (Array n t) Word32 t + , [Array n t] -> [Word32] -> [t] + ) +arbitraryArrayIx = return + (Op2 (Index typeOf), zipWith (\x y -> arrayElems x !! fromIntegral y)) + +-- | Generator of functions on Floating point numbers. +arbitraryOpFloat :: (Floating t, Typed t) => Gen (Fun t t, [t] -> [t]) +arbitraryOpFloat = elements + [ (Op1 (Exp typeOf), fmap exp) + , (Op1 (Sqrt typeOf), fmap sqrt) + , (Op1 (Log typeOf), fmap log) + , (Op1 (Sin typeOf), fmap sin) + , (Op1 (Tan typeOf), fmap tan) + , (Op1 (Cos typeOf), fmap cos) + , (Op1 (Asin typeOf), fmap asin) + , (Op1 (Atan typeOf), fmap atan) + , (Op1 (Acos typeOf), fmap acos) + , (Op1 (Sinh typeOf), fmap sinh) + , (Op1 (Tanh typeOf), fmap tanh) + , (Op1 (Cosh typeOf), fmap cosh) + , (Op1 (Asinh typeOf), fmap asinh) + , (Op1 (Atanh typeOf), fmap atanh) + , (Op1 (Acosh typeOf), fmap acosh) + ] + +-- | Generator of functions on that produce elements of any type. +arbitraryOp1Any :: forall a b + . (Arbitrary b, Typed a, Typed b) + => Gen (Fun a b, [a] -> [b]) +arbitraryOp1Any = oneof $ + [ (\v -> (\_ -> Const typeOf v, fmap (const v))) <$> arbitrary ] + ++ + rest + where + rest | Just Refl <- testEquality t1 t2 + = [return (id, id)] + | otherwise + = [] + + t1 :: Type a + t1 = typeOf + + t2 :: Type b + t2 = typeOf + +-- | Generator of functions on Booleans. +arbitraryOp1Bool :: Gen (Fun Bool Bool, [Bool] -> [Bool]) +arbitraryOp1Bool = elements + [ (Op1 Not, fmap not) + ] + +-- | Generator of binary functions on Booleans. +arbitraryOp2Bool :: Gen (Fun2 Bool Bool Bool, [Bool] -> [Bool] -> [Bool]) +arbitraryOp2Bool = elements + [ (Op2 And, zipWith (&&)) + , (Op2 Or, zipWith (||)) + ] + +-- | Generator of binary functions that take two Eq elements of the same type +-- and return a Bool. +arbitraryOp2Eq :: (Typed t, Eq t) + => Gen (Fun2 t t Bool, [t] -> [t] -> [Bool]) +arbitraryOp2Eq = elements + [ (Op2 (Eq typeOf), zipWith (==)) + , (Op2 (Ne typeOf), zipWith (/=)) + ] + +-- | Generator of binary functions that take two Ord elements of the same type +-- and return a Bool. +arbitraryOp2Ord :: (Typed t, Ord t) + => Gen (Fun2 t t Bool, [t] -> [t] -> [Bool]) +arbitraryOp2Ord = elements + [ (Op2 (Le typeOf), zipWith (<=)) + , (Op2 (Lt typeOf), zipWith (<)) + , (Op2 (Ge typeOf), zipWith (>=)) + , (Op2 (Gt typeOf), zipWith (>)) + ] + +-- ** Random data generators + +-- | Random array generator. +arbitraryArray :: forall n t . (KnownNat n, Random t) => Gen (Array n t) +arbitraryArray = array <$> vectorOf len chooseAny + where + len :: Int + len = fromIntegral $ natVal (Proxy :: Proxy n) + +-- ** Random test case generators + +-- | Generator for test cases on integral numbers that produce booleans. +arbitraryOpIntegralBool :: (Typed t, Bounded t, Integral t, Bits t) + => Gen (TestCase1 t Bool) +arbitraryOpIntegralBool = frequency + [ (5, mkTestCase1 + arbitraryOpBool + (chooseBoundedIntegral (minBound, maxBound))) + + , (2, mkTestCase1 + arbitraryOpBoolBits + (chooseBoundedIntegral (minBound, maxBound))) + + -- we need to use +1 because certain operations overflow the number + , (2, mkTestCase1 + arbitaryOpBoolOrdEqNum + (chooseBoundedIntegral (minBound + 1, maxBound))) + ] + +-- | Generator for test cases on floating-point numbers that produce booleans. +arbitraryOpFloatingBool :: (Random t, Typed t, Floating t, Eq t) + => Gen (TestCase1 t Bool) +arbitraryOpFloatingBool = oneof + [ mkTestCase1 arbitraryOpBoolEqNumFloat chooseAny + ] + +-- | Generator for test cases on Arrays selection producing values of the +-- array. +arbitraryArrayNum :: forall n a + . (KnownNat n, Num a, Random a, Typed a) + => Gen (TestCase2 (Array n a) Word32 a) +arbitraryArrayNum = oneof + [ mkTestCase2 arbitraryArrayIx arbitraryArray gen + ] + where + gen :: Gen Word32 + gen = choose (0, len - 1) + + len :: Word32 + len = fromIntegral $ natVal (Proxy :: Proxy n) + +-- * Semantics + +-- ** Functions + +-- | Unary Copilot function. +type Fun a b = Expr a -> Expr b + +-- | Binary Copilot function. +type Fun2 a b c = Expr a -> Expr b -> Expr c + +-- | Compose functions, paired with the Haskell functions that define their +-- idealized meaning. +funCompose1 :: (Fun b c, [b] -> [c]) + -> (Fun a b, [a] -> [b]) + -> (Fun a c, [a] -> [c]) +funCompose1 (f1, g1) (f2, g2) = (f1 . f2, g1 . g2) + +-- | Compose a binary function, with two functions, one for each argument. +funCompose2 :: (Fun2 b c d, [b] -> [c] -> [d]) + -> (Fun a b, [a] -> [b]) + -> (Fun a c, [a] -> [c]) + -> (Fun a d, [a] -> [d]) +funCompose2 (f1, g1) (f2, g2) (f3, g3) = + (uncurry f1 . (f2 &&& f3), uncurry g1 . (g2 &&& g3)) + +-- ** Test cases + +-- | Test case specification for specs with one input variable and one output. +data TestCase1 a b = TestCase1 + { wrapTC1Expr :: Spec + -- ^ Specification containing a trigger an extern of type 'a' and a trigger + -- with an argument of type 'b'. + + , wrapTC1Fun :: [a] -> [b] + -- ^ Function expected to function in the same way as the Spec being + -- tested. + + , wrapTC1CopInp :: (String -> String, String, String, Gen a) + -- ^ Input specification. + -- + -- - The first element is a function that prints the variable declaration + -- in C. + -- + -- - The second element obtains a C expression that calculates the size of + -- the variable in C. + -- + -- - The third contains the variable name in C. + -- + -- - The latter contains a randomized generator for values of the given + -- type. + + , wrapTC1CopOut :: (String, String) + -- ^ Output specification. + -- + -- The first element of the tuple contains the type of the output in C. + -- + -- The second element of the tuple is the formatting string when printing + -- values of the given kind. + } + +-- | Test case specification for specs with two input variables and one output. +data TestCase2 a b c = TestCase2 + { wrapTC2Expr :: Spec + -- ^ Specification containing a trigger an extern of type 'a' and a trigger + -- with an argument of type 'b'. + + , wrapTC2Fun :: [a] -> [b] -> [c] + -- ^ Function expected to function in the same way as the Spec being + -- tested. + + , wrapTC2CopInp1 :: (String -> String, String, String, Gen a) + -- ^ Input specification for the first input. + -- + -- - The first element is a function that prints the variable declaration + -- in C. + -- + -- - The second element obtains a C expression that calculates the size of + -- the variable in C. + -- + -- - The third contains the variable name in C. + -- + -- - The latter contains a randomized generator for values of the given + -- type. + + , wrapTC2CopInp2 :: (String -> String, String, String, Gen b) + -- ^ Input specification for the second input. + -- + -- - The first element is a function that prints the variable declaration + -- in C. + -- + -- - The second element obtains a C expression that calculates the size of + -- the variable in C. + -- + -- - The third contains the variable name in C. + -- + -- - The latter contains a randomized generator for values of the given + -- type. + + , wrapTC2CopOut :: (String, String) + -- ^ Output specification. + -- + -- The first element of the tuple contains the type of the output in C. + -- + -- The second element of the tuple is the formatting string when printing + -- values of the given kind. + } + +-- | Generate test cases for expressions that behave like unary functions. +mkTestCase1 :: (Typed a, Typed b) + => Gen (Fun a b, [a] -> [b]) + -> Gen a + -> Gen (TestCase1 a b) +mkTestCase1 genO gen = do + (copilotF, semF) <- genO + + let spec = alwaysTriggerArg1 (UExpr t2 appliedOp) + appliedOp = copilotF (ExternVar t1 varName Nothing) + + return $ + TestCase1 + spec + semF + ( varDeclC t1, sizeC t1, varName, gen ) + ( typeC t2, formatC t2) + + where + + t1 = typeOf + t2 = typeOf + + varName = "input" + +-- | Generate test cases for expressions that behave like binary functions. +mkTestCase2 :: (Typed a, Typed b, Typed c) + => Gen (Fun2 a b c, [a] -> [b] -> [c]) + -> Gen a + -> Gen b + -> Gen (TestCase2 a b c) +mkTestCase2 genO genA genB = do + (copilotF, semF) <- genO + + let spec = alwaysTriggerArg1 (UExpr t3 appliedOp) + appliedOp = copilotF (ExternVar t1 varName1 Nothing) + (ExternVar t2 varName2 Nothing) + + return $ + TestCase2 + spec + semF + ( varDeclC t1, sizeC t1, varName1, genA ) + ( varDeclC t2, sizeC t2, varName2, genB ) + ( typeC t3, formatC t3) + + where + + t1 = typeOf + t2 = typeOf + t3 = typeOf + + varName1 = "input1" + varName2 = "input2" + +-- | Test running a compiled C program and comparing the results. +testRunCompare1 :: (Show a, CShow a, ReadableFromC b, Eq b) + => Gen (TestCase1 a b) -> Property +testRunCompare1 ops = + forAllBlind ops $ \testCase -> + let (TestCase1 copilotSpec haskellFun inputVar outputVar) = testCase + (cTypeInput, size, cInputName, gen) = inputVar + + in forAll (getPositive <$> arbitrary) $ \len -> + + forAll (vectorOf len gen) $ \nums -> do + + let inputs = [ (cTypeInput, size, fmap cshow nums, cInputName) ] + outputs = haskellFun nums + + testRunCompareArg inputs len outputs copilotSpec outputVar + +-- | Test running a compiled C program and comparing the results. +testRunCompare2 :: (Show a1, CShow a1, Show a2, CShow a2, ReadableFromC b, Eq b) + => Gen (TestCase2 a1 a2 b) -> Property +testRunCompare2 ops = + forAllBlind ops $ \testCase -> + let (TestCase2 copilotSpec haskellFun inputVar1 inputVar2 outputVar) = + testCase + + (cTypeInput1, size1, cInputName1, gen1) = inputVar1 + (cTypeInput2, size2, cInputName2, gen2) = inputVar2 + + in forAll (getPositive <$> arbitrary) $ \len -> + forAll (vectorOf len gen1) $ \nums1 -> + forAll (vectorOf len gen2) $ \nums2 -> do + let inputs = [ (cTypeInput1, size1, fmap cshow nums1, cInputName1) + , (cTypeInput2, size2, fmap cshow nums2, cInputName2) + ] + + outputs = haskellFun nums1 nums2 + + testRunCompareArg inputs len outputs copilotSpec outputVar + +-- | Test running a compiled C program and comparing the results, when the +-- program produces one output as an argument to a trigger that always fires. +-- +-- PRE: all lists (second argument) of inputs have the length given as second +-- argument. +-- +-- PRE: the monitoring code this is linked against uses the function +-- @printBack@ with exactly one argument to pass the results. +testRunCompareArg :: (ReadableFromC b, Eq b) + => [(String -> String, String, [String], String)] + -> Int + -> [b] + -> Spec + -> (String, String) + -> Property +testRunCompareArg inputs numInputs nums spec outputVar = + ioProperty $ do + tmpDir <- getTemporaryDirectory + setCurrentDirectory tmpDir + + -- Operate in temporary directory + testDir <- mkdtemp "copilot_test_" + setCurrentDirectory testDir + + -- Produce copilot monitoring code + compile "copilot_test" spec + r <- compileC "copilot_test" + + -- Produce wrapper program + let cProgram = testRunCompareArgCProgram inputs numInputs outputVar + writeFile "main.c" cProgram + + -- Compile main program + r2 <- compileExecutable "main" [ "copilot_test.o" ] + + -- Print result so far (for debugging purposes only) + print r2 + print testDir + + -- Run program and compare result + out <- readProcess "./main" [] "" + let outNums = readFromC <$> lines out + comparison = outNums == nums + + -- Only clean up if the test succeeded; otherwise, we want to inspect it. + when comparison $ do + -- Remove file produced by GCC + removeFile "copilot_test.o" + removeFile "main" + + -- Remove files produced "by hand" + removeFile "main.c" + + -- Remove files produced by Copilot + removeFile "copilot_test.c" + removeFile "copilot_test.h" + removeFile "copilot_test_types.h" + + -- Remove temporary directory + setCurrentDirectory tmpDir + removeDirectory testDir + + return $ r && r2 && comparison + +-- | Return a wrapper C program that runs a loop for a number of iterations, +-- putting values in global variables at every step, running the monitors, and +-- publishing the results of any outputs. +testRunCompareArgCProgram + :: [(String -> String, String, [String], String)] + -> Int + -> (String, String) + -> String +testRunCompareArgCProgram inputs numSteps outputVar = unlines $ + [ "#include " + , "#include " + , "#include " + , "#include " + , "#include " + , "#include \"copilot_test.h\"" + , "" + ] + ++ varDecls ++ + [ "" + , "void printBack (" ++ cTypeRes ++ " num) {" + , " printf(\"" ++ cStr ++ "\\n\", num);" + , "}" + , "" + , "int main () {" + , " int i = 0;" + , " for (i = 0; i < " ++ maxInputsName ++ "; i++) {" + ] + ++ inputUpdates ++ + [ "" + , " step();" + , " }" + , " return 0;" + , "}" + ] + + where + + varDecls :: [String] + varDecls = + [ "int " ++ maxInputsName ++ " = " ++ show numSteps ++ ";" ] + ++ inputVarDecls + + inputVarDecls :: [String] + inputVarDecls = + concatMap + (\(ctypeF, _size, varName, arrVar, arrVals) -> + + let inputsStr = intercalate ", " (arrVals :: [String]) + + in [ ctypeF (arrVar ++ "[]") ++ " = {" ++ inputsStr ++ "};" + , "" + , ctypeF varName ++ ";" + ] + ) + vars + + inputUpdates :: [String] + inputUpdates = concatMap (\(_ctype, size, varName, arrVar, _arrVals) -> + [ " memcpy(&" ++ varName ++ ", &" ++ arrVar ++ "[i], " ++ size ++ ");" + ]) + vars + + (cTypeRes, cStr) = outputVar + + vars = map oneInput inputs + oneInput (cTypeInput, size, inputVals, cInputName) = + (cTypeInput, size, inputVarName, inputArrVarName, inputVals) + where + inputVarName = cInputName + inputArrVarName = cInputName ++ "_s" + + maxInputsName = "MAX_STEPS" + +-- * Auxiliary functions + +-- ** Specs handling + +-- | Build a 'Spec' that triggers at every step, passing the given expression +-- as argument, and execution a function 'printBack'. +alwaysTriggerArg1 :: UExpr -> Spec +alwaysTriggerArg1 = triggerArg1 (Const Bool True) + + where + + -- | Build a 'Spec' that triggers based on a given boolean stream, passing + -- the given expression as argument, and execution a function 'printBack'. + triggerArg1 :: Expr Bool -> UExpr -> Spec + triggerArg1 guard expr = Spec streams observers triggers properties + + where + + streams = [] + observers = [] + properties = [] + + triggers = [ Trigger function guard args ] + function = "printBack" + args = [ expr ] + +-- ** Compilation of C programs + +-- | Compile a C file given its basename. +compileC :: String -> IO Bool +compileC baseName = do + result <- catch (do callProcess "gcc" [ "-c", baseName ++ ".c" ] + return True + ) + (\e -> do + hPutStrLn stderr $ + "copilot-c99: error: compileC: cannot compile " + ++ baseName ++ ".c with gcc" + hPutStrLn stderr $ + "copilot-c99: exception: " ++ show (e :: IOException) + return False + ) + if result + then doesFileExist $ baseName ++ ".o" + else return False + +-- | Compile a C file into an executable, given its basename and files to link +-- with it. +compileExecutable :: String -> [String] -> IO Bool +compileExecutable baseName linked = do + result <- catch (do callProcess "gcc" $ [ baseName ++ ".c" ] + ++ linked + ++ [ "-lm" ] + ++ [ "-o", baseName ] + return True + ) + (\e -> do + hPutStrLn stderr $ + "copilot-c99: error: compileExecutable: cannot compile " + ++ baseName ++ ".c with gcc" + hPutStrLn stderr $ + "copilot-c99: exception: " ++ show (e :: IOException) + return False + ) + if result + then doesFileExist baseName + else return False + +-- ** Interfacing between Haskell and C + +-- | C formatting string that can be used to print values of a given type. +formatC :: Typed a => Type a -> String +formatC Bool = "%d" +formatC Int8 = "%d" +formatC Int16 = "%d" +formatC Int32 = "%d" +formatC Int64 = "%ld" +formatC Word8 = "%d" +formatC Word16 = "%d" +formatC Word32 = "%d" +formatC Word64 = "%ld" +formatC Float = "%f" +formatC Double = "%lf" +formatC _ = error + "copilot-c99 (test): Printing of arrays and structs is not yet supported." + +-- | C type used to store values of a given type. +typeC :: Typed a => Type a -> String +typeC Bool = "bool" +typeC Int8 = "int8_t" +typeC Int16 = "int16_t" +typeC Int32 = "int32_t" +typeC Int64 = "int64_t" +typeC Word8 = "uint8_t" +typeC Word16 = "uint16_t" +typeC Word32 = "uint32_t" +typeC Word64 = "uint64_t" +typeC Float = "float" +typeC Double = "double" +typeC (Array tE) = typeC tE ++ "[]" +typeC _ = error + "copilot-c99 (test): Input variables of type struct are not yet supported." + +-- | C variable declaration for values of a given type. +varDeclC :: Typed a => Type a -> String -> String +varDeclC Bool v = "bool " ++ v +varDeclC Int8 v = "int8_t " ++ v +varDeclC Int16 v = "int16_t " ++ v +varDeclC Int32 v = "int32_t " ++ v +varDeclC Int64 v = "int64_t " ++ v +varDeclC Word8 v = "uint8_t " ++ v +varDeclC Word16 v = "uint16_t " ++ v +varDeclC Word32 v = "uint32_t " ++ v +varDeclC Word64 v = "uint64_t " ++ v +varDeclC Float v = "float " ++ v +varDeclC Double v = "double " ++ v +varDeclC t@(Array tE) v = + typeC tE ++ " " ++ v ++ "[" ++ show (typeLength t) ++ "]" +varDeclC _ _ = error + "copilot-c99 (test): Input variables of type struct are not yet supported." + +-- | Expression that calculates the size of a variable of a given type. +sizeC :: Typed a => Type a -> String +sizeC Bool = "sizeof(bool)" +sizeC Int8 = "sizeof(int8_t)" +sizeC Int16 = "sizeof(int16_t)" +sizeC Int32 = "sizeof(int32_t)" +sizeC Int64 = "sizeof(int64_t)" +sizeC Word8 = "sizeof(uint8_t)" +sizeC Word16 = "sizeof(uint16_t)" +sizeC Word32 = "sizeof(uint32_t)" +sizeC Word64 = "sizeof(uint64_t)" +sizeC Float = "sizeof(float)" +sizeC Double = "sizeof(double)" +sizeC t@(Array tE) = show (typeLength t) ++ "* sizeof(" ++ typeC tE ++ ")" +sizeC _ = error + "copilot-c99 (test): Input variables of type struct are not yet supported." + +-- | Show a value of a given type in C. +class CShow s where + cshow :: s -> String + +instance CShow Int8 where + -- Use a macro to ensure that any necessary suffixes are added to the number. + -- We choose this macro instead of specifically adding a suffix for reasons + -- of portability. + cshow x = "INT8_C(" ++ show x ++ ")" + +instance CShow Int16 where + -- Use a macro to ensure that any necessary suffixes are added to the number. + -- We choose this macro instead of specifically adding a suffix for reasons + -- of portability. + cshow x = "INT16_C(" ++ show x ++ ")" + +instance CShow Int32 where + -- Use a macro to ensure that any necessary suffixes are added to the number. + -- We choose this macro instead of specifically adding a suffix for reasons + -- of portability. + cshow x = "INT32_C(" ++ show x ++ ")" + +instance CShow Int64 where + -- Use a macro to ensure that any necessary suffixes are added to the number. + -- We choose this macro instead of specifically adding a suffix for reasons + -- of portability. + cshow x = "INT64_C(" ++ show x ++ ")" + +instance CShow Word8 where + -- Use a macro to ensure that any necessary suffixes are added to the number. + -- We choose this macro instead of specifically adding a suffix for reasons + -- of portability. + cshow x = "UINT8_C(" ++ show x ++ ")" + +instance CShow Word16 where + -- Use a macro to ensure that any necessary suffixes are added to the number. + -- We choose this macro instead of specifically adding a suffix for reasons + -- of portability. + cshow x = "UINT16_C(" ++ show x ++ ")" + +instance CShow Word32 where + -- Use a macro to ensure that any necessary suffixes are added to the number. + -- We choose this macro instead of specifically adding a suffix for reasons + -- of portability. + cshow x = "UINT32_C(" ++ show x ++ ")" + +instance CShow Word64 where + -- Use a macro to ensure that any necessary suffixes are added to the number. + -- We choose this macro instead of specifically adding a suffix for reasons + -- of portability. + cshow x = "UINT64_C(" ++ show x ++ ")" + +instance CShow Float where + cshow = show + +instance CShow Double where + cshow = show + +instance CShow Bool where + cshow True = "true" + cshow False = "false" + +instance CShow t => CShow (Array n t) where + cshow a = intercalate "," $ map cshow $ arrayElems a + +-- | Read a value of a given type in C. +class ReadableFromC a where + readFromC :: String -> a + +instance ReadableFromC Bool where + readFromC "0" = False + readFromC _ = True + +instance ReadableFromC Int8 where + readFromC = read + +instance ReadableFromC Int16 where + readFromC = read + +instance ReadableFromC Int32 where + readFromC = read + +instance ReadableFromC Int64 where + readFromC = read + +instance ReadableFromC Word8 where + readFromC = read + +instance ReadableFromC Word16 where + readFromC = read + +instance ReadableFromC Word32 where + readFromC = read + +instance ReadableFromC Word64 where + readFromC = read diff --git a/copilot-core/CHANGELOG b/copilot-core/CHANGELOG index 558a247b3..033129dbc 100644 --- a/copilot-core/CHANGELOG +++ b/copilot-core/CHANGELOG @@ -1,4 +1,165 @@ -2021-10-19 +2026-11-07 + * Version bump (4.8.2). (#792) + * Increase test coverage for `Copilot.Core.Type.Array`. (#767) + * Fix errors in the documentation of `Copilot.Core.Spec`. (#769) + * Replace tab in CHANGELOG. (#772) + * Fix comments for two tests in `Test.Copilot.Core.Type`. (#781) + * Fix typo in Haddock comment of test property. (#783) + * Fix test to use `typeSize` instead of `typeLength` (#784). + +2026-09-07 + * Version bump (4.8.1). (#760) + +2026-07-07 + * Version bump (4.8). (#745) + +2026-05-07 + * Version bump (4.7.1). (#730) + +2026-03-07 + * Version bump (4.7). (#714) + +2026-01-07 + * Version bump (4.6.1). (#705) + +2025-11-07 + * Version bump (4.6). (#679) + +2025-09-07 + * Version bump (4.5.1). (#666) + +2025-07-07 + * Version bump (4.5). (#642) + * Remove deprecated fields of Copilot.Core.Expr.UExpr. (#636) + +2025-05-07 + * Version bump (4.4). (#618) + * Remove deprecated Copilot.Core.Type.uTypeType. (#615) + +2025-03-07 + * Version bump (4.3). (#604) + * Fix typo in documentation. (#587) + * Add a Show instance for Type. (#589) + * Add a Prop type to capture how a property is quantified. (#254) + +2025-01-07 + * Version bump (4.2). (#577) + * Deprecate fields of Copilot.Core.Expr.UExpr. (#565) + * Increase test coverage. (#555) + * Define generic implementations of Struct and Typed methods. (#564) + +2024-11-07 + * Version bump (4.1). (#561) + * Add Haddocks for updateField. (#525) + * Standardize changelog format. (#550) + * Deprecate Copilot.Core.Type.UType.uTypeType. (#484) + +2024-09-07 + * Version bump (4.0). (#532) + * Update Op3, Array to support array updates. (#36) + +2024-07-07 + * Version bump (3.20). (#522) + * Update Op2, Struct to support struct field updates. (#520) + +2024-05-07 + * Version bump (3.19.1). (#512) + +2024-03-07 + * Version bump (3.19). (#504) + * Remove deprecated functions in Copilot.Core.Type and + Copilot.Core.Type.Array. (#500) + * Increase test coverage. (#502) + +2024-01-07 + * Version bump (3.18.1). (#493) + +2024-01-07 + * Version bump (3.18). (#487) + +2023-11-07 + * Version bump (3.17). (#466) + * Compliance with style guide. (#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) + * Remove Copilot.Core.Type.Equality. (#427) + * Remove Copilot.Core.PrettyPrint. (#426) + +2023-03-07 + * Version bump (3.14). (#422) + * Remove Copilot.Core.PrettyDot. (#409) + * Fix formatting error in CHANGELOG. (#414) + * Remove module space Copilot.Core.Interpret. (#410) + * Remove unused definitions from Copilot.Core.Type.Array. (#411) + +2023-01-07 + * Version bump (3.13). (#406) + * Implement missing cases of type equality for arrays and structs. + (#400) + * Remove Copilot.Core.External. (#391) + * Fix bug in definition of simpleType for Int8. (#393) + * Hide module Copilot.Core.Type.Show. (#392) + +2022-11-07 + * Version bump (3.12). (#389) + * Deprecate Copilot.Core.PrettyPrinter. (#383) + * Replace uses of Copilot.Core.Type.Equality with definitions from + base:Data.Type.Equality; deprecate Copilot.Core.Type.Equality. (#379) + * Compliance with style guide. (#332) + +2022-09-07 + * Version bump (3.11). (#376) + * Deprecate Copilot.Core.PrettyDot. (#359) + * Remove Copilot.Core.Type.Dynamic. (#360) + * Split copilot-interpreter into separate library. (#361) + * Deprecate unused classes, functions from Array module. (#369) + +2022-07-07 + * Version bump (3.10). (#356) + * Fix error in test case generation; enable CLI args in tests. (#337) + * Remove unnecessary dependencies from Cabal package. (#324) + * Deprecate Copilot.Core.External. (#322) + * Remove duplicated compiler option. (#328) + * Hide type Copilot.Core.Type.Show.ShowWit. (#348) + * Deprecate Copilot.Core.Type.Show. (#330) + * Update repo info in cabal file. (#333) + +2022-05-06 + * Version bump (3.9). (#320) + * Compliance with style guide (partial). (#316) + * Hide module Copilot.Core.Interpret.Render. (#303) + * Remove Copilot.Core.Type.Dynamic.fromDynF,toDynF. (#301) + * Hide module Copilot.Core.Error. (#300) + * Remove Copilot.Core.Type.Uninitialized. (#302) + * Remove Copilot.Core.Expr.Tag. (#304) + +2022-03-07 + * Version bump (3.8). (#298) + * Replaces uses of the internal Dynamic with base:Data.Dynamic. (#266) + * Mark package as uncurated to avoid modification. (#288) + +2022-01-07 + * Version bump (3.7). (#287) + * Make imports explicit, reorganize imports. (#277) + * Remove Copilot.Core.Type.Read. (#286) + * Remove Copilot.Core.Type.Eq. (#285) + * Remove Copilot.Core.Locals. (#284) + * Deprecate Copilot.Core.Type.Show.ShowWit. (#283) + * Remove Copilot.Core.Type.Show.showWit. (#282) + +2021-11-07 + * Version bump (3.6). (#264) + * Deprecate Copilot.Core.Type.Dynamic.toDynF and fromDynF. (#269) + * Deprecate copilot-core:Copilot.Core.Type.Uninitialized. (#270) + * Deprecate export of copilot-core:Copilot.Core.Interpret.Render. (#268) + * Replace uses of copilot-core's error reporting functions. (#267) * Introduce new ops atan2, ceiling, floor. (#246) * Add initial support for unit testing. (#256) * Deprecate unused type. (#260) @@ -31,15 +192,15 @@ * Version bump (3.2.1). (#136) * Completed the documentation. (#145) -2020-12-06 Ivan Perez - * Version bump (3.2). - * Fixed implementation of tysize for n-dimensional arrays. (#147). - * Removed sorting of interpreter output (#148). - * Minor documentation fixes (#149, #151). +2020-12-06 + * Version bump (3.2). (#65) + * Fixed implementation of tysize for n-dimensional arrays. (#147) + * Removed sorting of interpreter output. (#148) + * Minor documentation fixes. (#149, #151) * Credits: @fdedden. -2019-11-22 Ivan Perez - * Version bump (3.1). - * Eliminate random modules and generators (#157). - * Updated contact information for 'impossible' error (#154). - * Implement missing pretty printer for Index operator (#155). +2019-11-22 + * Version bump (3.1). (#46) + * Eliminate random modules and generators. (#157) + * Updated contact information for 'impossible' error. (#154) + * Implement missing pretty printer for Index operator. (#155) diff --git a/copilot-core/copilot-core.cabal b/copilot-core/copilot-core.cabal index 067d17b59..288399a9c 100644 --- a/copilot-core/copilot-core.cabal +++ b/copilot-core/copilot-core.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: copilot-core -version: 3.5 +version: 4.8.2 synopsis: An intermediate representation for Copilot. description: Intermediate representation for Copilot. @@ -24,10 +24,12 @@ category: Language, Embedded build-type: Simple extra-source-files: README.md, CHANGELOG +x-curation: uncurated + source-repository head type: git location: https://github.com/Copilot-Language/copilot.git - subdir: lib/copilot-core + subdir: copilot-core library @@ -37,37 +39,19 @@ library ghc-options: -Wall - -fwarn-tabs -fno-warn-orphans build-depends: - base >= 4.9 && < 5, - pretty >= 1.0 && < 1.2, - mtl >= 2.0 && < 2.3, - dlist + base >= 4.9 && < 5 exposed-modules: Copilot.Core - Copilot.Core.Error Copilot.Core.Expr - Copilot.Core.External - Copilot.Core.Interpret - Copilot.Core.Interpret.Eval - Copilot.Core.Interpret.Render Copilot.Core.Operators Copilot.Core.Spec - Copilot.Core.Locals Copilot.Core.Type Copilot.Core.Type.Array - Copilot.Core.Type.Dynamic - Copilot.Core.Type.Equality - Copilot.Core.Type.Eq - Copilot.Core.Type.Show - Copilot.Core.Type.Read - Copilot.Core.Type.Uninitialized - Copilot.Core.PrettyPrint - Copilot.Core.PrettyDot test-suite unit-tests type: @@ -78,19 +62,13 @@ test-suite unit-tests other-modules: Test.Extra - Test.Copilot.Core.Error - Test.Copilot.Core.External - Test.Copilot.Core.Interpret.Eval Test.Copilot.Core.Type Test.Copilot.Core.Type.Array - Test.Copilot.Core.Type.Dynamic - Test.Copilot.Core.Type.Show build-depends: base , HUnit , QuickCheck - , pretty , test-framework , test-framework-hunit , test-framework-quickcheck2 diff --git a/copilot-core/src/Copilot/Core.hs b/copilot-core/src/Copilot/Core.hs index 704cf670b..87ad13b15 100644 --- a/copilot-core/src/Copilot/Core.hs +++ b/copilot-core/src/Copilot/Core.hs @@ -1,8 +1,9 @@ --------------------------------------------------------------------------------- --- Copyright © 2011 National Institute of Aerospace / Galois, Inc. --------------------------------------------------------------------------------- +{-# LANGUAGE Safe #-} --- | Intermediate representation for Copilot specifications. +-- | +-- Description: Intermediate representation for Copilot specifications. +-- Copyright: (c) 2011 National Institute of Aerospace / Galois, Inc. +-- -- The following articles might also be useful: -- -- * Carette, Jacques and Kiselyov, Oleg and Shan, Chung-chieh, @@ -15,33 +16,26 @@ -- Electronic Notes in Theoretical Computer Science vol. 174, p. 23-39, 2007. -- -- For examples of how to traverse a Copilot specification see --- the source code of the interpreter --- ("Copilot.Core.Interpret") --- and the pretty-printer --- ("Copilot.Core.PrettyPrint"). - -{-# LANGUAGE Safe #-} - +-- the source code of the interpreter (@copilot-interpreter@) +-- and the pretty-printer (@copilot-prettyprinter@). module Copilot.Core - ( module Copilot.Core.Error - , module Copilot.Core.Expr - , module Copilot.Core.External - , module Copilot.Core.Operators - , module Copilot.Core.Spec - , module Copilot.Core.Type - , module Copilot.Core.Type.Array - , module Copilot.Core.Type.Uninitialized - , module Data.Int - , module Data.Word - ) where + ( module Copilot.Core.Expr + , module Copilot.Core.Operators + , module Copilot.Core.Spec + , module Copilot.Core.Type + , module Copilot.Core.Type.Array + , module Data.Int + , module Data.Word + ) + where -import Copilot.Core.Error +-- External imports +import Data.Int +import Data.Word + +-- Internal imports import Copilot.Core.Expr -import Copilot.Core.External import Copilot.Core.Operators import Copilot.Core.Spec import Copilot.Core.Type import Copilot.Core.Type.Array -import Copilot.Core.Type.Uninitialized -import Data.Int -import Data.Word diff --git a/copilot-core/src/Copilot/Core/Expr.hs b/copilot-core/src/Copilot/Core/Expr.hs index 99ed57dc3..b65126a04 100644 --- a/copilot-core/src/Copilot/Core/Expr.hs +++ b/copilot-core/src/Copilot/Core/Expr.hs @@ -1,70 +1,70 @@ --------------------------------------------------------------------------------- --- Copyright © 2011 National Institute of Aerospace / Galois, Inc. --------------------------------------------------------------------------------- +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE Safe #-} -{-# LANGUAGE Safe #-} -{-# LANGUAGE GADTs, ExistentialQuantification #-} - --- | Internal representation of Copilot stream expressions. +-- | +-- Description: Internal representation of Copilot stream expressions. +-- Copyright: (c) 2011 National Institute of Aerospace / Galois, Inc. module Copilot.Core.Expr - ( Id - , Name - , Expr (..) - , UExpr (..) - , DropIdx - , Tag - ) where - -import Copilot.Core.Operators (Op1, Op2, Op3) -import Copilot.Core.Type (Type) -import Data.Word (Word32) - + ( Id + , Name + , Expr (..) + , UExpr (..) + , DropIdx + ) + where + +-- External imports import Data.Typeable (Typeable) +import Data.Word (Word32) --------------------------------------------------------------------------------- +-- Internal imports +import Copilot.Core.Operators (Op1, Op2, Op3) +import Copilot.Core.Type (Type) -- | A stream identifier. type Id = Int --------------------------------------------------------------------------------- - -- | A name of a trigger, an external variable, or an external function. type Name = String --------------------------------------------------------------------------------- - -- | An index for the drop operator. type DropIdx = Word32 --------------------------------------------------------------------------------- - --- | A unique tag for external arrays/function calls. -{-# DEPRECATED Tag "The type Tag is deprecated in Copilot 3.6." #-} -type Tag = Int - --------------------------------------------------------------------------------- - -- | Internal representation of Copilot stream expressions. -- -- The Core representation mimics the high-level Copilot stream, but the Core -- representation contains information about the types of elements in the -- stream. data Expr a where - Const :: Typeable a => Type a -> a -> Expr a - Drop :: Typeable a => Type a -> DropIdx -> Id -> Expr a - Local :: Typeable a => Type a -> Type b -> Name -> Expr a -> Expr b -> Expr b - Var :: Typeable a => Type a -> Name -> Expr a - ExternVar :: Typeable a => Type a -> Name -> Maybe [a] -> Expr a - Op1 :: Typeable a => Op1 a b -> Expr a -> Expr b - Op2 :: (Typeable a, Typeable b) => Op2 a b c -> Expr a -> Expr b -> Expr c - Op3 :: (Typeable a, Typeable b, Typeable c) => Op3 a b c d -> Expr a -> Expr b -> Expr c -> Expr d - Label :: Typeable a => Type a -> String -> Expr a -> Expr a - --------------------------------------------------------------------------------- + Const :: Typeable a + => Type a -> a -> Expr a + + Drop :: Typeable a + => Type a -> DropIdx -> Id -> Expr a + + Local :: Typeable a + => Type a -> Type b -> Name -> Expr a -> Expr b -> Expr b + + Var :: Typeable a + => Type a -> Name -> Expr a + + ExternVar :: Typeable a + => Type a -> Name -> Maybe [a] -> Expr a + + Op1 :: Typeable a + => Op1 a b -> Expr a -> Expr b + + Op2 :: (Typeable a, Typeable b) + => Op2 a b c -> Expr a -> Expr b -> Expr c + + Op3 :: (Typeable a, Typeable b, Typeable c) + => Op3 a b c d -> Expr a -> Expr b -> Expr c -> Expr d + + Label :: Typeable a + => Type a -> String -> Expr a -> Expr a -- | A untyped expression that carries the information about the type of the -- expression as a value, as opposed to exposing it at type level (using an -- existential). -data UExpr = forall a. Typeable a => UExpr - { uExprType :: Type a - , uExprExpr :: Expr a } +data UExpr = forall a . Typeable a => UExpr (Type a) (Expr a) diff --git a/copilot-core/src/Copilot/Core/External.hs b/copilot-core/src/Copilot/Core/External.hs deleted file mode 100644 index ffa78188f..000000000 --- a/copilot-core/src/Copilot/Core/External.hs +++ /dev/null @@ -1,85 +0,0 @@ --------------------------------------------------------------------------------- --- Copyright © 2011 National Institute of Aerospace / Galois, Inc. --------------------------------------------------------------------------------- - -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE Rank2Types #-} - --- | Internal Copilot Core representation of Copilot externs. -module Copilot.Core.External - ( ExtVar (..) - , externVars - ) where - -import Copilot.Core.Expr -import Copilot.Core.Type -import Copilot.Core.Spec -import Data.DList (DList, empty, singleton, append, concat, toList) -import Data.List (nubBy) -import Prelude hiding (all, concat, foldr) - -import Data.Typeable (Typeable) - --------------------------------------------------------------------------------- - --- | An extern variable declaration, together with the type of the underlying --- extern. -data ExtVar = ExtVar - { externVarName :: Name - , externVarType :: UType } - --------------------------------------------------------------------------------- - --- | List of all externs used in a specification. -externVars :: Spec -> [ExtVar] -externVars = nubBy eqExt . toList . all externVarsExpr - where - eqExt :: ExtVar -> ExtVar -> Bool - eqExt ExtVar { externVarName = name1 } ExtVar { externVarName = name2 } = - name1 == name2 - --- | Extract all externs used in a Copilot expression. -externVarsExpr :: Expr a -> DList ExtVar -externVarsExpr e0 = case e0 of - Const _ _ -> empty - Drop _ _ _ -> empty - Local _ _ _ e1 e2 -> externVarsExpr e1 `append` externVarsExpr e2 - Var _ _ -> empty - ExternVar t name _ -> singleton (ExtVar name (UType t)) - Op1 _ e -> externVarsExpr e - Op2 _ e1 e2 -> externVarsExpr e1 `append` externVarsExpr e2 - Op3 _ e1 e2 e3 -> externVarsExpr e1 `append` - externVarsExpr e2 `append` - externVarsExpr e3 - Label _ _ e -> externVarsExpr e - --- | Extract all expressions used in an untyped Copilot expression. -externVarsUExpr :: UExpr -> DList ExtVar -externVarsUExpr UExpr { uExprExpr = e } = externVarsExpr e - --------------------------------------------------------------------------------- - --- | Apply a function to all expressions in a specification, concatenating the --- results. -all :: (forall a . Expr a -> DList b) -> Spec -> DList b -all f spec = - concat (fmap (allStream) (specStreams spec)) `append` - concat (fmap allTrigger (specTriggers spec)) `append` - concat (fmap allObserver (specObservers spec)) - - where - - allStream - Stream { streamExpr = e } = f e - - allTrigger - Trigger - { triggerGuard = e - , triggerArgs = args } = f e `append` concat (fmap allUExpr args) - - allUExpr - (UExpr _ e1) = f e1 - - allObserver - Observer { observerExpr = e } = f e diff --git a/copilot-core/src/Copilot/Core/Locals.hs b/copilot-core/src/Copilot/Core/Locals.hs deleted file mode 100644 index 5b096444d..000000000 --- a/copilot-core/src/Copilot/Core/Locals.hs +++ /dev/null @@ -1,99 +0,0 @@ --------------------------------------------------------------------------------- --- Copyright © 2011 National Institute of Aerospace / Galois, Inc. --------------------------------------------------------------------------------- - --- | Let expressions. --- --- Although Copilot is a DSL embedded in Haskell and Haskell does support let --- expressions, we want Copilot to be able to implement explicit sharing, to --- detect when the same stream is being used in multiple places in a --- specification and avoid recomputing it unnecessarily. - -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE ExistentialQuantification #-} - -module Copilot.Core.Locals - {-# DEPRECATED "This module is deprecated." #-} - ( Loc (..) - , locals - ) where - -import Copilot.Core hiding (toList) -import Data.DList (DList, empty, singleton, append, concat, toList) -import Data.List (nubBy) -import Prelude hiding (concat, foldr) - --------------------------------------------------------------------------------- - --- | A local definition, with a given stream name and stream type. -data Loc = forall a . Loc - { localName :: Name - , localType :: Type a } - --- | Show the underlying stream name. -instance Show Loc where - show Loc { localName = name } = name - --------------------------------------------------------------------------------- - --- | Obtain all the local definitions in a specification. -locals :: Spec -> [Loc] -locals - Spec - { specStreams = streams - , specTriggers = triggers - , specObservers = observers - } = nubBy eqLoc . toList $ - concat (fmap locsStream streams) `append` - concat (fmap locsTrigger triggers) `append` - concat (fmap locsObserver observers) - - where - - eqLoc :: Loc -> Loc -> Bool - eqLoc Loc { localName = name1 } Loc { localName = name2 } = - name1 == name2 - --------------------------------------------------------------------------------- - --- | Obtain all the local definitions in a stream. -locsStream :: Stream -> DList Loc -locsStream Stream { streamExpr = e } = locsExpr e - --------------------------------------------------------------------------------- - --- | Obtain all the local definitions in a trigger. -locsTrigger :: Trigger -> DList Loc -locsTrigger Trigger { triggerGuard = e, triggerArgs = args } = - locsExpr e `append` concat (fmap locsUExpr args) - - where - - locsUExpr :: UExpr -> DList Loc - locsUExpr (UExpr _ e1) = locsExpr e1 - --------------------------------------------------------------------------------- - --- | Obtain all the local definitions in an observer. -locsObserver :: Observer -> DList Loc -locsObserver Observer { observerExpr = e } = locsExpr e - --------------------------------------------------------------------------------- - --- | Obtain all the local definitions in an expression. -locsExpr :: Expr a -> DList Loc -locsExpr e0 = case e0 of - Const _ _ -> empty - Drop _ _ _ -> empty - Local t _ name e1 e2 -> singleton (Loc name t) - `append` locsExpr e1 - `append` locsExpr e2 - Var _ _ -> empty - ExternVar _ _ _ -> empty - Op1 _ e -> locsExpr e - Op2 _ e1 e2 -> locsExpr e1 `append` locsExpr e2 - Op3 _ e1 e2 e3 -> locsExpr e1 `append` locsExpr e2 - `append` locsExpr e3 - Label _ _ e -> locsExpr e - --------------------------------------------------------------------------------- diff --git a/copilot-core/src/Copilot/Core/Operators.hs b/copilot-core/src/Copilot/Core/Operators.hs index a8acc17af..172353ee2 100644 --- a/copilot-core/src/Copilot/Core/Operators.hs +++ b/copilot-core/src/Copilot/Core/Operators.hs @@ -1,25 +1,26 @@ --------------------------------------------------------------------------------- --- Copyright © 2011 National Institute of Aerospace / Galois, Inc. --------------------------------------------------------------------------------- +{-# LANGUAGE GADTs #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE Safe #-} -{-# LANGUAGE Safe #-} -{-# LANGUAGE GADTs, Rank2Types #-} - --- | Internal representation of Copilot operators. +-- | +-- Description: Internal representation of Copilot operators. +-- Copyright: (c) 2011 National Institute of Aerospace / Galois, Inc. module Copilot.Core.Operators - ( Op1 (..) - , Op2 (..) - , Op3 (..) - ) where - -import GHC.TypeLits (KnownSymbol) + ( Op1 (..) + , Op2 (..) + , Op3 (..) + ) + where -import Copilot.Core.Type (Type(..), Field(..)) -import Copilot.Core.Type.Array (Array) -import Data.Bits -import Data.Word (Word32) +-- External imports +import Data.Bits (Bits) +import Data.Typeable (Typeable) +import Data.Word (Word32) +import GHC.TypeLits (KnownSymbol) --------------------------------------------------------------------------------- +-- Internal imports +import Copilot.Core.Type (Field (..), Type (..)) +import Copilot.Core.Type.Array (Array) -- | Unary operators. data Op1 a b where @@ -50,7 +51,7 @@ data Op1 a b where Ceiling :: RealFrac a => Type a -> Op1 a a Floor :: RealFrac a => Type a -> Op1 a a -- Bitwise operators. - BwNot :: Bits a => Type a -> Op1 a a + BwNot :: Bits a => Type a -> Op1 a a -- Casting operator. Cast :: (Integral a, Num b) => Type a -> Type b -> Op1 a b -- ^ Casting operator. @@ -90,14 +91,21 @@ data Op2 a b c where BwAnd :: Bits a => Type a -> Op2 a a a BwOr :: Bits a => Type a -> Op2 a a a BwXor :: Bits a => Type a -> Op2 a a a - BwShiftL :: ( Bits a, Integral b ) => Type a -> Type b -> Op2 a b a - BwShiftR :: ( Bits a, Integral b ) => Type a -> Type b -> Op2 a b a + BwShiftL :: (Bits a, Integral b) => Type a -> Type b -> Op2 a b a + BwShiftR :: (Bits a, Integral b) => Type a -> Type b -> Op2 a b a -- Array operator. - Index :: Type (Array n t) -> Op2 (Array n t) Word32 t -- ^ Array access/projection of an array element. + -- Struct operator. + UpdateField :: (Typeable b, KnownSymbol s, Show b) + => Type a -> Type b -> (a -> Field s b) -> Op2 a b a + -- ^ Update a field of a struct. + -- | Ternary operators. data Op3 a b c d where - -- Conditional operator: - Mux :: Type a -> Op3 Bool a a a + -- Conditional operator. + Mux :: Type a -> Op3 Bool a a a + -- Array operator. + UpdateArray :: Type (Array n t) -> Op3 (Array n t) Word32 t (Array n t) + -- ^ Update an element of an array. diff --git a/copilot-core/src/Copilot/Core/PrettyDot.hs b/copilot-core/src/Copilot/Core/PrettyDot.hs deleted file mode 100644 index 1b5f6e73d..000000000 --- a/copilot-core/src/Copilot/Core/PrettyDot.hs +++ /dev/null @@ -1,329 +0,0 @@ --------------------------------------------------------------------------------- --- Copyright © 2011 National Institute of Aerospace / Galois, Inc. --------------------------------------------------------------------------------- - --- | A pretty printer for Copilot specifications as GraphViz/dot graphs. - -{-# LANGUAGE Safe #-} -{-# LANGUAGE GADTs #-} - -module Copilot.Core.PrettyDot - ( prettyPrintDot - , prettyPrintExprDot - ) where - -import Copilot.Core -import Copilot.Core.Type.Show (showWithType, ShowType(..), showType) -import Prelude hiding (id, (<>)) -import Text.PrettyPrint.HughesPJ -import Data.List (intersperse) -import Text.Printf - --- | Create a temporary/internal name from an extern variable name. -mkExtTmpVar :: String -> String -mkExtTmpVar = ("ext_" ++) - --------------------------------------------------------------------------------- - --- | Pretty print a Copilot Expression as a GraphViz graph part. --- --- See the --- for details. -ppExprDot :: Int -- ^ Index or ID of the next node in the graph. - -> Int -- ^ Index or ID of the parent node in the graph. - -> Bool -- ^ Mark externs with the prefix @externV:@. - -> Expr a -- ^ The expression to pretty print. - -> (Doc,Int) -ppExprDot ii pere bb e0 = case e0 of - Const t x -> (text (printf "%s [label=\"const: %s\",color=red1, style=filled]\n" (show ii::String) ((showWithType Haskell t x)::String) ) - <> text (printf "%s -> %s\n" (show pere::String) (show ii::String)),ii+1) - Drop _ 0 id -> (text (printf "%s [label=\"stream: %s\",color=crimson, style=filled]\n" (show ii::String) (show id::String) ) - <> text (printf "%s -> %s\n" (show pere::String) (show ii::String)),ii+1) - Drop _ i id -> (text (printf "%s [label=\"drop %s: \nstream: %s\",color=crimson, style=filled]\n" (show ii::String) (show i::String) (show id::String) ) - <> text (printf "%s -> %s\n" (show pere::String) (show ii::String)),ii+1) - ExternVar _ name _ -> (if bb - then (text (printf "%s [label=\"externV: %s\",color=cyan1, style=filled]\n" (show ii::String) (name::String)) <> text (printf "%s -> %s\n" (show pere::String) (show ii::String))) - else (text (printf "%s [label=\"%s\",color=cyan1, style=filled]\n" (show ii::String) (mkExtTmpVar name)) <> text (printf "%s -> %s\n" (show pere::String) (show ii::String))) - ,ii+1) - Local _ _ name e1 e2 -> let (r1, i1) = ppExprDot (ii+2) (ii+1) bb e1 - in let (r2, i2) = ppExprDot (i1) ii bb e2 - in (text (printf "%s [label=\"local:\",color=blue, style=filled]\n" (show ii::String) ) - <> text (printf "%s -> %s\n" (show pere::String) (show ii::String)) - <> text (printf "%s [label=\"def: %s\",color=blue, style=filled]\n" ((show $ ii+1)::String) (name::String) ) - <> text (printf "%s -> %s\n" (show ii::String) (show $ ii+1::String)) - <> r1 - <> r2 ,i2) - - Var _ name -> (text (printf "%s [label=\"var: %s\",color=blue, style=filled]\n" (show ii::String) (name::String) ) - <> text (printf "%s -> %s\n" (show pere::String) (show ii::String)),ii+1) - - Op1 op e -> let (r1,i1) = ppExprDot (ii+1) ii bb e - in (text (printf "%s [label=\"op1: %s\",color=green4, style=filled]\n" (show ii::String) (ppOp1 op::String)) - <> text (printf "%s -> %s\n" (show pere::String) (show ii::String)) - <> r1,i1) - - Op2 op e1 e2 -> let (r1,i1) = ppExprDot (ii+1) ii bb e1 - in let (r2,i2) = ppExprDot i1 ii bb e2 - in (text (printf "%s [label=\"op2: %s\",color=green4, style=filled]\n" (show ii::String) (ppOp2 op::String)) - <> text (printf "%s -> %s\n" (show pere::String) (show ii::String)) - <> r1 - <> r2 ,i2) - Op3 op e1 e2 e3 -> let (r1,i1) = ppExprDot (ii+1) ii bb e1 - in let (r2,i2) = ppExprDot i1 ii bb e2 - in let (r3,i3) = ppExprDot i2 ii bb e3 - in (text (printf "%s [label=\"op3: %s\",color=green4, style=filled]\n" (show ii::String) (ppOp3 op::String)) - <> text (printf "%s -> %s\n" (show pere::String) (show ii::String)) - <> r1 - <> r2 - <> r3 ,i3) - - Label _ s e -> let (r1,i1) = ppExprDot (ii+1) ii bb e - in (text (printf "%s [label=\"label: %s\",color=plum, style=filled]\n" (show ii::String) (s::String)) - <> text (printf "%s -> %s\n" (show pere::String) (show ii::String)) - <> r1,i1) - --- | Pretty print an untyped Copilot Expression as a graphiViz graph part. --- --- See the --- for details. -ppUExpr :: Int -- ^ Index or ID of the next node in the graph. - -> Int -- ^ Index or ID of the parent node in the graph. - -> Bool -- ^ Mark externs with the prefix @externV:@. - -> UExpr -- ^ The expression to pretty print. - -> (Doc, Int) -ppUExpr i pere bb UExpr { uExprExpr = e0 } = ppExprDot i pere bb e0 - --- | Pretty print a unary operator. -ppOp1 :: Op1 a b -> String -ppOp1 op = case op of - Not -> "not" - Abs _ -> "abs" - Sign _ -> "signum" - Recip _ -> "recip" - 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" - Ceiling _ -> "ceiling" - Floor _ -> "floor" - BwNot _ -> "~" - Cast _ _ -> "(cast)" - --- | Pretty print a binary operator. -ppOp2 :: Op2 a b c -> String -ppOp2 op = case op of - And -> "&&" - Or -> "||" - Add _ -> "+" - Sub _ -> "-" - Mul _ -> "*" - Div _ -> "div" - Mod _ -> "mod" - Fdiv _ -> "/" - Pow _ -> "**" - Logb _ -> "logBase" - Atan2 _ -> "atan2" - Eq _ -> "==" - Ne _ -> "/=" - Le _ -> "<=" - Ge _ -> ">=" - Lt _ -> "<" - Gt _ -> ">" - BwAnd _ -> "&" - BwOr _ -> "|" - BwXor _ -> "^" - BwShiftL _ _ -> "<<" - BwShiftR _ _ -> ">>" - --- | Pretty print a ternary operator. -ppOp3 :: Op3 a b c d -> String -ppOp3 op = case op of - Mux _ -> "mux" - --------------------------------------------------------------------------------- - --- | Pretty print a stream as a GraphViz graph part. -ppStream :: Int -- ^ Index or ID of the next node in the graph. - -> Stream -- ^ Stream to pretty print - -> (Doc, Int) -ppStream i - Stream - { streamId = id - , streamBuffer = buffer - , streamExpr = e - , streamExprType = t - } - = - (text (printf "%s [label=\"stream: %s\ntype: %s\",color=mediumblue, style=filled]\n" (show i::String) (show id::String) (showType t::String)) - <> text (printf "%s [label=\"++\",color=yellow, style=filled]\n" ((show $ i+1)::String)) - <> text (printf "%s -> %s\n" (show i::String) ((show $ i+1)::String)) - <> text (printf "%s [label=\"[%s]\",color=green, style=filled]\n" ((show $ i+2)::String) ((concat $ intersperse "," $ map (showWithType Haskell t) buffer )) ::String) - <> text (printf "%s -> %s\n" (show (i+1)::String) ((show $ i+2)::String)) - <> r1, i1) - where (r1, i1) = ppExprDot (i+3) (i+1) True e --------------------------------------------------------------------------------- - --- | Pretty print a trigger as a GraphViz graph part. -ppTrigger :: Int -- ^ Index or ID of the next node in the graph. - -> Trigger -- ^ Trigger to pretty print - -> (Doc, Int) -ppTrigger i - Trigger - { triggerName = name - , triggerGuard = e - , triggerArgs = args } - = ( text (printf "%s [label=\"trigger: %s\",color=mediumblue, style=filled]\n" (show i::String) (name::String) ) - <> text (printf "%s [label=\"guard\",color=yellow, style=filled]\n" ((show $ i+1)::String)) - <> text (printf "%s -> %s\n" (show i::String) ((show $ i+1)::String)) - <> r1 - <> text (printf "%s [label=\"args\",color=yellow, style=filled]\n" (show i1::String)) - <> text (printf "%s -> %s\n" (show i::String) (show i1::String)) - <> (vcat (r2)) - ,i2) - where - (r1, i1) = ppExprDot (i+2) (i+1) True e - (r2, i2) = ppUExprL (i1+1) (i1) True args - --- | Pretty print a list of untyped Copilot Expressions as a GraphViz graph --- part. -ppUExprL :: Int -- ^ Index or ID of the next node in the graph. - -> Int -- ^ Index or ID of the parent node in the graph. - -> Bool -- ^ Mark externs with the prefix @externV:@. - -> [UExpr] -- ^ The list of expressions to pretty print. - -> ([Doc], Int) -ppUExprL i _ _ [] = ([], i) - -ppUExprL i pere bb (a:b) = ((r1:r2), i2) - where - (r1, i1) = ppUExpr i pere bb a - (r2, i2) = ppUExprL i1 pere bb b - --------------------------------------------------------------------------------- - --- | Pretty print an observer as a GraphViz graph part. -ppObserver :: Int -- ^ Index or ID of the next node in the graph. - -> Observer -- ^ Observer to pretty print - -> (Doc, Int) -ppObserver i - Observer - { observerName = name - , observerExpr = e } - = - (text (printf "%s [label=\"observer: \n%s\",color=mediumblue, style=filled]\n" (show i::String) name::String) - <> r1, i1) - where (r1, i1) = ppExprDot (i+1) i True e --------------------------------------------------------------------------------- - --- | Pretty print a property as a GraphViz graph part. -ppProperty :: Int -- ^ Index or ID of the next node in the graph. - -> Property -- ^ Property to pretty print - -> (Doc, Int) -ppProperty i - Property - { propertyName = name - , propertyExpr = e } - = - (text (printf "%s [label=\"property: \n%s\",color=mediumblue, style=filled]\n" (show i::String) name::String) - <> r1, i1) - where (r1, i1) = ppExprDot (i+1) i True e - --------------------------------------------------------------------------------- - - --------------------------------------------------------------------------------- - --- | Pretty print a list of streams as a GraphViz graph part. -ppStreamL :: Int -- ^ Index or ID of the next node in the graph. - -> [Stream] -- ^ List of streams to pretty print - -> (Doc, Int) -ppStreamL i [] = (empty,i) - -ppStreamL i (a:b) = ((s1$$s2),(i2)) - where - (s1,i1) = ppStream i a - (s2,i2) = ppStreamL i1 b - --------------------------------------------------------------------------------- - --- | Pretty print a list of triggers as a GraphViz graph part. -ppTriggerL :: Int -- ^ Index or ID of the next node in the graph. - -> [Trigger] -- ^ List of triggers to pretty print - -> (Doc, Int) -ppTriggerL i [] = (empty,i) - -ppTriggerL i (a:b) = ((s1$$s2),(i2)) - where - (s1,i1) = ppTrigger i a - (s2,i2) = ppTriggerL i1 b - --------------------------------------------------------------------------------- - --- | Pretty print a list of observers as a GraphViz graph part. -ppObserverL :: Int -- ^ Index or ID of the next node in the graph. - -> [Observer] -- ^ List of observers to pretty print - -> (Doc, Int) -ppObserverL i [] = (empty,i) - -ppObserverL i (a:b) = ((s1$$s2),(i2)) - where - (s1,i1) = ppObserver i a - (s2,i2) = ppObserverL i1 b - - --------------------------------------------------------------------------------- - --- | Pretty print a list of properties as a GraphViz graph part. -ppPropertyL :: Int -- ^ Index or ID of the next node in the graph. - -> [Property] -- ^ List of properties to pretty print - -> (Doc, Int) -ppPropertyL i [] = (empty,i) - -ppPropertyL i (a:b) = ((s1$$s2),(i2)) - where - (s1,i1) = ppProperty i a - (s2,i2) = ppPropertyL i1 b - --------------------------------------------------------------------------------- - --- | Pretty-print a Copilot specification as a GraphViz/dot graph. -ppSpecDot :: Int -- ^ Index or ID of the next node in the graph. - -> Spec -- ^ Spec to pretty print. - -> (Doc, Int) -ppSpecDot i spec = - ((aa $$ cs $$ ds $$ es $$ fs $$ bb),i4) - where - aa = text "digraph G {\nnode [shape=box]\n" - (cs, i1) = ppStreamL i (specStreams spec) - (ds, i2) = ppTriggerL i1 (specTriggers spec) - (es, i3) = ppObserverL i2 (specObservers spec) - (fs, i4) = ppPropertyL i3 (specProperties spec) - bb = text "\n}\n" - --------------------------------------------------------------------------------- - --- | Pretty-print a Copilot expression as a GraphViz/dot graph. -prettyPrintExprDot :: Bool -- ^ Mark externs with the prefix @externV:@. - -> Expr a -- ^ The expression to pretty print. - -> String -prettyPrintExprDot bb s = render rr - where - (r1, _) = ppExprDot 1 0 bb s - rr = text "digraph G {\nnode [shape=box]\n" $$ (text "0 [label=\"file: \n?????\",color=red, style=filled]\n") <> r1 $$ text "\n}\n" - --- | Pretty-print a Copilot specification as a GraphViz/dot graph. -prettyPrintDot :: Spec -> String -prettyPrintDot s = render r1 - where (r1, _) = ppSpecDot 0 s - --------------------------------------------------------------------------------- diff --git a/copilot-core/src/Copilot/Core/Spec.hs b/copilot-core/src/Copilot/Core/Spec.hs index ba6edeba9..e8972c928 100644 --- a/copilot-core/src/Copilot/Core/Spec.hs +++ b/copilot-core/src/Copilot/Core/Spec.hs @@ -1,78 +1,94 @@ --------------------------------------------------------------------------------- --- Copyright © 2011 National Institute of Aerospace / Galois, Inc. --------------------------------------------------------------------------------- +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE Safe #-} -{-# LANGUAGE Safe #-} -{-# LANGUAGE ExistentialQuantification, GADTs #-} - --- | Copilot specifications constitute the main declaration of Copilot modules. +-- | +-- Copyright: (c) 2011 National Institute of Aerospace / Galois, Inc. +-- +-- Copilot specifications constitute the main declaration of Copilot modules. -- -- A specification normally contains the association between streams to monitor -- and their handling functions, or streams to observe, or a theorem that must -- be proved. -- --- In order to be executed, high-level Copilot Language Spec must be turned --- into Copilot Core's 'Spec'. This module defines the low-level Copilot Core --- representations for Specs and the main types of element in a spec.. +-- In order to be executed, a high-level Copilot Language @Spec@ must be +-- turned into a Copilot Core 'Spec'. This module defines the low-level Copilot +-- Core representation for 'Spec' and the main types of element in a spec. module Copilot.Core.Spec - ( Stream (..) - , Observer (..) - , Trigger (..) - , Spec (..) - , Property (..) - ) where + ( Stream (..) + , Observer (..) + , Trigger (..) + , Spec (..) + , Property (..) + , Prop (..) + , extractProp + ) + where -import Copilot.Core.Expr (Name, Id, Expr, UExpr) -import Copilot.Core.Type (Type, Typed) +-- External imports import Data.Typeable (Typeable) --------------------------------------------------------------------------------- +-- Internal imports +import Copilot.Core.Expr (Expr, Id, Name, UExpr) +import Copilot.Core.Type (Type, Typed) --- | A stream in an infinite succession of values of the same type. +-- | A stream is an infinite succession of values of the same type. -- --- Stream can carry different types of data. Boolean streams play a special +-- Streams can carry different types of data. Boolean streams play a special -- role: they are used by other parts (e.g., 'Trigger') to detect when the -- properties being monitored are violated. -data Stream = forall a. (Typeable a, Typed a) => Stream - { streamId :: Id - , streamBuffer :: [a] - , streamExpr :: Expr a - , streamExprType :: Type a } - --------------------------------------------------------------------------------- +data Stream = forall a . (Typeable a, Typed a) => Stream + { streamId :: Id + , streamBuffer :: [a] + , streamExpr :: Expr a + , streamExprType :: Type a + } -- | An observer, representing a stream that we observe during interpretation -- at every sample. -data Observer = forall a. Typeable a => Observer +data Observer = forall a . Typeable a => Observer { observerName :: Name , observerExpr :: Expr a - , observerExprType :: Type a } - --------------------------------------------------------------------------------- + , observerExprType :: Type a + } -- | A trigger, representing a function we execute when a boolean stream becomes -- true at a sample. data Trigger = Trigger - { triggerName :: Name - , triggerGuard :: Expr Bool - , triggerArgs :: [UExpr] } - --------------------------------------------------------------------------------- + { triggerName :: Name + , triggerGuard :: Expr Bool + , triggerArgs :: [UExpr] + } -- | A property, representing a boolean stream that is existentially or -- universally quantified over time. data Property = Property - { propertyName :: Name - , propertyExpr :: Expr Bool } + { propertyName :: Name + , propertyProp :: Prop + } --------------------------------------------------------------------------------- +-- | A proposition, representing a boolean stream that is existentially or +-- universally quantified over time. +data Prop + = Forall (Expr Bool) + | Exists (Expr Bool) + +-- | Extract the underlying stream from a quantified proposition. +-- +-- Think carefully before using this function, as this function will remove the +-- quantifier from a proposition. Universally quantified streams usually require +-- separate treatment from existentially quantified ones, so carelessly using +-- this function to remove quantifiers can result in hard-to-spot soundness +-- bugs. +extractProp :: Prop -> Expr Bool +extractProp (Forall e) = e +extractProp (Exists e) = e -- | A Copilot specification is a list of streams, together with monitors on -- these streams implemented as observers, triggers or properties. data Spec = Spec - { specStreams :: [Stream] - , specObservers :: [Observer] - , specTriggers :: [Trigger] - , specProperties :: [Property] } - --------------------------------------------------------------------------------- + { specStreams :: [Stream] + , specObservers :: [Observer] + , specTriggers :: [Trigger] + , specProperties :: [Property] + } diff --git a/copilot-core/src/Copilot/Core/Type.hs b/copilot-core/src/Copilot/Core/Type.hs index d0e75ecea..b290810c2 100644 --- a/copilot-core/src/Copilot/Core/Type.hs +++ b/copilot-core/src/Copilot/Core/Type.hs @@ -1,88 +1,137 @@ --------------------------------------------------------------------------------- --- Copyright © 2011 National Institute of Aerospace / Galois, Inc. --------------------------------------------------------------------------------- - --- | Typing for Core. +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +-- | +-- Description: Typing for Core. +-- Copyright: (c) 2011 National Institute of Aerospace / Galois, Inc. -- -- All expressions and streams in Core are accompanied by a representation of -- the types of the underlying expressions used or carried by the streams. -- This information is needed by the compiler to generate code, since it must -- initialize variables and equivalent representations for those types in -- the target languages. - -{-# LANGUAGE Safe #-} -{-# LANGUAGE ExistentialQuantification - , GADTs - , KindSignatures - , ScopedTypeVariables - , UndecidableInstances - , FlexibleContexts - , DataKinds - , FlexibleInstances -#-} - module Copilot.Core.Type - ( Type (..) - , Typed (..) - , UType (..) - , SimpleType (..) - - , tysize - , tylength - - , Value (..) - , toValues - , Field (..) - , typename - - , Struct - , fieldname - , accessorname - ) where - -import Data.Int -import Data.Word -import Copilot.Core.Type.Equality -import Copilot.Core.Type.Array - -import Data.Typeable (Typeable, typeRep) - -import GHC.TypeLits (KnownNat, natVal, Symbol, KnownSymbol, symbolVal) -import Data.Proxy (Proxy (..)) - -import Data.List (intercalate) + ( Type (..) + , Typed (..) + , typeOfDefault + , UType (..) + , SimpleType (..) + + , typeSize + , typeLength + + , Value (..) + , toValues + , toValuesDefault + , Field (..) + , typeName + , typeNameDefault + + , Struct + , fieldName + , accessorName + , updateField + , updateFieldDefault + ) + where + +-- External imports +import Data.Char (isLower, isUpper, toLower) +import Data.Coerce (coerce) +import Data.Int (Int16, Int32, Int64, Int8) +import Data.List (intercalate) +import Data.Proxy (Proxy (..)) +import Data.Type.Equality as DE +import Data.Typeable (Typeable, eqT, typeRep) +import Data.Word (Word16, Word32, Word64, Word8) +import GHC.Generics (Datatype (..), D1, Generic (..), K1 (..), M1 (..), + U1 (..), (:*:) (..)) +import GHC.TypeLits (KnownNat, KnownSymbol, Symbol, natVal, sameNat, + sameSymbol, symbolVal) + +-- Internal imports +import Copilot.Core.Type.Array (Array) -- | The value of that is a product or struct, defined as a constructor with -- several fields. class Struct a where -- | Returns the name of struct in the target language. - typename :: a -> String + typeName :: a -> String + -- | Transforms all the struct's fields into a list of values. toValues :: a -> [Value a] + -- | Update the value of a struct field. This is only used by the Copilot + -- interpreter. + -- + -- If you do not plan to use the interpreter, you can omit an implementation + -- of this method. If you do so, it is recommended that you derive a 'Generic' + -- instance for the struct data type. This is because in a future release, the + -- default implementation of 'updateField' (which will be picked if there is + -- not a manually written implementation) will be changed to require a + -- 'Generic' instance. + -- + -- In order to implement 'updateField', pick one of the following approaches: + -- + -- * Derive a 'Generic' instance for the struct data type and then define + -- @'updateField' = 'updateFieldDefault'@ in the 'Struct' instance. + -- + -- * Manually implement 'updateField' by doing the following for each 'Field' + -- in a struct: + -- + -- 1. Check that the name of the 'Field' matches the name of the supplied + -- 'Value' (using 'GHC.TypeLits.sameSymbol'). + -- + -- 2. Check that the type of the 'Field' matches the 'Type' of the supplied + -- 'Value' (using 'DE.testEquality'). + -- + -- 3. If both (1) and (2) succeed, update the corresponding struct field + -- using a record update. + -- + -- For a complete end-to-end example that demonstrates how to manually + -- implement 'updateField' and use it in the Copilot interpreter, see the + -- @examples/StructsUpdateField.hs@ example in the @copilot@ library. + updateField :: a -> Value t -> a + updateField = error $ unlines + [ "Field updates not supported for this type." + , "(Perhaps you need to implement 'updateField' for a 'Struct' instance?)" + ] + -- | The field of a struct, together with a representation of its type. -data Value a = forall s t. (Typeable t, KnownSymbol s, Show t) => Value (Type t) (Field s t) +data Value a = + forall s t . (Typeable t, KnownSymbol s, Show t) => Value (Type t) (Field s t) -- | A field in a struct. The name of the field is a literal at the type -- level. data Field (s :: Symbol) t = Field t -- | Extract the name of a field. -fieldname :: forall s t. KnownSymbol s => Field s t -> String -fieldname _ = symbolVal (Proxy :: Proxy s) +fieldName :: forall s t . KnownSymbol s => Field s t -> String +fieldName _ = symbolVal (Proxy :: Proxy s) -- | Extract the name of an accessor (a function that returns a field of a -- struct). -accessorname :: forall a s t. (Struct a, KnownSymbol s) => (a -> Field s t) -> String -accessorname _ = symbolVal (Proxy :: Proxy s) +accessorName :: forall a s t . (Struct a, KnownSymbol s) + => (a -> Field s t) -> String +accessorName _ = symbolVal (Proxy :: Proxy s) instance (KnownSymbol s, Show t) => Show (Field s t) where - show f@(Field v) = fieldname f ++ ":" ++ show v + show f@(Field v) = fieldName f ++ ":" ++ show v instance {-# OVERLAPPABLE #-} (Typed t, Struct t) => Show t where - show t = "<" ++ fields ++ ">" where - fields = intercalate "," $ map showfield (toValues t) - showfield (Value _ field) = show field + show t = "<" ++ fields ++ ">" + where + fields = intercalate "," $ map showfield (toValues t) + showfield (Value _ field) = show field -- | A Type representing the types of expressions or values handled by -- Copilot Core. @@ -91,48 +140,60 @@ instance {-# OVERLAPPABLE #-} (Typed t, Struct t) => Show t where -- former, the length of the array is part of the type. In the latter, the -- names of the fields are part of the type. data Type :: * -> * where - Bool :: Type Bool - Int8 :: Type Int8 - Int16 :: Type Int16 - Int32 :: Type Int32 - Int64 :: Type Int64 - Word8 :: Type Word8 - Word16 :: Type Word16 - Word32 :: Type Word32 - Word64 :: Type Word64 - Float :: Type Float - Double :: Type Double - Array :: forall n t. ( KnownNat n + Bool :: Type Bool + Int8 :: Type Int8 + Int16 :: Type Int16 + Int32 :: Type Int32 + Int64 :: Type Int64 + Word8 :: Type Word8 + Word16 :: Type Word16 + Word32 :: Type Word32 + Word64 :: Type Word64 + Float :: Type Float + Double :: Type Double + Array :: forall n t . ( KnownNat n , Typed t - , Typed (InnerType t) - , Flatten t (InnerType t) ) => Type t -> Type (Array n t) - Struct :: (Typed a, Struct a) => a -> Type a + Struct :: (Typed a, Struct a) => a -> Type a +deriving instance Show (Type a) -- | Return the length of an array from its type -tylength :: forall n t. KnownNat n => Type (Array n t) -> Int -tylength _ = fromIntegral $ natVal (Proxy :: Proxy n) +typeLength :: forall n t . KnownNat n => Type (Array n t) -> Int +typeLength _ = fromIntegral $ natVal (Proxy :: Proxy n) -- | Return the total (nested) size of an array from its type -tysize :: forall n t. KnownNat n => Type (Array n t) -> Int -tysize ty@(Array ty'@(Array _)) = tylength ty * tysize ty' -tysize ty@(Array _ ) = tylength ty - -instance EqualType Type where - (=~=) Bool Bool = Just Refl - (=~=) Int8 Int8 = Just Refl - (=~=) Int16 Int16 = Just Refl - (=~=) Int32 Int32 = Just Refl - (=~=) Int64 Int64 = Just Refl - (=~=) Word8 Word8 = Just Refl - (=~=) Word16 Word16 = Just Refl - (=~=) Word32 Word32 = Just Refl - (=~=) Word64 Word64 = Just Refl - (=~=) Float Float = Just Refl - (=~=) Double Double = Just Refl - (=~=) _ _ = Nothing - --------------------------------------------------------------------------------- +typeSize :: forall n t . KnownNat n => Type (Array n t) -> Int +typeSize ty@(Array ty'@(Array _)) = typeLength ty * typeSize ty' +typeSize ty@(Array _ ) = typeLength ty + +instance TestEquality Type where + testEquality Bool Bool = Just DE.Refl + testEquality Int8 Int8 = Just DE.Refl + testEquality Int16 Int16 = Just DE.Refl + testEquality Int32 Int32 = Just DE.Refl + testEquality Int64 Int64 = Just DE.Refl + testEquality Word8 Word8 = Just DE.Refl + testEquality Word16 Word16 = Just DE.Refl + testEquality Word32 Word32 = Just DE.Refl + testEquality Word64 Word64 = Just DE.Refl + testEquality Float Float = Just DE.Refl + testEquality Double Double = Just DE.Refl + testEquality (Array t1) (Array t2) = + testArrayEquality t1 t2 + where + testArrayEquality :: forall n1 a1 n2 a2. + (KnownNat n1, KnownNat n2) + => Type a1 + -> Type a2 + -> Maybe (Array n1 a1 :~: Array n2 a2) + testArrayEquality ty1 ty2 + | Just DE.Refl <- sameNat (Proxy :: Proxy n1) (Proxy :: Proxy n2) + , Just DE.Refl <- testEquality ty1 ty2 + = Just DE.Refl + | otherwise + = Nothing + testEquality (Struct _) (Struct _) = eqT + testEquality _ _ = Nothing -- | A simple, monomorphic representation of types that facilitates putting -- variables in heterogeneous lists and environments in spite of their types @@ -154,27 +215,24 @@ data SimpleType where -- | Type equality, used to help type inference. -{- This instance is necessary, otherwise the type of SArray can't be inferred -} - +-- This instance is necessary, otherwise the type of SArray can't be inferred. instance Eq SimpleType where - SBool == SBool = True - SInt8 == SInt8 = True - SInt16 == SInt16 = True - SInt32 == SInt32 = True - SInt64 == SInt64 = True - SWord8 == SWord8 = True - SWord16 == SWord16 = True - SWord32 == SWord32 = True - SWord64 == SWord64 = True - SFloat == SFloat = True - SDouble == SDouble = True - (SArray t1) == (SArray t2) | Just Refl <- t1 =~= t2 = True - | otherwise = False - SStruct == SStruct = True + SBool == SBool = True + SInt8 == SInt8 = True + SInt16 == SInt16 = True + SInt32 == SInt32 = True + SInt64 == SInt64 = True + SWord8 == SWord8 = True + SWord16 == SWord16 = True + SWord32 == SWord32 = True + SWord64 == SWord64 = True + SFloat == SFloat = True + SDouble == SDouble = True + (SArray t1) == (SArray t2) | Just DE.Refl <- testEquality t1 t2 = True + | otherwise = False + SStruct == SStruct = True _ == _ = False --------------------------------------------------------------------------------- - -- | A typed expression, from which we can obtain the two type representations -- used by Copilot: 'Type' and 'SimpleType'. class (Show a, Typeable a) => Typed a where @@ -182,51 +240,216 @@ class (Show a, Typeable a) => Typed a where simpleType :: Type a -> SimpleType simpleType _ = SStruct --------------------------------------------------------------------------------- - -instance Typed Bool where +instance Typed Bool where typeOf = Bool simpleType _ = SBool -instance Typed Int8 where + +instance Typed Int8 where typeOf = Int8 - simpleType _ = SBool -instance Typed Int16 where + simpleType _ = SInt8 + +instance Typed Int16 where typeOf = Int16 simpleType _ = SInt16 -instance Typed Int32 where + +instance Typed Int32 where typeOf = Int32 simpleType _ = SInt32 -instance Typed Int64 where + +instance Typed Int64 where typeOf = Int64 simpleType _ = SInt64 -instance Typed Word8 where + +instance Typed Word8 where typeOf = Word8 simpleType _ = SWord8 + instance Typed Word16 where typeOf = Word16 simpleType _ = SWord16 + instance Typed Word32 where typeOf = Word32 simpleType _ = SWord32 + instance Typed Word64 where typeOf = Word64 simpleType _ = SWord64 -instance Typed Float where + +instance Typed Float where typeOf = Float simpleType _ = SFloat + instance Typed Double where typeOf = Double simpleType _ = SDouble -instance (Typeable t, Typed t, KnownNat n, Flatten t (InnerType t), Typed (InnerType t)) => Typed (Array n t) where - typeOf = Array typeOf - simpleType (Array t) = SArray t --------------------------------------------------------------------------------- +instance (Typeable t, Typed t, KnownNat n) => Typed (Array n t) where + typeOf = Array typeOf + simpleType (Array t) = SArray t -- | A untyped type (no phantom type). -data UType = forall a . Typeable a => UType { uTypeType :: Type a } +data UType = forall a . Typeable a => UType (Type a) instance Eq UType where UType ty1 == UType ty2 = typeRep ty1 == typeRep ty2 --------------------------------------------------------------------------------- +-- * GHC.Generics-based defaults + +-- | A default implementation of 'typeName' that leverages 'Generic'. In order +-- to use this, make sure you derive a 'Generic' instance for your data type and +-- then define @'typeName' = 'typeNameDefault'@ in its 'Struct' instance. +-- +-- This generates a struct name that consists of the name of the original +-- Haskell data type, but converted to snake_case. +typeNameDefault :: (Generic a, GDatatype (Rep a)) => a -> String +typeNameDefault = convert . gTypeName . from + where + convert :: String -> String + convert = convert' True True + + convert' :: Bool -- ^ Is this the first letter + -> Bool -- ^ Was the previous letter capital + -> String -- ^ Remainder of the string + -> String + convert' _ _ [] = [] + convert' _ v [x] + | v && isUpper x = toLower x : [] + | isUpper x = '_' : toLower x : [] + | otherwise = x : [] + convert' b v (x1:x2:xs) + | not b && isUpper x1 && (isLower x2 || not v) + = '_' : toLower x1 : convert' False (isUpper x1) (x2:xs) + | otherwise + = toLower x1 : convert' False (isUpper x1) (x2:xs) + +-- | A default implementation of 'toValues' that leverages 'Generic'. In order +-- to use this, make sure you derive a 'Generic' instance for your data type and +-- then define @'toValues' = 'toValuesDefault'@ in its 'Struct' instance. +toValuesDefault :: (Generic a, GStruct (Rep a)) => a -> [Value a] +toValuesDefault x = coerce $ gToValues $ from x + +-- | A default implementation of 'updateField' that leverages 'Generic'. In +-- order to use this, make sure you derive a 'Generic' instance for your data +-- type and then define @'updateField' = 'updateFieldDefault'@ in its 'Struct' +-- instance. +updateFieldDefault :: (Generic a, GStruct (Rep a)) => a -> Value t -> a +updateFieldDefault a v@(Value _ field) + | updated = to a' + | otherwise = error $ "Unexpected field: " ++ show field + where + (a', updated) = gUpdateField (from a) v + +-- | A default implementation of 'typeOf' that leverages 'Generic'. In order to +-- use this, make sure you derive a 'Generic' instance for your data type and +-- then define @'typeOf' = 'typeOfDefault'@ in its 'Typed' instance. +typeOfDefault :: + forall a. (Typed a, Struct a, Generic a, GTypedStruct (Rep a)) => Type a +typeOfDefault = Struct $ to $ gStructPlaceholder @(Rep a) @() + +-- ** Generic-based classes (not exported) + +-- | Capture the name of a Haskell data type from its 'Generic' metadata. +class GDatatype f where + -- | Returns the name of a Haskell data type. (Note that this differs from + -- 'typeName', which is expected to return the name of the struct in the + -- /target/ language). + gTypeName :: f p -> String + +-- | The only 'GDatatype' instance we need is for 'D1', which describes +-- 'Datatype' metadata (@d@). We ignore all other metadata (@_f@). +instance Datatype d => GDatatype (D1 d _f) where + gTypeName = datatypeName + +-- | Perform struct-related operations on 'Generic' representation types. +class GStruct f where + -- | Transforms all the struct representation's fields into a list of values. + gToValues :: f p -> [Value (f p)] + + -- | Update the value of a struct representation's field. This returns two + -- things: + -- + -- 1. @f p@: The struct representation, but with the field updated. + -- + -- 2. 'Bool': This is 'True' if the field was successfully updated and 'False' + -- otherwise. If this returns 'False', it is the responsibility of the + -- caller to raise an error. + gUpdateField :: f p -> Value t -> (f p, Bool) + +-- | 'U1' represents a data constructor with no fields. As such, 'gToValues' +-- returns an empty list of 'Value's, and 'gUpdateField' does not update +-- anything. +instance GStruct U1 where + gToValues U1 = [] + gUpdateField u _ = (u, False) + +-- | 'M1' is only used to store metadata, which the 'GStruct' class does not +-- make use of. As such, this instance discards the metadata and recurses. +instance GStruct f => GStruct (M1 _i _c f) where + gToValues (M1 x) = coerce (gToValues x) + gUpdateField (M1 x) v = (M1 x', updated) + where + (x', updated) = gUpdateField x v + +-- | @(':*:')@ represents a data constructor with multiple fields. +instance (GStruct f, GStruct g) => GStruct (f :*: g) where + -- Recursively compute two lists of Values and append them. + gToValues (f :*: g) = coerce (gToValues f) ++ coerce (gToValues g) + -- Recursively attempt to update the field in both branches and combine the + -- updated branches. We will have successfully updated the field if either + -- branch was successfully updated. + gUpdateField (f :*: g) v = (f' :*: g', updatedF || updatedG) + where + (f', updatedF) = gUpdateField f v + (g', updatedG) = gUpdateField g v + +-- | 'K1' represents a single field in a data constructor. This is the base +-- case. +instance (KnownSymbol name, Typed ty, c ~ Field name ty) => + GStruct (K1 _i c) where + -- Now that we have the field, return it in a singleton list. + gToValues (K1 field) = [Value typeOf field] + -- In order to update the field, we check that the field names and types + -- match. If they do, return the updated field and declare the update as + -- successful. Otherwise, return the old field and declare the update as + -- unsuccessful. + gUpdateField (K1 oldField) (Value newTy (newField :: Field newName newTy)) = + case (sameSymbol pName pNewName, testEquality ty newTy) of + (Just Refl, Just Refl) -> (K1 newField, True) + _ -> (K1 oldField, False) + where + pName = Proxy @name + pNewName = Proxy @newName + ty = typeOf @ty + +-- | Compute a 'Generic' placeholder value to use for a struct type. +class GTypedStruct f where + -- | A placeholder value to supply to use in a generic implementation of + -- 'typeOf' for a struct type. + gStructPlaceholder :: f p + +-- | 'U1' represents a data constructor with no fields. As such, +-- 'gStructPlaceholder' simply returns the data constructor with no other +-- information. +instance GTypedStruct U1 where + gStructPlaceholder = U1 + +-- | 'M1' is only used to store metadata, which the 'GTypedStruct' class does +-- not make use of. As such, this instance recursively computes a placeholder +-- value without inspecting the metadata. +instance GTypedStruct f => GTypedStruct (M1 _i _c f) where + gStructPlaceholder = M1 gStructPlaceholder + +-- | @(':*:')@ represents a data constructor with multiple fields. As such, +-- 'gStructPlaceholder' recursively computes placeholders for each field and +-- combines them into the overall data constructor. +instance (GTypedStruct f, GTypedStruct g) => GTypedStruct (f :*: g) where + gStructPlaceholder = gStructPlaceholder :*: gStructPlaceholder + +-- | 'K1' represents a single field in a data constructor. This is the base +-- case. This instance computes a placeholder value that works for any field of +-- any type. +instance (c ~ Field name ty) => GTypedStruct (K1 _i c) where + -- We use 'undefined' as the actual value for the 'Field' because Copilot + -- never inspects the value. + gStructPlaceholder = K1 $ Field undefined diff --git a/copilot-core/src/Copilot/Core/Type/Array.hs b/copilot-core/src/Copilot/Core/Type/Array.hs index 49043ae3a..07c10ba31 100644 --- a/copilot-core/src/Copilot/Core/Type/Array.hs +++ b/copilot-core/src/Copilot/Core/Type/Array.hs @@ -1,34 +1,27 @@ --------------------------------------------------------------------------------- --- Copyright © 2011 National Institute of Aerospace / Galois, Inc. --------------------------------------------------------------------------------- - -{-# LANGUAGE Safe #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} --- | Implementation of an array that uses type literals to store length. No +-- | +-- Copyright: (c) 2011 National Institute of Aerospace / Galois, Inc. +-- +-- Implementation of an array that uses type literals to store length. No -- explicit indexing is used for the input data. Supports arbitrary nesting of -- arrays. - -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeFamilies #-} - module Copilot.Core.Type.Array - ( Array - , array - , flatten - , size - , Flatten - , InnerType - , arrayelems - ) where + ( Array + , array + , arrayElems + , arrayUpdate + ) + where -import GHC.TypeLits (Nat, KnownNat, natVal) -import Data.Proxy (Proxy (..)) +-- External imports +import Data.Proxy (Proxy (..)) +import GHC.TypeLits (KnownNat, Nat, natVal, type(-)) -- | Implementation of an array that uses type literals to store length. data Array (n :: Nat) t where @@ -41,38 +34,31 @@ instance Show t => Show (Array n t) where -- list matches the length of the array at type level. array :: forall n t. KnownNat n => [t] -> Array n t array xs | datalen == typelen = Array xs - | otherwise = error errmsg where - datalen = length xs - typelen = fromIntegral $ natVal (Proxy :: Proxy n) - errmsg = "Length of data (" ++ show datalen ++ - ") does not match length of type (" ++ show typelen ++ ")." - - --- | Association between an array and the type of the elements it contains. -type family InnerType x where - InnerType (Array _ x) = InnerType x - InnerType x = x - --- | Flattening or conversion of arrays to lists. -class Flatten a b where - -- | Flatten an array to a list. - flatten :: Array n a -> [b] - --- | Flattening of plain arrays. -instance Flatten a a where - flatten (Array xs) = xs - --- | Flattening of nested arrays. -instance Flatten a b => Flatten (Array n a) b where - flatten (Array xss) = concat $ map flatten xss - -instance Foldable (Array n) where - foldr f base (Array xs) = foldr f base xs - --- | Total number of elements in a possibly nested array. -size :: forall a n b. (Flatten a b, b ~ InnerType a) => Array n a -> Int -size xs = length $ (flatten xs :: [b]) - --- | Return the elemts of an array. -arrayelems :: Array n a -> [a] -arrayelems (Array xs) = xs + | otherwise = error errmsg + where + datalen = length xs + typelen = fromIntegral $ natVal $! (Proxy :: Proxy n) + errmsg = "Length of data (" ++ show datalen ++ + ") does not match length of type (" ++ show typelen ++ ")." + +-- | Return the elements of an array. +arrayElems :: Array n a -> [a] +arrayElems (Array xs) = xs + +-- | Update element of array to given element. +-- +-- PRE: the second argument denotes a valid index in the array. +arrayUpdate :: Array n a -> Int -> a -> Array n a +arrayUpdate (Array []) _ _ = error errMsg + where + errMsg = "copilot-core: arrayUpdate: Attempt to update empty array" + +arrayUpdate (Array (x:xs)) 0 y = Array (y:xs) + +arrayUpdate (Array (x:xs)) n y = + arrayAppend x (arrayUpdate (Array xs) (n - 1) y) + where + -- | Append to an array while preserving length information at the type + -- level. + arrayAppend :: a -> Array (n - 1) a -> Array n a + arrayAppend x (Array xs) = Array (x:xs) diff --git a/copilot-core/src/Copilot/Core/Type/Dynamic.hs b/copilot-core/src/Copilot/Core/Type/Dynamic.hs deleted file mode 100644 index e68b8d6f5..000000000 --- a/copilot-core/src/Copilot/Core/Type/Dynamic.hs +++ /dev/null @@ -1,61 +0,0 @@ --------------------------------------------------------------------------------- --- Copyright © 2011 National Institute of Aerospace / Galois, Inc. --------------------------------------------------------------------------------- - -{-# LANGUAGE Safe #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE Rank2Types #-} - --- | An implementation of dynamic types using "Copilot.Core.Type.Equality". --- The theory behind this technique is described the following paper: --- --- * Baars, Arthur I. and Swierstra, S. Doaitse, --- \"/Typing dynamic typing/\", --- ACM SIGPLAN Notices vol. 37, p. 157-166, 2002 - -{-# LANGUAGE GADTs, KindSignatures, ScopedTypeVariables #-} - -module Copilot.Core.Type.Dynamic - ( Dynamic (..) - , DynamicF (..) - , toDyn - , fromDyn - , toDynF - , fromDynF - ) where - -import Copilot.Core.Type.Equality - --------------------------------------------------------------------------------- - --- | Representation of a value accompanied by its type. -data Dynamic :: (* -> *) -> * where - Dynamic :: a -> t a -> Dynamic t - --- | Representation of a function accompanied by its type. -data DynamicF :: (* -> *) -> (* -> *) -> * where - DynamicF :: f a -> t a -> DynamicF f t - --- | Enclose a value and its type in a container. -toDyn :: t a -> a -> Dynamic t -toDyn t x = Dynamic x t - --- | Extract a value from a dynamic. Return 'Nothing' if the value is not of --- the given type. -fromDyn :: EqualType t => t a -> Dynamic t -> Maybe a -fromDyn t1 (Dynamic x t2) = - case t1 =~= t2 of - Just Refl -> return x - Nothing -> Nothing - --- | Enclose a function and its type in a container. -toDynF :: t a -> f a -> DynamicF f t -toDynF t fx = DynamicF fx t - --- | Extract a value from a dynamic function container. Return 'Nothing' if --- the value is not of the given type. -fromDynF :: EqualType t => t a -> DynamicF f t -> Maybe (f a) -fromDynF t1 (DynamicF fx t2) = - case t1 =~= t2 of - Just Refl -> return fx - Nothing -> Nothing diff --git a/copilot-core/src/Copilot/Core/Type/Eq.hs b/copilot-core/src/Copilot/Core/Type/Eq.hs deleted file mode 100644 index b6984d98d..000000000 --- a/copilot-core/src/Copilot/Core/Type/Eq.hs +++ /dev/null @@ -1,79 +0,0 @@ --------------------------------------------------------------------------------- --- Copyright © 2011 National Institute of Aerospace / Galois, Inc. --------------------------------------------------------------------------------- - -{-# LANGUAGE Safe #-} -{-# LANGUAGE ExistentialQuantification, GADTs #-} - -module Copilot.Core.Type.Eq - {-# DEPRECATED "This module is deprecated." #-} - ( EqWit (..) - , eqWit - , UVal (..) - ) where - -import Copilot.Core.Error (impossible) -import Copilot.Core.Type -import Copilot.Core.Type.Dynamic (fromDyn, toDyn) - --------------------------------------------------------------------------------- - -data EqWit a = Eq a => EqWit - --------------------------------------------------------------------------------- - -eqWit :: Type a -> EqWit a -eqWit t = - case t of - Bool -> EqWit - Int8 -> EqWit - Int16 -> EqWit - Int32 -> EqWit - Int64 -> EqWit - Word8 -> EqWit - Word16 -> EqWit - Word32 -> EqWit - Word64 -> EqWit - Float -> EqWit - Double -> EqWit - --------------------------------------------------------------------------------- - -data UVal = forall a. UVal - { uType :: Type a - , uVal :: a - } - --------------------------------------------------------------------------------- - -instance Eq UVal where - (==) UVal { uType = t1 - , uVal = a } - UVal { uType = t2 - , uVal = b } - = case eqWit t1 of - EqWit -> - case eqWit t2 of - EqWit -> - let dyn1 = toDyn t1 a in - case fromDyn t2 dyn1 of - Nothing -> False - Just x -> - case t1 of - -- Hacks for QuickChecking between C and Haskell - Float -> case t2 of - Float -> approx floatErr x b - _ -> impossible "instance Eq UVal" - "copilot-core" - Double -> case t2 of - Double -> approx doubleErr x b - _ -> impossible "instance Eq UVal" - "copilot-core" - _ -> x == b - where - approx :: (Num a, Ord a) => a -> a -> a -> Bool - approx err x y = x - y < err && y - x < err - floatErr = 0.0001 :: Float - doubleErr = 0.0001 :: Double - --------------------------------------------------------------------------------- diff --git a/copilot-core/src/Copilot/Core/Type/Equality.hs b/copilot-core/src/Copilot/Core/Type/Equality.hs deleted file mode 100644 index be4b11236..000000000 --- a/copilot-core/src/Copilot/Core/Type/Equality.hs +++ /dev/null @@ -1,46 +0,0 @@ --------------------------------------------------------------------------------- --- Copyright © 2011 National Institute of Aerospace / Galois, Inc. --------------------------------------------------------------------------------- - -{-# LANGUAGE Safe #-} -{-# LANGUAGE GADTs, KindSignatures #-} - --- | Propositional equality and type equality. -module Copilot.Core.Type.Equality - ( Equal (..) - , EqualType (..) - , coerce - , refl - , trans - , symm - , cong - ) where - --- | Propositional equality. -data Equal :: * -> * -> * where - Refl :: Equal a a - --- | Type equality. If the value of @x =~= y@ is @Just Refl@, then the two --- types @x@ and @y@ are equal. -class EqualType t where - (=~=) :: t a -> t b -> Maybe (Equal a b) - --- | Safe coercion, which requires proof of equality. -coerce :: Equal a b -> a -> b -coerce Refl x = x - --- | Proof of propositional equality. -refl :: Equal a a -refl = Refl - --- | Symmetry. -symm :: Equal a b -> Equal b a -symm Refl = Refl - --- | Transitivity. -trans :: Equal a b -> Equal b c -> Equal a c -trans Refl Refl = Refl - --- | Congruence. -cong :: Equal a b -> Equal (f a) (f b) -cong Refl = Refl diff --git a/copilot-core/src/Copilot/Core/Type/Read.hs b/copilot-core/src/Copilot/Core/Type/Read.hs deleted file mode 100644 index f33044f86..000000000 --- a/copilot-core/src/Copilot/Core/Type/Read.hs +++ /dev/null @@ -1,53 +0,0 @@ --------------------------------------------------------------------------------- --- Copyright © 2011 National Institute of Aerospace / Galois, Inc. --------------------------------------------------------------------------------- - -{-# LANGUAGE Safe #-} -{-# LANGUAGE ExistentialQuantification, GADTs #-} - -module Copilot.Core.Type.Read - {-# DEPRECATED "This module is deprecated." #-} - ( ReadWit (..) - , readWit - , readWithType - ) where - -import Copilot.Core.Type -import Copilot.Core.Error (badUsage) - --------------------------------------------------------------------------------- - -data ReadWit a = Read a => ReadWit - --------------------------------------------------------------------------------- - -readWit :: Type a -> ReadWit a -readWit t = - case t of - Bool -> ReadWit - Int8 -> ReadWit - Int16 -> ReadWit - Int32 -> ReadWit - Int64 -> ReadWit - Word8 -> ReadWit - Word16 -> ReadWit - Word32 -> ReadWit - Word64 -> ReadWit - Float -> ReadWit - Double -> ReadWit - --------------------------------------------------------------------------------- - -readWithType :: Type a -> String -> a -readWithType t str = - case t of - Bool -> case str of - "0" -> False - "1" -> True - x -> badUsage $ "in readWithType in copilot-core: expecting a \"0\" or \"1\" when reading a Boolean value " ++ show x ++ "." - _ -> rd - where - rd = case readWit t of - ReadWit -> read str - --------------------------------------------------------------------------------- diff --git a/copilot-core/src/Copilot/Core/Type/Uninitialized.hs b/copilot-core/src/Copilot/Core/Type/Uninitialized.hs deleted file mode 100644 index d9d618eb9..000000000 --- a/copilot-core/src/Copilot/Core/Type/Uninitialized.hs +++ /dev/null @@ -1,34 +0,0 @@ --------------------------------------------------------------------------------- --- Copyright © 2011 National Institute of Aerospace / Galois, Inc. --------------------------------------------------------------------------------- - --- | Initial values for a given type. - -{-# LANGUAGE Safe #-} -{-# LANGUAGE GADTs #-} - -module Copilot.Core.Type.Uninitialized - ( uninitialized - ) where - -import Copilot.Core.Type - --------------------------------------------------------------------------------- - --- | Initial value for a given type. --- --- Does not support structs or arrays. -uninitialized :: Type a -> a -uninitialized t = - case t of - Bool -> False - Int8 -> 0 - Int16 -> 0 - Int32 -> 0 - Int64 -> 0 - Word8 -> 0 - Word16 -> 0 - Word32 -> 0 - Word64 -> 0 - Float -> 0 - Double -> 0 diff --git a/copilot-core/tests/Main.hs b/copilot-core/tests/Main.hs index cc9491cc8..621700fd9 100644 --- a/copilot-core/tests/Main.hs +++ b/copilot-core/tests/Main.hs @@ -2,30 +2,19 @@ module Main where -- External imports -import Data.Monoid (mempty) -import Test.Framework (Test, defaultMainWithOpts) +import Test.Framework (Test, defaultMain) -- Internal library modules being tested -import qualified Test.Copilot.Core.Error -import qualified Test.Copilot.Core.External -import qualified Test.Copilot.Core.Interpret.Eval import qualified Test.Copilot.Core.Type import qualified Test.Copilot.Core.Type.Array -import qualified Test.Copilot.Core.Type.Dynamic -import qualified Test.Copilot.Core.Type.Show -- | Run all unit tests on copilot-core. main :: IO () -main = defaultMainWithOpts tests mempty +main = defaultMain tests -- | All unit tests in copilot-core. tests :: [Test.Framework.Test] tests = - [ Test.Copilot.Core.Error.tests - , Test.Copilot.Core.External.tests - , Test.Copilot.Core.Interpret.Eval.tests - , Test.Copilot.Core.Type.tests + [ Test.Copilot.Core.Type.tests , Test.Copilot.Core.Type.Array.tests - , Test.Copilot.Core.Type.Dynamic.tests - , Test.Copilot.Core.Type.Show.tests ] diff --git a/copilot-core/tests/Test/Copilot/Core/Error.hs b/copilot-core/tests/Test/Copilot/Core/Error.hs deleted file mode 100644 index 31ee285f7..000000000 --- a/copilot-core/tests/Test/Copilot/Core/Error.hs +++ /dev/null @@ -1,35 +0,0 @@ --- | Test copilot-core:Copilot.Core.Error. -module Test.Copilot.Core.Error where - --- External imports -import Test.Framework (Test, testGroup) -import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit (assertBool) - --- Internal imports: auxiliary testing facilities -import Test.Extra (withoutException) - --- Internal imports: library modules being tested -import Copilot.Core.Error (badUsage, impossible) - --- | All unit tests for copilot-core:Copilot.Core.Error. -tests :: Test.Framework.Test -tests = - testGroup "Copilot.Core.Error" - [ testCase "impossible" testErrorImpossible - , testCase "badUsage" testErrorBadUsage - ] - --- * Individual tests - --- | Test that 'Error.impossible' always throws an exception of some kind. -testErrorImpossible :: IO () -testErrorImpossible = do - res <- not <$> withoutException (impossible "func1" "pkg1") - assertBool "The function impossible should fail with an exception" res - --- | Test that 'Error.badUsage' always throws an exception of some kind. -testErrorBadUsage :: IO () -testErrorBadUsage = do - res <- not <$> withoutException (badUsage "func1") - assertBool "The function badUsage should fail with an exception" res diff --git a/copilot-core/tests/Test/Copilot/Core/External.hs b/copilot-core/tests/Test/Copilot/Core/External.hs deleted file mode 100644 index 361c613a3..000000000 --- a/copilot-core/tests/Test/Copilot/Core/External.hs +++ /dev/null @@ -1,43 +0,0 @@ --- | Test copilot-core:Copilot.Core.External. -module Test.Copilot.Core.External where - --- External imports -import Data.List (sort) -import Test.Framework (Test, testGroup) -import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit (assertBool) - --- Internal imports: library modules being tested -import Copilot.Core.Expr (Expr (ExternVar, Op1)) -import Copilot.Core.External (externVarName, externVars) -import Copilot.Core.Operators (Op1 (Abs, Sign)) -import Copilot.Core.Spec (Spec (..), Stream (..)) -import Copilot.Core.Type (Type (Int64)) - --- | All unit tests for copilot-core:Copilot.Core.External. -tests :: Test.Framework.Test -tests = - testGroup "Copilot.Core.External" - [ testCase "externVars" testExternVarsFind - ] - --- * Individual tests - --- | Test that 'externVars' will find an extern in a spec. -testExternVarsFind :: IO () -testExternVarsFind = do - -- A simple stream and a nested stream - let s1 = Stream 1 [] (ExternVar Int64 "z" Nothing) Int64 - s2 = Stream 2 [] s2Expr Int64 - s2Expr = Op1 (Abs Int64) - $ Op1 (Sign Int64) - $ ExternVar Int64 "y" Nothing - - -- Calculate the expected external vars in a spec - let res = sort $ map externVarName $ externVars $ Spec [s1, s2] [] [] [] - - -- Compare result with the expectation - let success = [ "y", "z" ] == res - assertBool - "The function externVars could not find the expected externs" - success diff --git a/copilot-core/tests/Test/Copilot/Core/Type.hs b/copilot-core/tests/Test/Copilot/Core/Type.hs index 6a3ffd57f..47d8c5940 100644 --- a/copilot-core/tests/Test/Copilot/Core/Type.hs +++ b/copilot-core/tests/Test/Copilot/Core/Type.hs @@ -1,20 +1,39 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} -- | Test copilot-core:Copilot.Core.Type. module Test.Copilot.Core.Type where -- External imports +import Data.Int (Int16, Int32, Int64, Int8) +import Data.Maybe (isJust) +import Data.Proxy (Proxy (..)) +import Data.Type.Equality (TestEquality (..), testEquality, + (:~:) (..)) +import Data.Word (Word16, Word32, Word64, Word8) +import GHC.TypeLits (sameSymbol) +import Prelude as P import Test.Framework (Test, testGroup) import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.QuickCheck (Property, elements, forAllBlind, - shuffle, (==>)) +import Test.QuickCheck (Gen, Property, arbitrary, elements, + expectFailure, forAll, forAllBlind, + property, shuffle, (==>)) -- Internal imports: library modules being tested -import Copilot.Core.Type (SimpleType (..)) +import Copilot.Core.Type (Field (..), SimpleType (..), Struct (..), + Type (..), Typed, UType (..), Value (..), + accessorName, fieldName, simpleType, typeLength, + typeOf, typeSize) +import Copilot.Core.Type.Array (Array) -- | All unit tests for copilot-core:Copilot.Core.Type. tests :: Test.Framework.Test tests = testGroup "Copilot.Core.Type" - [ testProperty "reflexivity of equality of simple types" + [ testProperty "simpleType preserves inequality" + testSimpleTypesInequality + , testProperty "reflexivity of equality of simple types" testSimpleTypesEqualityReflexive , testProperty "symmetry of equality of simple types" testSimpleTypesEqualitySymmetric @@ -22,8 +41,77 @@ tests = testSimpleTypesEqualityTransitive , testProperty "uniqueness of equality of simple types" testSimpleTypesEqualityUniqueness + , testProperty "typeLength matches array size for 1-dimensional arrays" + testTypeLength1 + , testProperty "typeLength matches array size for 2-dimensional arrays" + testTypeLength2 + , testProperty "typeSize matches full array size for 1-dimensional arrays" + testTypeSize1 + , testProperty "typeSize matches full array size for 2-dimensional arrays" + testTypeSize2 + , testProperty "equality of types" + testUTypesEqualitySymmetric + , testProperty "equality of utype" + testUTypesEq + , testProperty "inequality of utype" + testUTypesInequality + , testProperty "inequality of utype via typeOf" + testUTypesTypeOfInequality + , testProperty "inequality of different types" + testTypesInequality + , testProperty "fieldName matches field name (positive)" + testFieldNameOk + , testProperty "fieldName matches field name (negative)" + testFieldNameFail + , testProperty "Show field name" + testShowField + , testProperty "Show struct" + testShowStruct + , testProperty "Update struct" + testUpdateStruct + , testProperty "Update struct" + testUpdateStructFail + , testProperty "accessorName matches field name (positive)" + testAccessorNameOk + , testProperty "accessorName matches field name (negative)" + testAccessorNameFail + , testProperty "typeName matches struct type name (positive)" + testTypeNameOk + , testProperty "typeName matches struct type name (negative)" + testTypeNameFail ] +-- | Test that the function simpleTypes preserves inequality, that is, it +-- returns different values for different types. This test is limited; we do +-- not test structs or arrays. +testSimpleTypesInequality :: Property +testSimpleTypesInequality = forAllBlind twoDiffTypes $ \(t1, t2) -> + t1 /= t2 + where + twoDiffTypes :: Gen (SimpleType, SimpleType) + twoDiffTypes = do + shuffled <- shuffle diffTypes + case shuffled of + (t1:t2:_) -> return (t1, t2) + _ -> return (SBool, SBool) + + -- | A list of types that should all be different. + diffTypes :: [SimpleType] + diffTypes = [ simpleType Bool + , simpleType Int8 + , simpleType Int16 + , simpleType Int32 + , simpleType Int64 + , simpleType Word8 + , simpleType Word16 + , simpleType Word32 + , simpleType Word64 + , simpleType Float + , simpleType Double + , simpleType (Array Int8 :: Type (Array 3 Int8)) + , simpleType (Struct (S (Field 0) (Field 0))) + ] + -- | Test that the equality relation for simple types is reflexive. testSimpleTypesEqualityReflexive :: Property testSimpleTypesEqualityReflexive = @@ -66,4 +154,298 @@ simpleTypes = , SFloat , SDouble , SStruct + , SArray Int8 + , SArray Int16 ] + +-- | Test that the length of an array is as expected. +testTypeLength1 :: Property +testTypeLength1 = property $ typeLength a == 3 + where + a :: Type (Array 3 Int8) + a = Array Int8 + +-- | Test that the length of a multi-dimensional array is as expected. +testTypeLength2 :: Property +testTypeLength2 = property $ typeLength a == 3 + where + a :: Type (Array 3 (Array 12 Int8)) + a = Array (Array Int8) + +-- | Test that the size of an array is as expected. +testTypeSize1 :: Property +testTypeSize1 = property $ typeSize a == 3 + where + a :: Type (Array 3 Int8) + a = Array Int8 + +-- | Test that the size of a multi-dimensional array is as expected (flattens +-- the array). +testTypeSize2 :: Property +testTypeSize2 = property $ typeSize a == 36 + where + a :: Type (Array 3 (Array 12 Int8)) + a = Array (Array Int8) + +-- | Test that equality is symmetric for UTypes via testEquality. +testUTypesEqualitySymmetric :: Property +testUTypesEqualitySymmetric = + forAllBlind (elements utypes) $ \(UType t1) -> testEquality t1 t1 == Just Refl + +-- | Test that testEquality implies equality for UTypes. +testUTypesEq :: Property +testUTypesEq = + forAllBlind (elements utypes) $ \t@(UType t1) -> (testEquality t1 t1 == Just Refl) ==> t == t + +-- | Test that any two different UTypes are not equal. +-- +-- This function pre-selects two UTypes from a list of different UTypes, which +-- guarantees that they will be different. +testUTypesInequality :: Property +testUTypesInequality = forAllBlind twoDiffTypes $ \(t1, t2) -> + t1 /= t2 + where + twoDiffTypes :: Gen (UType, UType) + twoDiffTypes = do + shuffled <- shuffle utypes + case shuffled of + (t1:t2:_) -> return (t1, t2) + _ -> return (UType Bool, UType Bool) + +-- | Test that any two different Types are not equal. +-- +-- This function pre-selects two Types from a list of different UTypes, which +-- guarantees that they will be different. +testTypesInequality :: Property +testTypesInequality = forAllBlind twoDiffTypes $ \(UType t1, UType t2) -> + testEquality t1 t2 == Nothing + where + twoDiffTypes :: Gen (UType, UType) + twoDiffTypes = do + shuffled <- shuffle utypes + case shuffled of + (t1:t2:_) -> return (t1, t2) + _ -> return (UType Bool, UType Bool) + +-- | Different UTypes. +utypes :: [UType] +utypes = + [ UType Bool + , UType Int8 + , UType Int16 + , UType Int32 + , UType Int64 + , UType Word8 + , UType Word16 + , UType Word32 + , UType Word64 + , UType Float + , UType Double + , UType a1 + , UType a2 + , UType a3 + , UType a4 + , UType b1 + , UType b2 + , UType b3 + , UType b4 + , UType c + ] + where + a1 :: Type (Array 3 Int8) + a1 = Array Int8 + + a2 :: Type (Array 4 Int8) + a2 = Array Int8 + + a3 :: Type (Array 5 Int8) + a3 = Array Int8 + + a4 :: Type (Array 6 Int8) + a4 = Array Int8 + + b1 :: Type (Array 3 Int16) + b1 = Array Int16 + + b2 :: Type (Array 4 Int16) + b2 = Array Int16 + + b3 :: Type (Array 5 Int16) + b3 = Array Int16 + + b4 :: Type (Array 6 Int16) + b4 = Array Int16 + + c :: Type S + c = Struct (S (Field 0) (Field 0)) + +-- | Test that any two different UTypes are not equal. +-- +-- This function pre-selects two UTypes from a list of different UTypes built +-- via the function typeOf, which guarantees that they will be different. +testUTypesTypeOfInequality :: Property +testUTypesTypeOfInequality = forAllBlind twoDiffTypes $ \(t1@(UType t1'), t2@(UType t2')) -> + -- The seqs are important: otherwise, the coverage goes down drastically + -- because the typeOf function is not really executed. + t1' `seq` t2' `seq` t1 /= t2 + where + twoDiffTypes :: Gen (UType, UType) + twoDiffTypes = do + shuffled <- shuffle uTypesTypeOf + case shuffled of + (t1:t2:_) -> t1 `seq` t2 `seq` return (t1, t2) + _ -> return (UType Bool, UType Bool) + +-- | Different UTypes, produced by using the function typeOf. +uTypesTypeOf :: [UType] +uTypesTypeOf = + [ UType (typeOf :: Type Bool) + , UType (typeOf :: Type Int8) + , UType (typeOf :: Type Int16) + , UType (typeOf :: Type Int32) + , UType (typeOf :: Type Int64) + , UType (typeOf :: Type Word8) + , UType (typeOf :: Type Word16) + , UType (typeOf :: Type Word32) + , UType (typeOf :: Type Word64) + , UType (typeOf :: Type Float) + , UType (typeOf :: Type Double) + , UType (typeOf :: Type (Array 3 Int8)) + , UType (typeOf :: Type (Array 3 Int16)) + , UType (typeOf :: Type (Array 3 Int32)) + , UType (typeOf :: Type (Array 3 Int64)) + , UType (typeOf :: Type (Array 3 Word8)) + , UType (typeOf :: Type (Array 3 Word16)) + , UType (typeOf :: Type (Array 3 Word32)) + , UType (typeOf :: Type (Array 3 Word64)) + , UType (typeOf :: Type (Array 3 Double)) + , UType (typeOf :: Type (Array 3 Float)) + , UType (typeOf :: Type S) + ] + +-- | Test the fieldName function (should succeed). +testFieldNameOk :: Property +testFieldNameOk = forAll arbitrary $ \k1 -> + forAll arbitrary $ \k2 -> + fieldName (s1 (S (Field k1) (Field k2))) == s1FieldName + where + s1FieldName = "field1" + +-- | Test the fieldName function (should fail). +testFieldNameFail :: Property +testFieldNameFail = expectFailure $ property $ + fieldName (s1 sampleS) == s1FieldName + where + sampleS = S (Field 0) (Field 0) + s1FieldName = "Field" + +-- | Test showing a field of a struct. +testShowField :: Property +testShowField = forAll arbitrary $ \k -> + show (s1 (S (Field k) (Field 0))) == ("field1:" ++ show k) + +-- | Test showing a struct. +testShowStruct :: Property +testShowStruct = forAll arbitrary $ \k1 -> + forAll arbitrary $ \k2 -> + show (S (Field k1) (Field k2)) == "" + +-- | Test updating a struct. +testUpdateStruct :: Property +testUpdateStruct = + forAll arbitrary $ \k1 -> + forAll arbitrary $ \k2 -> + let f :: Field "field1" Int8 + f = Field k2 + v :: Value Int8 + v = Value Int8 f + in unField (s1 (updateField (S (Field k1) (Field 0)) v)) == k2 + + where + unField (Field x) = x + +-- | Test updating a struct (should fail). +testUpdateStructFail :: Property +testUpdateStructFail = expectFailure $ + forAll arbitrary $ \k1 -> + forAll arbitrary $ \k3 -> + let f :: Field "field" Int8 + f = Field k3 + v :: Value Int8 + v = Value Int8 f + in unField (s3 (updateField (S3 (Field k1)) v)) == k3 + + where + unField (Field x) = x + +-- | Test the accessorName of a field of a struct (should succeed). +testAccessorNameOk :: Property +testAccessorNameOk = property $ + accessorName s1 == s1FieldName + where + s1FieldName = "field1" + +-- | Test the accessorName of a field of a struct (should fail). +testAccessorNameFail :: Property +testAccessorNameFail = expectFailure $ property $ + accessorName s1 == s1FieldName + where + s1FieldName = "Field1" + +-- | Test the typeName of a struct (should succeed). +testTypeNameOk :: Property +testTypeNameOk = property $ + typeName sampleS == s1TypeName + + where + + sampleS :: S + sampleS = S (Field 0) (Field 0) + + s1TypeName :: String + s1TypeName = "S" + +-- | Test the typeName of a struct (should fail). +testTypeNameFail :: Property +testTypeNameFail = expectFailure $ property $ + typeName sampleS == s1TypeName + + where + + sampleS :: S + sampleS = S (Field 0) (Field 0) + + s1TypeName :: String + s1TypeName = "s" + +-- | Auxiliary struct defined for testing purposes. +data S = S { s1 :: Field "field1" Int8, s2 :: Field "field2" Word8 } + +instance Struct S where + typeName _ = "S" + + toValues s = [ Value Int8 (s1 s), Value Word8 (s2 s) ] + + updateField s (Value fieldTy (field :: Field fieldName a)) + | Just Refl <- sameSymbol (Proxy @"field1") (Proxy @fieldName) + , Just Refl <- testEquality Int8 fieldTy + = s { s1 = field } + | Just Refl <- sameSymbol (Proxy @"field2") (Proxy @fieldName) + , Just Refl <- testEquality Word8 fieldTy + = s { s2 = field } + | otherwise + = error $ "Unexpected field: " P.++ show field + +instance Typed S where + typeOf = Struct (S (Field 0) (Field 0)) + +-- | Auxiliary struct defined for testing purposes. +data S3 = S3 { s3 :: Field "field" Int8 } + +instance Struct S3 where + typeName _ = "S3" + + toValues s = [ Value Int8 (s3 s) ] + +instance Typed S3 where + typeOf = Struct (S3 (Field 0)) diff --git a/copilot-core/tests/Test/Copilot/Core/Type/Array.hs b/copilot-core/tests/Test/Copilot/Core/Type/Array.hs index 34b56e849..0af0ffae9 100644 --- a/copilot-core/tests/Test/Copilot/Core/Type/Array.hs +++ b/copilot-core/tests/Test/Copilot/Core/Type/Array.hs @@ -9,11 +9,14 @@ import Data.Proxy (Proxy (..)) import GHC.TypeNats (KnownNat, natVal) import Test.Framework (Test, testGroup) import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.QuickCheck (Gen, Property, arbitrary, forAll, +import Test.QuickCheck (Gen, Property, arbitrary, + chooseInt, expectFailure, forAll, + getNegative, getNonNegative, + listOf, oneof, property, vector, vectorOf) -- Internal imports: library modules being tested -import Copilot.Core.Type.Array (Array, array, arrayelems, flatten, size) +import Copilot.Core.Type.Array (Array, array, arrayElems, arrayUpdate) -- | All unit tests for copilot-core:Copilot.Core.Array. tests :: Test.Framework.Test @@ -25,42 +28,34 @@ tests = (testArrayElemsLeft (Proxy :: Proxy 5)) , testProperty "arrayElems . array (identity; 200)" (testArrayElemsLeft (Proxy :: Proxy 200)) - , testProperty "arrayFlatten . array (identity; 0)" - (testArrayFlattenLeft (Proxy :: Proxy 0)) - , testProperty "arrayFlatten . array (identity; 1)" - (testArrayFlattenLeft (Proxy :: Proxy 1)) - , testProperty "arrayFlatten . array (identity; 2)" - (testArrayFlattenLeft (Proxy :: Proxy 2)) - , testProperty "arrayFlatten . array (identity; 22)" - (testArrayFlattenLeft (Proxy :: Proxy 22)) - , testProperty "arrayFlatten . array (identity; 50)" - (testArrayFlattenLeft (Proxy :: Proxy 50)) - , testProperty "arrayFlatten . array (identity; nested; nested; 2x6)" - (testArrayFlattenNestedLeft (Proxy :: Proxy 2) (Proxy :: Proxy 6)) - , testProperty "arrayFlatten . array (identity; nested; nested; 10x2)" - (testArrayFlattenNestedLeft (Proxy :: Proxy 10) (Proxy :: Proxy 2)) - , testProperty "arrayFlatten . array (identity; nested; nested; 38x20)" - (testArrayFlattenNestedLeft (Proxy :: Proxy 38) (Proxy :: Proxy 20)) - , testProperty "arrayFlatten . array (identity; nested; nested; 125x100)" - (testArrayFlattenNestedLeft (Proxy :: Proxy 125) (Proxy :: Proxy 100)) - , testProperty "arraySize . array (identity; 0)" - (testArraySizeLeft (Proxy :: Proxy 0)) - , testProperty "arraySize . array (identity; 45)" - (testArraySizeLeft (Proxy :: Proxy 45)) - , testProperty "arraySize . array (identity; 100)" - (testArraySizeLeft (Proxy :: Proxy 100)) + , testProperty "array of incorrect length" + testArrayElemsFail + , testProperty "Show for arrays" + testShowArray + , testProperty "showsPrec for arrays" + testShowsPrecArray + , testProperty "showList for arrays" + testShowListArray + , testProperty "arrayElems (arrayUpdate x i v) !! i == v" + (testArrayUpdateElem (Proxy :: Proxy 5)) + , testProperty "arrayUpdate x i ((arrayElems x) !! i) == x" + (testArrayUpdateElems (Proxy :: Proxy 5)) + , testProperty "arrayUpdate fails if out of range of array" + (testArrayUpdateWrong (Proxy :: Proxy 5)) + , testProperty "array fails length is wrong" + (testArrayMakeWrongLength (Proxy :: Proxy 5)) ] -- * Individual tests -- | Test that building an array from a list and extracting the elements with --- the function 'arrayelems' will result in the same list. +-- the function 'arrayElems' will result in the same list. testArrayElemsLeft :: forall n . KnownNat n => Proxy n -> Property testArrayElemsLeft len = forAll xsInt64 $ \ls -> let array' :: Array n Int64 array' = array ls - in arrayelems array' == ls + in arrayElems array' == ls where @@ -68,16 +63,45 @@ testArrayElemsLeft len = xsInt64 :: Gen [Int64] xsInt64 = vectorOf (fromIntegral (natVal len)) arbitrary --- | Test that building an array from a list and extracting the elements with --- the function 'flatten' will result in the same list. --- --- This test tests only plain arrays (no nesting). -testArrayFlattenLeft :: forall n . KnownNat n => Proxy n -> Property -testArrayFlattenLeft len = - forAll xsInt64 $ \ls -> - let array' :: Array n Int64 +-- | Test that arrays cannot be properly evaluated if their length does not +-- match their type. +testArrayElemsFail :: Property +testArrayElemsFail = expectFailure $ forAll (vector 3) $ \l -> + let v = array l :: Array 4 Int64 + in arrayElems v == l + +-- | Test show for arrays. +testShowArray :: Property +testShowArray = forAll (vector 3) $ \l -> property $ + show (array l :: Array 3 Int64) == show (l :: [Int64]) + +-- | Test 'Show.showsPrec' for 'Array's. +testShowsPrecArray :: Property +testShowsPrecArray = forAll (getNonNegative <$> arbitrary) $ \prec -> + forAll (vector 3) $ \l -> property $ + showsPrec prec (array l :: Array 3 Int64) "" == show (l :: [Int64]) + +-- | Test 'Show.showList' for 'Array's. +testShowListArray :: Property +testShowListArray = forAll (listOf $ vector 3) $ \l -> property $ + showList (map array l :: [Array 3 Int64]) "" == show (l :: [[Int64]]) + +-- | Test that updating an array updates the element appropriately (if we +-- project that element we get the value we put in). +testArrayUpdateElem :: forall n . KnownNat n => Proxy n -> Property +testArrayUpdateElem len = + forAll xsInt64 $ \ls -> + forAll position $ \p -> + forAll xInt64 $ \v -> + let -- Original array + array' :: Array n Int64 array' = array ls - in flatten array' == ls + + -- Updated array + array'' :: Array n Int64 + array'' = arrayUpdate array' p v + + in arrayElems array'' !! p == v where @@ -85,48 +109,94 @@ testArrayFlattenLeft len = xsInt64 :: Gen [Int64] xsInt64 = vectorOf (fromIntegral (natVal len)) arbitrary --- | Test that building a nested array of a known size and extracting the --- elements with the function 'flatten' will result in a list with a size that --- is the product of the sizes provided. -testArrayFlattenNestedLeft :: forall n1 n2 - . (KnownNat n1, KnownNat n2) - => Proxy n1 - -> Proxy n2 - -> Property -testArrayFlattenNestedLeft len1 len2 = - forAll xsArrays $ \array' -> - length (flatten array' :: [Int64]) == expectedSize - - where + -- Generator for element of type Int64. + xInt64 :: Gen Int64 + xInt64 = arbitrary + + -- Generator for positions within the list. + position :: Gen Int + position = chooseInt (0, fromIntegral (natVal len) - 1) + +-- | Test that updating an array updates the element appropriately (if we +-- project that element we get the value we put in). +testArrayUpdateWrong :: forall n . KnownNat n => Proxy n -> Property +testArrayUpdateWrong len = + expectFailure $ + forAll xsInt64 $ \ls -> + forAll position $ \p -> + forAll xInt64 $ \v -> + let -- Original array + array' :: Array n Int64 + array' = array ls - -- Expected size of the matrix / array. - expectedSize :: Int - expectedSize = fromIntegral $ natVal len1 * natVal len2 + -- Updated array + array'' :: Array n Int64 + array'' = arrayUpdate array' (p + 10) v - -- Generator for nested matrices of Int64 of known size. - xsArrays :: Gen (Array n1 (Array n2 Int64)) - xsArrays = - array <$> vectorOf (fromIntegral (natVal len1)) xsArrayInt64 + in arrayElems array'' !! p == v - -- Generator for arrays of Int64 of known length. - xsArrayInt64 :: Gen (Array n2 Int64) - xsArrayInt64 = array <$> xsInt64 + where -- Generator for lists of Int64 of known length. xsInt64 :: Gen [Int64] - xsInt64 = vectorOf (fromIntegral (natVal len2)) arbitrary + xsInt64 = vectorOf (fromIntegral (natVal len)) arbitrary --- | Test that building an array from a list and calculating the size will --- return the length of the list. -testArraySizeLeft :: forall n . KnownNat n => Proxy n -> Property -testArraySizeLeft len = - forAll xsInt64 $ \ls -> + -- Generator for element of type Int64. + xInt64 :: Gen Int64 + xInt64 = arbitrary + + -- Generator for positions within the list. + position :: Gen Int + position = oneof + [ (fromIntegral (natVal len) +) . getNonNegative <$> arbitrary + , getNegative <$> arbitrary + ] + +-- | Test that making an array of a specific length fails if the list of +-- elements supplied doesn't have the same length. +testArrayMakeWrongLength :: forall n . KnownNat n => Proxy n -> Property +testArrayMakeWrongLength len = + expectFailure $ + forAll wrongLength $ \length -> + forAll (xsInt64 length) $ \ls -> let array' :: Array n Int64 array' = array ls - in size array' == length ls + in arrayElems array' == ls + where + xsInt64 length = vectorOf length arbitrary + expectedLength = fromIntegral (natVal len) + wrongLength = (expectedLength +) . getNonNegative <$> arbitrary + +-- | Test that updating an array updates the element appropriately (if we +-- project that element we get the value we put in). +testArrayUpdateElems :: forall n . KnownNat n => Proxy n -> Property +testArrayUpdateElems len = + forAll xsInt64 $ \ls -> + forAll position $ \p -> + forAll xInt64 $ \v -> + let -- Original array + array' :: Array n Int64 + array' = array ls + + -- Updated array + e :: Int64 + e = arrayElems array' !! p + + array'' :: Array n Int64 + array'' = arrayUpdate array' p e + + in arrayElems array'' == ls where -- Generator for lists of Int64 of known length. xsInt64 :: Gen [Int64] xsInt64 = vectorOf (fromIntegral (natVal len)) arbitrary + + -- Generator for element of type Int64. + xInt64 :: Gen Int64 + xInt64 = arbitrary + + -- Generator for positions within the list. + position :: Gen Int + position = chooseInt (0, fromIntegral (natVal len) - 1) diff --git a/copilot-core/tests/Test/Copilot/Core/Type/Dynamic.hs b/copilot-core/tests/Test/Copilot/Core/Type/Dynamic.hs deleted file mode 100644 index cbead83b6..000000000 --- a/copilot-core/tests/Test/Copilot/Core/Type/Dynamic.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-# LANGUAGE GADTs #-} --- | Test copilot-core:Copilot.Core.Type.Dynamic. -module Test.Copilot.Core.Type.Dynamic where - --- External imports -import Test.Framework (Test, testGroup) -import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.QuickCheck (Arbitrary, Property, property) - --- Internal imports: library modules being tested -import Copilot.Core.Type (Type (..)) -import Copilot.Core.Type.Dynamic (fromDyn, toDyn) -import Copilot.Core.Type.Equality (Equal (Refl), EqualType ((=~=))) - --- | All unit tests for copilot-core:Copilot.Core.Type.Dynamic. -tests :: Test.Framework.Test -tests = - testGroup "Copilot.Core.Type.Dynamic" - [ testProperty "fromDyn . toDyn == identity (Int64)" - (testDynamicIdentity Int64 Int64) - , testProperty "fromDyn . toDyn == identity (Bool)" - (testDynamicIdentity Bool Bool) - , testProperty "fromDyn . toDyn == identity (Float)" - (testDynamicIdentity Float Float) - , testProperty "fromDyn . toDyn == identity (Double)" - (testDynamicIdentity Double Double) - , testProperty "fromDyn . toDyn /= identity (Int64 vs Int32)" - (testDynamicIdentity Int64 Int32) - , testProperty "fromDyn . toDyn /= identity (Int64 vs Int16)" - (testDynamicIdentity Int64 Int16) - , testProperty "fromDyn . toDyn /= identity (Bool vs Int16)" - (testDynamicIdentity Bool Int16) - , testProperty "fromDyn . toDyn /= identity (Float vs Double)" - (testDynamicIdentity Float Double) - ] - --- | Test that wrapping in and unwrapping from a dynamic gets the original --- value if the types match, and Nothing otherwise. -testDynamicIdentity :: (Eq a, Arbitrary b) - => Type a -- ^ Type to unwrap to - -> Type b -- ^ Type to wrap to - -> b -- ^ Value to wrap - -> Property -testDynamicIdentity t1 t2 ls = property $ - let unwrapped = fromDyn t1 (toDyn t2 ls) - in case t1 =~= t2 of - Nothing -> Nothing == unwrapped - Just Refl -> Just ls == unwrapped diff --git a/copilot-core/tests/Test/Copilot/Core/Type/Show.hs b/copilot-core/tests/Test/Copilot/Core/Type/Show.hs deleted file mode 100644 index b13ba293c..000000000 --- a/copilot-core/tests/Test/Copilot/Core/Type/Show.hs +++ /dev/null @@ -1,34 +0,0 @@ --- | Test copilot-core:Copilot.Core.Type.Show. -module Test.Copilot.Core.Type.Show where - --- External imports -import Test.Framework (Test, testGroup) -import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.QuickCheck (Arbitrary, Property, property) -import Text.Read (readMaybe) - --- Internal imports: library modules being tested -import Copilot.Core.Type (Type (Double, Float, Int16, Int32, Int64)) -import Copilot.Core.Type.Show (ShowType (Haskell), showWithType) - --- | All unit tests for copilot-core:Copilot.Core.Type.Show. -tests :: Test.Framework.Test -tests = - testGroup "Copilot.Core.Type.Show" - [ testProperty "read . showWithType == identity (Int16)" - (testShowRead Int16) - , testProperty "read . showWithType == identity (Int32)" - (testShowRead Int32) - , testProperty "read . showWithType == identity (Int64)" - (testShowRead Int64) - , testProperty "read . showWithType == identity (Float)" - (testShowRead Float) - , testProperty "read . showWithType == identity (Double)" - (testShowRead Double) - ] - --- | Test that showing a value with 'showWithType' and reading it back results --- in the same value. -testShowRead :: (Arbitrary a, Eq a, Read a) => Type a -> a -> Property -testShowRead t v = property $ - Just v == readMaybe (showWithType Haskell t v) diff --git a/copilot-core/tests/Test/Extra.hs b/copilot-core/tests/Test/Extra.hs index 363adcbde..f10d784c4 100644 --- a/copilot-core/tests/Test/Extra.hs +++ b/copilot-core/tests/Test/Extra.hs @@ -1,21 +1,8 @@ -{-# LANGUAGE ScopedTypeVariables #-} -- | Auxiliary testing helper functions. module Test.Extra where -- External imports -import Control.Arrow ((***)) -import Control.Exception (SomeException, catch) - --- * Detecting exceptions - --- | Test that a computation terminates without throwing an exception. --- --- Returns 'True' if the computation can be completed without an exception, --- and 'False' otherwise. -withoutException :: IO a -> IO Bool -withoutException e = - catch (e >> return True) - (\(_ :: SomeException) -> return False) +import Control.Arrow ((***)) -- * Function application diff --git a/copilot-interpreter/CHANGELOG b/copilot-interpreter/CHANGELOG new file mode 100644 index 000000000..55cdec51c --- /dev/null +++ b/copilot-interpreter/CHANGELOG @@ -0,0 +1,86 @@ +2026-11-07 + * Version bump (4.8.2). (#792) + * Replace tab in `Copilot.Interpreter.Eval`. (#772) + +2026-09-07 + * Version bump (4.8.1). (#760) + +2026-07-07 + * Version bump (4.8). (#745) + +2026-05-07 + * Version bump (4.7.1). (#730) + +2026-03-07 + * Version bump (4.7). (#714) + +2026-01-07 + * Version bump (4.6.1). (#705) + +2025-11-07 + * Version bump (4.6). (#679) + +2025-09-07 + * Version bump (4.5.1). (#666) + +2025-07-07 + * Version bump (4.5). (#642) + +2025-05-07 + * Version bump (4.4). (#618) + +2025-03-07 + * Version bump (4.3). (#604) + +2025-01-07 + * Version bump (4.2). (#577) + +2024-11-07 + * Version bump (4.1). (#561) + +2024-09-07 + * Version bump (4.0). (#532) + * Add support for array updates. (#36) + +2024-07-07 + * Version bump (3.20). (#522) + * Add support for struct field updates. (#520) + +2024-05-07 + * Version bump (3.19.1). (#512) + +2024-03-07 + * Version bump (3.19). (#504) + +2024-01-07 + * Version bump (3.18.1). (#493) + +2024-01-07 + * Version bump (3.18). (#487) + +2023-11-07 + * Version bump (3.17). (#466) + * 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) + +2023-01-07 + * Version bump (3.13). (#406) + +2022-11-07 + * Version bump (3.12). (#389) + * Use pretty-printer from copilot-prettyprinter. (#383) + +2022-09-07 + * Version bump (3.11). (#376) + * Split copilot-interpreter into separate library. (#361) diff --git a/copilot-interpreter/LICENSE b/copilot-interpreter/LICENSE new file mode 100644 index 000000000..d4ed5bc4c --- /dev/null +++ b/copilot-interpreter/LICENSE @@ -0,0 +1,29 @@ +2009 +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. diff --git a/copilot-interpreter/README.md b/copilot-interpreter/README.md new file mode 100644 index 000000000..90bc428f5 --- /dev/null +++ b/copilot-interpreter/README.md @@ -0,0 +1,30 @@ +[![Build Status](https://travis-ci.com/Copilot-Language/copilot.svg?branch=master)](https://app.travis-ci.com/github/Copilot-Language/copilot) + +# Copilot: a stream DSL +The interpreter, which evaluates Copilot specifications and prints +their results over time. + +Copilot is a runtime verification framework written in Haskell. It allows the +user to write programs in a simple but powerful way using a stream-based +approach. + +Programs can be interpreted for testing (with the library copilot-interpreter), +or translated C99 code to be incorporated in a project, or as a standalone +application. The C99 backend ensures us that the output is constant in memory +and time, making it suitable for systems with hard realtime requirements. + +## Installation +Copilot-interpreter can be found on +[Hackage](https://hackage.haskell.org/package/copilot-interpreter). It is typically +only installed as part of the complete Copilot distribution. For installation +instructions, please refer to the [Copilot +website](https://copilot-language.github.io). + +## Further information +For further information, install instructions and documentation, please visit +the Copilot website: +[https://copilot-language.github.io](https://copilot-language.github.io) + +## License +Copilot is distributed under the BSD-3-Clause license, which can be found +[here](https://raw.githubusercontent.com/Copilot-Language/copilot/master/copilot-interpreter/LICENSE). diff --git a/copilot-interpreter/Setup.hs b/copilot-interpreter/Setup.hs new file mode 100644 index 000000000..9a994af67 --- /dev/null +++ b/copilot-interpreter/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/copilot-interpreter/copilot-interpreter.cabal b/copilot-interpreter/copilot-interpreter.cabal new file mode 100644 index 000000000..60152a66a --- /dev/null +++ b/copilot-interpreter/copilot-interpreter.cabal @@ -0,0 +1,88 @@ +cabal-version: >=1.10 +name: copilot-interpreter +version: 4.8.2 +synopsis: Interpreter for Copilot. +description: + Interpreter for Copilot. + . + 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 + . + +author: Frank Dedden, Lee Pike, Robin Morisset, Alwyn Goodloe, + Sebastian Niller, Nis Nordbyop Wegmann, Ivan Perez +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 + +x-curation: uncurated + +source-repository head + type: git + location: https://github.com/Copilot-Language/copilot.git + subdir: copilot-interpreter + +library + + default-language: Haskell2010 + + hs-source-dirs: src + + ghc-options: + -Wall + + build-depends: + base >= 4.9 && < 5, + pretty >= 1.0 && < 1.2, + + copilot-core >= 4.8.2 && < 4.9 + + exposed-modules: + + Copilot.Interpret + Copilot.Interpret.Eval + + other-modules: + + Copilot.Interpret.Error + Copilot.Interpret.Render + +test-suite unit-tests + type: + exitcode-stdio-1.0 + + main-is: + Main.hs + + other-modules: + Test.Extra + Test.Copilot.Interpret.Eval + + build-depends: + base + , QuickCheck + , pretty + , test-framework + , test-framework-quickcheck2 + + , copilot-core + , copilot-interpreter + , copilot-prettyprinter + + hs-source-dirs: + tests + + default-language: + Haskell2010 + + ghc-options: + -Wall diff --git a/copilot-core/src/Copilot/Core/Interpret.hs b/copilot-interpreter/src/Copilot/Interpret.hs similarity index 64% rename from copilot-core/src/Copilot/Core/Interpret.hs rename to copilot-interpreter/src/Copilot/Interpret.hs index 0b8c3ffb1..7afaf1f6f 100644 --- a/copilot-core/src/Copilot/Core/Interpret.hs +++ b/copilot-interpreter/src/Copilot/Interpret.hs @@ -1,20 +1,17 @@ --------------------------------------------------------------------------------- -- Copyright © 2011 National Institute of Aerospace / Galois, Inc. --------------------------------------------------------------------------------- -- | An interpreter for Copilot specifications. {-# LANGUAGE Safe #-} -module Copilot.Core.Interpret +module Copilot.Interpret ( Format (..) , interpret ) where import Copilot.Core -import Copilot.Core.Interpret.Eval -import Copilot.Core.Interpret.Render -import Copilot.Core.Type.Show (ShowType(..)) +import Copilot.Interpret.Eval +import Copilot.Interpret.Render -- | Output format for the results of a Copilot spec interpretation. data Format = Table | CSV @@ -28,4 +25,5 @@ interpret format k spec = case format of Table -> renderAsTable e CSV -> renderAsCSV e - where e = eval Haskell k spec + where + e = eval Haskell k spec diff --git a/copilot-interpreter/src/Copilot/Interpret/Error.hs b/copilot-interpreter/src/Copilot/Interpret/Error.hs new file mode 100644 index 000000000..563162575 --- /dev/null +++ b/copilot-interpreter/src/Copilot/Interpret/Error.hs @@ -0,0 +1,12 @@ +-- Copyright © 2011 National Institute of Aerospace / Galois, Inc. + +{-# LANGUAGE Safe #-} + +-- | Custom functions to report error messages to users. +module Copilot.Interpret.Error + ( badUsage ) where + +-- | Report an error due to an error detected by Copilot (e.g., user error). +badUsage :: String -- ^ Description of the error. + -> a +badUsage msg = error $ "Copilot error: " ++ msg diff --git a/copilot-core/src/Copilot/Core/Interpret/Eval.hs b/copilot-interpreter/src/Copilot/Interpret/Eval.hs similarity index 82% rename from copilot-core/src/Copilot/Core/Interpret/Eval.hs rename to copilot-interpreter/src/Copilot/Interpret/Eval.hs index af86b7ae1..9543806c9 100644 --- a/copilot-core/src/Copilot/Core/Interpret/Eval.hs +++ b/copilot-interpreter/src/Copilot/Interpret/Eval.hs @@ -1,34 +1,38 @@ --------------------------------------------------------------------------------- -- Copyright © 2011 National Institute of Aerospace / Galois, Inc. --------------------------------------------------------------------------------- -- | A tagless interpreter for Copilot specifications. -{-# LANGUAGE Safe #-} -{-# LANGUAGE GADTs, BangPatterns, DeriveDataTypeable #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE ScopedTypeVariables #-} -module Copilot.Core.Interpret.Eval +module Copilot.Interpret.Eval ( Env , Output , ExecTrace (..) , eval + , ShowType (..) ) where -import Copilot.Core -import Copilot.Core.Type.Show (showWithType, ShowType) +import Copilot.Core (Expr (..), Field (..), Id, Name, Observer (..), + Op1 (..), Op2 (..), Op3 (..), Spec, Stream (..), + Trigger (..), Type (..), UExpr (..), Value (..), + arrayElems, arrayUpdate, specObservers, + specStreams, specTriggers, updateField) +import Copilot.Interpret.Error (badUsage) -import Prelude hiding (id) +import Prelude hiding (id) import qualified Prelude as P -import Data.List (transpose) -import Data.Maybe (fromJust) -import Data.Bits import Control.Exception (Exception, throw) - -import Data.Dynamic (Dynamic, fromDynamic, toDyn) -import Data.Typeable (Typeable) - --------------------------------------------------------------------------------- +import Data.Bits (complement, shiftL, shiftR, xor, (.&.), (.|.)) +import Data.Dynamic (Dynamic, fromDynamic, toDyn) +import Data.List (transpose) +import Data.Maybe (fromJust) +import Data.Typeable (Typeable) +import GHC.TypeLits (KnownNat, Nat, natVal) -- | Exceptions that may be thrown during interpretation of a Copilot -- specification. @@ -77,14 +81,10 @@ instance Show InterpException where -- exception mechanisms. instance Exception InterpException --------------------------------------------------------------------------------- - -- | An environment that contains an association between (stream or extern) -- names and their values. type Env nm = [(nm, Dynamic)] --------------------------------------------------------------------------------- - -- | The simulation output is defined as a string. Different backends may -- choose to format their results differently. type Output = String @@ -104,8 +104,6 @@ data ExecTrace = ExecTrace } deriving Show --------------------------------------------------------------------------------- - -- We could write this in a beautiful lazy style like above, but that creates a -- space leak in the interpreter that is hard to fix while maintaining laziness. -- We take a more brute-force appraoch below. @@ -135,8 +133,6 @@ eval showType k spec = zip (map observerName (specObservers spec)) obsvs } --------------------------------------------------------------------------------- - -- | An environment that contains an association between (stream or extern) -- names and their values. type LocalEnv = [(Name, Dynamic)] @@ -174,8 +170,6 @@ evalExpr_ k e0 locs strms = case e0 of let ev1 = evalExpr_ k e1 locs strms in ev1 --------------------------------------------------------------------------------- - -- | Evaluate an extern stream for a number of steps, obtaining the value of -- the sample at that time. evalExternVar :: Int -> Name -> Maybe [a] -> a @@ -187,10 +181,6 @@ evalExternVar k name exts = Nothing -> throw (NotEnoughValues name k) Just x -> x --------------------------------------------------------------------------------- - --------------------------------------------------------------------------------- - -- | Evaluate an 'Copilot.Core.Operators.Op1' by producing an equivalent -- Haskell function operating on the same types as the -- 'Copilot.Core.Operators.Op1'. @@ -228,8 +218,6 @@ evalOp1 op = case op of -- Extract value from field unfield (Field v) = v --------------------------------------------------------------------------------- - -- | Evaluate an 'Copilot.Core.Operators.Op2' by producing an equivalent -- Haskell function operating on the same types as the -- 'Copilot.Core.Operators.Op2'. @@ -257,7 +245,13 @@ evalOp2 op = case op of BwXor _ -> (xor) BwShiftL _ _ -> ( \ !a !b -> shiftL a $! fromIntegral b ) BwShiftR _ _ -> ( \ !a !b -> shiftR a $! fromIntegral b ) - Index _ -> \xs n -> (arrayelems xs) !! (fromIntegral n) + Index _ -> \xs n -> (arrayElems xs) !! (fromIntegral n) + + UpdateField (Struct _) ty (fieldAccessor :: a -> Field s b) -> + \stream fieldValue -> + let newField :: Field s b + newField = Field fieldValue + in updateField stream (Value ty newField) -- | Apply a function to two numbers, so long as the second one is -- not zero. @@ -268,15 +262,12 @@ catchZero :: Integral a => (a -> a -> a) -> (a -> a -> a) catchZero _ _ 0 = throw DivideByZero catchZero f x y = f x y --------------------------------------------------------------------------------- - -- | Evaluate an 'Copilot.Core.Operators.Op3' by producing an equivalent -- Haskell function operating on the same types as the -- 'Copilot.Core.Operators.Op3'. evalOp3 :: Op3 a b c d -> (a -> b -> c -> d) -evalOp3 (Mux _) = \ !v !x !y -> if v then x else y - --------------------------------------------------------------------------------- +evalOp3 (Mux _) = \ !v !x !y -> if v then x else y +evalOp3 (UpdateArray ty) = \xs n x -> arrayUpdate xs (fromIntegral n) x -- | Turn a stream into a key-value pair that can be added to an 'Env' for -- simulation. @@ -308,8 +299,6 @@ evalStreams top specStrms initStrms = let ls = x `seq` (x:xs) in (id, toDyn ls) --------------------------------------------------------------------------------- - -- | Evaluate a trigger for a number of steps. evalTrigger :: ShowType -- ^ Show booleans as @0@/@1@ (C) or -- @True@/@False@ (Haskell). @@ -342,8 +331,6 @@ evalTrigger showType k strms evalUExpr (UExpr t e1) = map (showWithType showType t) (evalExprs_ k e1 strms) --------------------------------------------------------------------------------- - -- | Evaluate an observer for a number of steps. evalObserver :: ShowType -- ^ Show booleans as @0@/@1@ (C) or @True@/@False@ -- (Haskell). @@ -358,16 +345,12 @@ evalObserver showType k strms , observerExprType = t } = map (showWithType showType t) (evalExprs_ k e strms) --------------------------------------------------------------------------------- - -- | Evaluate an expression for a number of steps, producing a list with the -- changing value of the expression until that time. evalExprs_ :: Typeable a => Int -> Expr a -> Env Id -> [a] evalExprs_ k e strms = map (\i -> evalExpr_ i e [] strms) [0..(k-1)] --------------------------------------------------------------------------------- - -- | Safe indexing (!!) on possibly infininite lists. safeIndex :: Int -> [a] -> Maybe a safeIndex i ls = @@ -375,4 +358,49 @@ safeIndex i ls = if length ls' > i then Just (ls' !! i) else Nothing -------------------------------------------------------------------------------- +-- * Auxiliary + +-- Are we proving equivalence with a C backend, in which case we want to show +-- Booleans as '0' and '1'. + +-- | Target language for showing a typed value. Used to adapt the +-- representation of booleans. +data ShowType = C | Haskell + +-- | Show a value. The representation depends on the type and the target +-- language. Booleans are represented differently depending on the backend. +showWithType :: ShowType -> Type a -> a -> String +showWithType showT t x = + case showT of + C -> case t of + Bool -> if x then "1" else "0" + _ -> sw + Haskell -> case t of + Bool -> if x then "true" else "false" + _ -> sw + where + sw = case showWit t of + ShowWit -> show x + +-- * Auxiliary show instance + +-- | Witness datatype for showing a value, used by 'showWithType'. +data ShowWit a = Show a => ShowWit + +-- | Turn a type into a show witness. +showWit :: Type a -> ShowWit a +showWit t = + case t of + Bool -> ShowWit + Int8 -> ShowWit + Int16 -> ShowWit + Int32 -> ShowWit + Int64 -> ShowWit + Word8 -> ShowWit + Word16 -> ShowWit + Word32 -> ShowWit + Word64 -> ShowWit + Float -> ShowWit + Double -> ShowWit + Array t -> ShowWit + Struct t -> ShowWit diff --git a/copilot-core/src/Copilot/Core/Interpret/Render.hs b/copilot-interpreter/src/Copilot/Interpret/Render.hs similarity index 77% rename from copilot-core/src/Copilot/Core/Interpret/Render.hs rename to copilot-interpreter/src/Copilot/Interpret/Render.hs index 23b3a4fc5..3b6241a8c 100644 --- a/copilot-core/src/Copilot/Core/Interpret/Render.hs +++ b/copilot-interpreter/src/Copilot/Interpret/Render.hs @@ -1,25 +1,21 @@ --------------------------------------------------------------------------------- -- Copyright © 2011 National Institute of Aerospace / Galois, Inc. --------------------------------------------------------------------------------- -- | Pretty-print the results of a simulation. {-# LANGUAGE Safe #-} -module Copilot.Core.Interpret.Render +module Copilot.Interpret.Render ( renderAsTable , renderAsCSV ) where import Data.List (intersperse, transpose, foldl') import Data.Maybe (catMaybes) -import Copilot.Core.Interpret.Eval (Output, ExecTrace (..)) +import Copilot.Interpret.Eval (Output, ExecTrace (..)) import Text.PrettyPrint import Prelude hiding ((<>)) --------------------------------------------------------------------------------- - -- | Render an execution trace as a table, formatted to faciliate readability. renderAsTable :: ExecTrace -> String renderAsTable @@ -49,8 +45,6 @@ renderAsTable ppObserverOutputs :: [[Doc]] ppObserverOutputs = map (map text) (map snd obsvs) --------------------------------------------------------------------------------- - -- | Render an execution trace as using comma-separate value (CSV) format. renderAsCSV :: ExecTrace -> String renderAsCSV = render . unfold @@ -97,22 +91,19 @@ step ExecTrace , interpObservers = [] } --------------------------------------------------------------------------------- - - - -- Copied from pretty-ncols because of incompatibility with newer GHC versions. asColumns :: [[Doc]] -> Doc asColumns = flip asColumnsWithBuff $ 1 asColumnsWithBuff :: [[Doc]] -> Int -> Doc asColumnsWithBuff lls q = normalize - where normalize = vcat $ map hsep - $ map (\x -> pad (length x) longColumnLen empty x) - $ pad' longEntryLen q - $ transpose lls -- normalize column height - longColumnLen = maximum (map length lls) - longEntryLen = maximum $ map docLen (concat lls) + where + normalize = vcat $ map hsep + $ map (\x -> pad (length x) longColumnLen empty x) + $ pad' longEntryLen q + $ transpose lls -- normalize column height + longColumnLen = maximum (map length lls) + longEntryLen = maximum $ map docLen (concat lls) docLen d = length $ render d @@ -127,4 +118,5 @@ pad' :: Int -- ^ Mininum number of spaces to add -> [[Doc]] pad' _ _ [] = [] pad' mx q (ls:xs) = map buf ls : pad' mx q xs - where buf x = x <> (hcat $ replicate q space) <> (hcat $ replicate (mx - (docLen x)) space) + where + buf x = x <> (hcat $ replicate q space) <> (hcat $ replicate (mx - (docLen x)) space) diff --git a/copilot-interpreter/tests/Main.hs b/copilot-interpreter/tests/Main.hs new file mode 100644 index 000000000..608b41060 --- /dev/null +++ b/copilot-interpreter/tests/Main.hs @@ -0,0 +1,18 @@ +-- | Test copilot-core. +module Main where + +-- External imports +import Test.Framework (Test, defaultMain) + +-- Internal library modules being tested +import qualified Test.Copilot.Interpret.Eval + +-- | Run all unit tests on copilot-core. +main :: IO () +main = defaultMain tests + +-- | All unit tests in copilot-core. +tests :: [Test.Framework.Test] +tests = + [ Test.Copilot.Interpret.Eval.tests + ] diff --git a/copilot-core/tests/Test/Copilot/Core/Interpret/Eval.hs b/copilot-interpreter/tests/Test/Copilot/Interpret/Eval.hs similarity index 92% rename from copilot-core/tests/Test/Copilot/Core/Interpret/Eval.hs rename to copilot-interpreter/tests/Test/Copilot/Interpret/Eval.hs index 3832ea6b2..bcabddc21 100644 --- a/copilot-core/tests/Test/Copilot/Core/Interpret/Eval.hs +++ b/copilot-interpreter/tests/Test/Copilot/Interpret/Eval.hs @@ -1,10 +1,11 @@ {-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GADTs #-} -- | Test copilot-core:Copilot.Core.Interpret.Eval. -- -- The gist of this evaluation is in 'SemanticsP' and 'checkSemanticsP' which -- evaluates an expression using Copilot's evaluator and compares it against -- its expected meaning. -module Test.Copilot.Core.Interpret.Eval where +module Test.Copilot.Interpret.Eval where -- External imports import Data.Bits (Bits, complement, shiftL, shiftR, @@ -24,14 +25,14 @@ import Test.QuickCheck (Arbitrary, Gen, Property, import Text.PrettyPrint.HughesPJ (render) -- Internal imports: library modules being tested -import Copilot.Core.Expr (Expr (Const, Drop, Op1, Op2, Op3), - UExpr (UExpr)) -import Copilot.Core.Interpret.Eval (ExecTrace (interpObservers), eval) -import Copilot.Core.Operators (Op1 (..), Op2 (..), Op3 (..)) -import Copilot.Core.PrettyPrint (ppExpr) -import Copilot.Core.Spec (Observer (..), Spec (..), Stream (Stream)) -import Copilot.Core.Type (Typed (typeOf)) -import Copilot.Core.Type.Show (ShowType (Haskell), showType) +import Copilot.Core.Expr (Expr (Const, Drop, Op1, Op2, Op3), + UExpr (UExpr)) +import Copilot.Core.Operators (Op1 (..), Op2 (..), Op3 (..)) +import Copilot.Core.Spec (Observer (..), Spec (..), Stream (Stream)) +import Copilot.Core.Type (Type (..), Typed (typeOf)) +import Copilot.Interpret.Eval (ExecTrace (interpObservers), + ShowType (Haskell), eval) +import Copilot.PrettyPrint (ppExpr) -- Internal imports: auxiliary functions import Test.Extra (apply1, apply2, apply3) @@ -476,27 +477,42 @@ arbitraryBitsExpr = arbitraryBitsIntegralExpr :: (Arbitrary t, Typed t, Bits t, Integral t) => Gen (Expr t, [t]) arbitraryBitsIntegralExpr = - -- We use frequency instead of oneof because the random expression generator - -- seems to generate expressions that are too large and the test fails due - -- to running out of memory. - frequency - [ (10, arbitraryConst) - - , (2, apply1 <$> arbitraryNumOp1 <*> arbitraryBitsIntegralExpr) - - , (1, apply2 <$> arbitraryNumOp2 - <*> arbitraryBitsIntegralExpr - <*> arbitraryBitsIntegralExpr) + -- We use frequency instead of oneof because the random expression + -- generator seems to generate expressions that are too large and the + -- test fails due to running out of memory. + frequency + [ (10, arbitraryConst) + + , (2, apply1 <$> arbitraryNumOp1 <*> arbitraryBitsIntegralExpr) + + , (1, apply2 <$> arbitraryNumOp2 + <*> arbitraryBitsIntegralExpr + <*> arbitraryBitsIntegralExpr) + + , (5, apply2 <$> arbitraryBitsIntegralOp2 + <*> arbitraryBitsIntegralExpr + <*> arbitraryBitsIntegralExprConstPos) + + , (1, apply3 <$> arbitraryITEOp3 + <*> arbitraryBoolExpr + <*> arbitraryBitsIntegralExpr + <*> arbitraryBitsIntegralExpr) + ] + where - , (5, apply2 <$> arbitraryBitsIntegralOp2 - <*> arbitraryBitsIntegralExpr - <*> arbitraryBitsIntegralExpr) - - , (1, apply3 <$> arbitraryITEOp3 - <*> arbitraryBoolExpr - <*> arbitraryBitsIntegralExpr - <*> arbitraryBitsIntegralExpr) - ] + -- Generator for constant bit integral expressions that, when converted to + -- type 't', result in a positive number. We use a constant generator, as + -- opposed to a generator based on the more comprehensive + -- arbitraryBitsIntegralExpr, because the latter runs out of memory easily + -- when nested and filtered with suchThat. + arbitraryBitsIntegralExprConstPos = + (\v -> (Const typeOf v, repeat v)) <$> intThatFits + where + -- In this context: + -- + -- intThatFits :: Gen t + intThatFits = + suchThat arbitrary ((> 0) . (\x -> (fromIntegral x) :: Int)) -- ** Operators @@ -768,3 +784,21 @@ readResult = read . readResult' -- provided is not found in the map. lookupWithDefault :: Ord k => k -> v -> [(k, v)] -> v lookupWithDefault k def = fromMaybe def . lookup k + +-- | Show Copilot Core type. +showType :: Type a -> String +showType t = + case t of + Bool -> "Bool" + Int8 -> "Int8" + Int16 -> "Int16" + Int32 -> "Int32" + Int64 -> "Int64" + Word8 -> "Word8" + Word16 -> "Word16" + Word32 -> "Word32" + Word64 -> "Word64" + Float -> "Float" + Double -> "Double" + Array t -> "Array " ++ showType t + Struct t -> "Struct" diff --git a/copilot-interpreter/tests/Test/Extra.hs b/copilot-interpreter/tests/Test/Extra.hs new file mode 100644 index 000000000..f10d784c4 --- /dev/null +++ b/copilot-interpreter/tests/Test/Extra.hs @@ -0,0 +1,31 @@ +-- | Auxiliary testing helper functions. +module Test.Extra where + +-- External imports +import Control.Arrow ((***)) + +-- * Function application + +-- | Apply a tuple with two functions to a tuple of arguments. +apply1 :: (a1 -> b1, a2 -> b2) -- ^ Pair with functions + -> (a1, a2) -- ^ Pair with arguments + -> (b1, b2) -- ^ Pair with results +apply1 = uncurry (***) + +-- | Apply a tuple with two functions on two arguments to their tupled +-- arguments. +apply2 :: (a1 -> b1 -> c1, a2 -> b2 -> c2) -- ^ Pair with functions + -> (a1, a2) -- ^ Pair with first arguments + -> (b1, b2) -- ^ Pair with second arguments + -> (c1, c2) -- ^ Pair with results +apply2 fs = apply1 . apply1 fs + +-- | Apply a tuple with two functions on three arguments to their tupled +-- arguments. +apply3 :: (a1 -> b1 -> c1 -> d1, a2 -> b2 -> c2 -> d2) + -- ^ Pair with functions + -> (a1, a2) -- ^ Pair with first arguments + -> (b1, b2) -- ^ Pair with second arguments + -> (c1, c2) -- ^ Pair with third arguments + -> (d1, d2) -- ^ Pair with results +apply3 fs = apply2 . apply1 fs diff --git a/copilot-language/CHANGELOG b/copilot-language/CHANGELOG index 3fc253913..4aacc9e2e 100644 --- a/copilot-language/CHANGELOG +++ b/copilot-language/CHANGELOG @@ -1,4 +1,132 @@ -2021-10-19 +2026-11-07 + * Version bump (4.8.2). (#792) + +2026-09-07 + * Version bump (4.8.1). (#760) + +2026-07-07 + * Version bump (4.8). (#745) + +2026-05-07 + * Version bump (4.7.1). (#730) + +2026-03-07 + * Version bump (4.7). (#714) + +2026-01-07 + * Version bump (4.6.1). (#705) + * Relax version constraint on containers. (#603) + +2025-11-07 + * Version bump (4.6). (#679) + +2025-09-07 + * Version bump (4.5.1). (#666) + +2025-07-07 + * Version bump (4.5). (#642) + +2025-05-07 + * Version bump (4.4). (#618) + +2025-03-07 + * Version bump (4.3). (#604) + * Fix typo in documentation. (#587) + * Record how a Property's underlying proposition is quantified. (#254) + * Remove deprecated function Copilot.Language.Operators.Array.(.!!). + (#599) + +2025-01-07 + * Version bump (4.2). (#577) + * Bump upper version constraint on containers. (#570) + +2024-11-07 + * Version bump (4.1). (#561) + * Reject duplicate externs in properties and theorems. (#536) + * Standardize changelog format. (#550) + +2024-09-07 + * Version bump (4.0). (#532) + * Add support for array updates. (#36) + +2024-07-07 + * Version bump (3.20). (#522) + * Remove deprecated function Copilot.Language.Spec.forall. (#518) + * Add support for struct field updates. (#520) + +2024-05-07 + * Version bump (3.19.1). (#512) + +2024-03-07 + * Version bump (3.19). (#504) + +2024-01-07 + * Version bump (3.18.1). (#493) + +2024-01-07 + * Version bump (3.18). (#487) + * Add type annotation to help type inference engine. (#469) + * Rename forall to forAll. (#470) + +2023-11-07 + * Version bump (3.17). (#466) + +2023-09-07 + * Version bump (3.16.1). (#455) + +2023-07-07 + * Version bump (3.16). (#448) + * Move Copilot.Language.Stream.Arg to Copilot.Language.Spec. (#446) + +2023-05-07 + * Version bump (3.15). (#438) + * Remove outdated comment about pretty-printer. (#428) + +2023-03-07 + * Version bump (3.14). (#422) + * Remove function Copilot.Language.prettyPrint. (#412) + * Adjust to work with GHC 9.4. (#423) + +2023-01-07 + * Version bump (3.13). (#406) + +2022-11-07 + * Version bump (3.12). (#389) + * Use pretty-printer from copilot-prettyprinter. (#383) + +2022-09-07 + * Version bump (3.11). (#376) + * Deprecate prettyPrint. (#362) + * Reimplement DynStableName without unsafeCoerce. (#262) + * Use interpreter from copilot-interpreter. (#361) + * Remove unnecessary type constraints. (#369) + +2022-07-07 + * Version bump (3.10). (#356) + * Fix error in test case generation; enable CLI args in tests. (#337) + * Remove duplicated compiler option. (#328) + * Adjust imports due to deprecation. (#330) + * Fix typos in Copilot.Language.Interpret. (#331) + * Update 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) + * Introduce testing infrastructure. (#271) + * Remove deprecated module Copilot. (#291) + * Remove deprecated type StructArg. (#290) + * Mark package as uncurated to avoid modification. (#288) + +2022-01-07 + * Version bump (3.7). (#287) + * Bring back externF. (#261) + +2021-11-07 + * Version bump (3.6). (#264) + * Replace uses of copilot-core's error reporting functions. (#267) * Introduce new ops atan2, ceiling, floor. (#246) * Remove deprecated function. (#250) * Fix outdated/broken links. (#252) @@ -27,12 +155,12 @@ * Completed the documentation. (#112) 2020-05-07 - * Version bump (3.2). - * Fixed the reverse order of triggers (#114). - * Update description, bug-reports, changelog fields in cabal file - (#116). - * Bump ghc-prim version bounds (#122). - -2019-11-22 Ivan Perez - * Version bump (3.1). - * Remove ExternFun (#118). + * Version bump (3.2). (#65) + * Fixed the reverse order of triggers. (#114) + * Update description, bug-reports, changelog fields in cabal file. + (#116) + * Bump ghc-prim version bounds. (#122) + +2019-11-22 + * Version bump (3.1). (#46) + * Remove ExternFun. (#118) diff --git a/copilot-language/copilot-language.cabal b/copilot-language/copilot-language.cabal index 32997f470..40ba65f2c 100644 --- a/copilot-language/copilot-language.cabal +++ b/copilot-language/copilot-language.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: copilot-language -version: 3.5 +version: 4.8.2 synopsis: A Haskell-embedded DSL for monitoring hard real-time distributed systems. description: @@ -25,26 +25,28 @@ category: Language, Embedded build-type: Simple extra-source-files: README.md, CHANGELOG +x-curation: uncurated + source-repository head type: git location: https://github.com/Copilot-Language/copilot.git - subdir: lib/copilot-language + subdir: copilot-language library default-language: Haskell2010 hs-source-dirs: src - build-depends: base >= 4.9 && < 5 + build-depends: base >= 4.9 && < 5 - , array >= 0.5 && < 0.6 - , containers >= 0.4 && < 0.7 - , data-reify >= 0.6 && < 0.7 - , mtl >= 2.0 && < 3 + , array >= 0.5 && < 0.6 + , containers >= 0.4 && < 0.9 + , data-reify >= 0.6 && < 0.7 + , mtl >= 2.0 && < 3 - , copilot-core >= 3.5 && < 3.6 - , copilot-theorem >= 3.5 && < 3.6 + , copilot-core >= 4.8.2 && < 4.9 + , copilot-interpreter >= 4.8.2 && < 4.9 + , copilot-theorem >= 4.8.2 && < 4.9 - exposed-modules: Copilot - , Copilot.Language + exposed-modules: Copilot.Language , Copilot.Language.Operators.BitWise , Copilot.Language.Operators.Boolean , Copilot.Language.Operators.Propositional @@ -59,6 +61,7 @@ library , Copilot.Language.Operators.Ord , Copilot.Language.Operators.Temporal , Copilot.Language.Operators.Array + , Copilot.Language.Operators.Projection , Copilot.Language.Operators.Struct , Copilot.Language.Prelude , Copilot.Language.Reify @@ -70,5 +73,37 @@ library , System.Mem.StableName.Map , Copilot.Language.Error ghc-options: - -fwarn-tabs + -Wall + +test-suite unit-tests + type: + exitcode-stdio-1.0 + + main-is: + Main.hs + + other-modules: + Test.Copilot.Language.Reify + Test.Extra + + build-depends: + base + , HUnit + , QuickCheck + , pretty + , test-framework + , test-framework-hunit + , test-framework-quickcheck2 + + , copilot-core + , copilot-interpreter + , copilot-language + + hs-source-dirs: + tests + + default-language: + Haskell2010 + + ghc-options: -Wall diff --git a/copilot-language/src/Copilot.hs b/copilot-language/src/Copilot.hs deleted file mode 100644 index d0b5095f2..000000000 --- a/copilot-language/src/Copilot.hs +++ /dev/null @@ -1,14 +0,0 @@ --------------------------------------------------------------------------------- --- Copyright © 2011 National Institute of Aerospace / Galois, Inc. --------------------------------------------------------------------------------- - -{-# LANGUAGE Safe #-} - -module Copilot - {-# DEPRECATED "This module is deprecated." #-} - ( module Copilot.Language - ) where - -import Copilot.Language - --------------------------------------------------------------------------------- diff --git a/copilot-language/src/Copilot/Language.hs b/copilot-language/src/Copilot/Language.hs index 62d7369a7..674d601f7 100644 --- a/copilot-language/src/Copilot/Language.hs +++ b/copilot-language/src/Copilot/Language.hs @@ -1,12 +1,9 @@ --------------------------------------------------------------------------------- -- Copyright © 2011 National Institute of Aerospace / Galois, Inc. --------------------------------------------------------------------------------- -- | Main Copilot language export file. -- -- This is mainly a meta-module that re-exports most definitions in this --- library. It also provides a default pretty printer that prints a --- specification to stdout. +-- library. {-# LANGUAGE Safe #-} @@ -40,8 +37,8 @@ module Copilot.Language , arg , prop , theorem - , forall, exists - , prettyPrint + , forAll + , exists ) where import Data.Int hiding (Int) @@ -49,7 +46,6 @@ import Data.Word import Copilot.Core (Name, Typed) import Copilot.Core.Type import Copilot.Core.Type.Array -import qualified Copilot.Core.PrettyPrint as PP import Copilot.Language.Error import Copilot.Language.Interpret import Copilot.Language.Operators.Boolean @@ -70,12 +66,3 @@ import Copilot.Language.Reify import Copilot.Language.Prelude import Copilot.Language.Spec import Copilot.Language.Stream (Stream) - --------------------------------------------------------------------------------- - --- | Transform a high-level Copilot Language specification into a low-level --- Copilot Core specification and pretty-print it to stdout. -prettyPrint :: Spec -> IO () -prettyPrint e = fmap PP.prettyPrint (reify e) >>= putStr - --------------------------------------------------------------------------------- diff --git a/copilot-language/src/Copilot/Language/Analyze.hs b/copilot-language/src/Copilot/Language/Analyze.hs index f37ff077f..e7065f7b4 100644 --- a/copilot-language/src/Copilot/Language/Analyze.hs +++ b/copilot-language/src/Copilot/Language/Analyze.hs @@ -1,10 +1,8 @@ --------------------------------------------------------------------------------- -- Copyright © 2011 National Institute of Aerospace / Galois, Inc. --------------------------------------------------------------------------------- -{-# LANGUAGE Safe #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE Safe #-} {-# LANGUAGE ScopedTypeVariables #-} -- | Copilot specification sanity check. @@ -16,9 +14,10 @@ module Copilot.Language.Analyze import Copilot.Core (DropIdx) import qualified Copilot.Core as C -import Copilot.Language.Stream (Stream (..), Arg (..)) +import Copilot.Language.Stream (Stream (..)) import Copilot.Language.Spec import Copilot.Language.Error (badUsage) +import Copilot.Theorem.Prove (UProof) import Data.List (groupBy) import Data.IORef @@ -29,8 +28,6 @@ import qualified System.Mem.StableName.Map as M import Control.Monad (when, foldM_, foldM) import Control.Exception (Exception, throw) --------------------------------------------------------------------------------- - -- | Exceptions or kinds of errors in Copilot specifications that the analysis -- implemented is able to detect. data AnalyzeException @@ -57,7 +54,7 @@ instance Show AnalyzeException where show NestedArray = badUsage $ "An external function cannot take another external function or external array as an argument. Try defining a stream, and using the stream values in the other definition." show TooMuchRecursion = badUsage $ - "You have exceeded the limit of " ++ show maxRecursion ++ " recursive calls in a stream definition. Likely, you have accidently defined a circular stream, such as 'x = x'. Another possibility is you have defined a a polymorphic function with type constraints that references other streams. For example,\n\n nats :: (Typed a, Num a) => Stream a\n nats = [0] ++ nats + 1\n\nis not allowed. Make the definition monomorphic, or add a level of indirection, like \n\n nats :: (Typed a, Num a) => Stream a\n nats = n\n where n = [0] ++ n + 1\n\nFinally, you may have intended to generate a very large expression. You can try shrinking the expression by using local variables. It all else fails, you can increase the maximum size of ecursive calls by modifying 'maxRecursion' in copilot-language." + "You have exceeded the limit of " ++ show maxRecursion ++ " recursive calls in a stream definition. Likely, you have accidently defined a circular stream, such as 'x = x'. Another possibility is you have defined a a polymorphic function with type constraints that references other streams. For example,\n\n nats :: (Typed a, Num a) => Stream a\n nats = [0] ++ nats + 1\n\nis not allowed. Make the definition monomorphic, or add a level of indirection, like \n\n nats :: (Typed a, Num a) => Stream a\n nats = n\n where\n n = [0] ++ n + 1\n\nFinally, you may have intended to generate a very large expression. You can try shrinking the expression by using local variables. It all else fails, you can increase the maximum size of ecursive calls by modifying 'maxRecursion' in copilot-language." show InvalidField = badUsage $ "A struct can only take external variables, arrays, or other structs as fields." show (DifferentTypes name) = badUsage $ @@ -77,13 +74,9 @@ instance Exception AnalyzeException maxRecursion :: Int maxRecursion = 100000 --------------------------------------------------------------------------------- - -- | An environment that contains the nodes visited. type Env = Map () --------------------------------------------------------------------------------- - -- | Analyze a Copilot specification and report any errors detected. -- -- This function can fail with one of the exceptions in 'AnalyzeException'. @@ -96,8 +89,6 @@ analyze spec = do mapM_ (analyzeProperty refStreams) (map fst $ theorems $ runSpec spec) specExts refStreams spec >>= analyzeExts --------------------------------------------------------------------------------- - -- | Analyze a Copilot trigger and report any errors detected. -- -- This function can fail with one of the exceptions in 'AnalyzeException'. @@ -109,31 +100,27 @@ analyzeTrigger refStreams (Trigger _ e0 args) = analyzeTriggerArg :: Arg -> IO () analyzeTriggerArg (Arg e) = analyzeExpr refStreams e --------------------------------------------------------------------------------- - -- | Analyze a Copilot observer and report any errors detected. -- -- This function can fail with one of the exceptions in 'AnalyzeException'. analyzeObserver :: IORef Env -> Observer -> IO () analyzeObserver refStreams (Observer _ e) = analyzeExpr refStreams e --------------------------------------------------------------------------------- - -- | Analyze a Copilot property and report any errors detected. -- -- This function can fail with one of the exceptions in 'AnalyzeException'. analyzeProperty :: IORef Env -> Property -> IO () -analyzeProperty refStreams (Property _ e) = analyzeExpr refStreams e - --------------------------------------------------------------------------------- +analyzeProperty refStreams (Property _ p) = + -- Soundness note: it is OK to call `extractProp` here to drop the quantifier + -- from the proposition `p`, as the analysis does not depend on what the + -- quantifier is. + analyzeExpr refStreams (extractProp p) data SeenExtern = NoExtern | SeenFun | SeenArr | SeenStruct --------------------------------------------------------------------------------- - -- | Analyze a Copilot stream and report any errors detected. -- -- This function can fail with one of the exceptions in 'AnalyzeException'. @@ -165,8 +152,6 @@ analyzeExpr refStreams s = do go seenExt nodes' e3 Label _ e -> go seenExt nodes' e --------------------------------------------------------------------------------- - -- | Detect whether the given stream name has already been visited. -- -- This function throws a 'ReferentialCycle' exception if the second argument @@ -178,16 +163,12 @@ assertNotVisited _ dstn nodes = Just () -> throw ReferentialCycle Nothing -> return () --------------------------------------------------------------------------------- - -- | Check that the level of recursion is not above the max recursion allowed. mapCheck :: IORef Env -> IO Bool mapCheck refStreams = do ref <- readIORef refStreams return $ getSize ref > maxRecursion --------------------------------------------------------------------------------- - -- | Analyze a Copilot stream append and report any errors detected. analyzeAppend :: IORef Env -> DynStableName -> Stream a -> b @@ -200,8 +181,6 @@ analyzeAppend refStreams dstn e b f = do modifyIORef refStreams $ M.insert dstn () f refStreams e --------------------------------------------------------------------------------- - -- | Analyze a Copilot stream drop and report any errors detected. -- -- This function can fail if the drop is exercised over a stream that is not an @@ -214,12 +193,9 @@ analyzeDrop k (Append xs _ _) | otherwise = return () analyzeDrop _ _ = throw DropAppliedToNonAppend - --------------------------------------------------------------------------------- -- Analyzing external variables. We check that every reference to an external -- variable has the same type, and for external functions, they have the same -- typed arguments. --------------------------------------------------------------------------------- -- | An environment to store external variables, arrays, functions and structs, -- so that we can check types in the expression---e.g., if we declare the same @@ -231,8 +207,6 @@ data ExternEnv = ExternEnv , externStructArgs :: [(String, [C.SimpleType])] } --------------------------------------------------------------------------------- - -- | Make sure external variables, functions, arrays, and structs are correctly -- typed. analyzeExts :: ExternEnv -> IO () @@ -296,15 +270,19 @@ analyzeExts ExternEnv { externVarEnv = vars (head grp) -- should be typesafe, since this is from groupBy grp --------------------------------------------------------------------------------- - -- | Obtain all the externs in a specification. specExts :: IORef Env -> Spec' a -> IO ExternEnv specExts refStreams spec = do - env <- foldM triggerExts - (ExternEnv [] [] [] []) - (triggers $ runSpec spec) - foldM observerExts env (observers $ runSpec spec) + env0 <- foldM triggerExts + (ExternEnv [] [] [] []) + (triggers $ runSpec spec) + env1 <- foldM observerExts + env0 + (observers $ runSpec spec) + env2 <- foldM propertyExts + env1 + (properties $ runSpec spec) + foldM theoremExts env2 (theorems $ runSpec spec) where observerExts :: ExternEnv -> Observer -> IO ExternEnv @@ -316,6 +294,17 @@ specExts refStreams spec = do foldM (\env'' (Arg arg_) -> collectExts refStreams arg_ env'') env' args + propertyExts :: ExternEnv -> Property -> IO ExternEnv + propertyExts env (Property _ p) = + -- Soundness note: it is OK to call `extractProp` here to drop the + -- quantifier from the proposition `p`. This is because we are simply + -- gathering externs from `p`, and the presence of externs does not depend + -- on what the quantifier is. + collectExts refStreams (extractProp p) env + + theoremExts :: ExternEnv -> (Property, UProof) -> IO ExternEnv + theoremExts env (p, _) = propertyExts env p + -- | Obtain all the externs in a stream. collectExts :: C.Typed a => IORef Env -> Stream a -> ExternEnv -> IO ExternEnv collectExts refStreams stream_ env_ = do @@ -348,11 +337,7 @@ collectExts refStreams stream_ env_ = do go nodes env'' e3 Label _ e -> go nodes env e --------------------------------------------------------------------------------- - -- | Return the simple C type representation of the type of the values carried -- by a stream. getSimpleType :: forall a. C.Typed a => Stream a -> C.SimpleType getSimpleType _ = C.simpleType (C.typeOf :: C.Type a) - --------------------------------------------------------------------------------- diff --git a/copilot-language/src/Copilot/Language/Error.hs b/copilot-language/src/Copilot/Language/Error.hs index e44c29156..54833c445 100644 --- a/copilot-language/src/Copilot/Language/Error.hs +++ b/copilot-language/src/Copilot/Language/Error.hs @@ -1,6 +1,4 @@ --------------------------------------------------------------------------------- -- Copyright © 2011 National Institute of Aerospace / Galois, Inc. --------------------------------------------------------------------------------- {-# LANGUAGE Safe #-} diff --git a/copilot-language/src/Copilot/Language/Interpret.hs b/copilot-language/src/Copilot/Language/Interpret.hs index 5b2d1b9f2..78c1be014 100644 --- a/copilot-language/src/Copilot/Language/Interpret.hs +++ b/copilot-language/src/Copilot/Language/Interpret.hs @@ -1,28 +1,27 @@ -{- Copyright (c) 2011 National Institute of Aerospace / Galois, Inc. -} +-- Copyright (c) 2011 National Institute of Aerospace / Galois, Inc. --- | This module implements two interpreters, which may be used to simulated or --- executed Copilot specifications on a computer to understand their behavior --- to debug possible errors. +-- | This module implements two interpreters, which may be used to simulate or +-- execute Copilot specifications on a computer to understand their behavior to +-- debug possible errors. -- -- The interpreters included vary in how the present the results to the user. -- One of them uses a format (csv) that may be more machine-readable, while the -- other uses a format that may be easier for humans to read. -{-# LANGUAGE Safe #-} -{-# LANGUAGE GADTs, FlexibleInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE Safe #-} module Copilot.Language.Interpret ( csv , interpret ) where -import qualified Copilot.Core.Interpret as I +import qualified Copilot.Interpret as I import Copilot.Language.Spec (Spec) import Copilot.Language.Reify --------------------------------------------------------------------------------- - -- | Simulate a number of steps of a given specification, printing the results -- in a table in comma-separated value (CSV) format. csv :: Integer -> Spec -> IO () @@ -30,8 +29,6 @@ csv i spec = do putStrLn "Note: CSV format does not output observers." interpret' I.CSV i spec --------------------------------------------------------------------------------- - -- | Simulate a number of steps of a given specification, printing the results -- in a table in readable format. -- @@ -46,5 +43,3 @@ interpret' :: I.Format -> Integer -> Spec -> IO () interpret' format i spec = do coreSpec <- reify spec putStrLn $ I.interpret format (fromIntegral i) coreSpec - --------------------------------------------------------------------------------- diff --git a/copilot-language/src/Copilot/Language/Operators/Array.hs b/copilot-language/src/Copilot/Language/Operators/Array.hs index 0aecb7b64..17bb3bff3 100644 --- a/copilot-language/src/Copilot/Language/Operators/Array.hs +++ b/copilot-language/src/Copilot/Language/Operators/Array.hs @@ -1,37 +1,76 @@ -{-# LANGUAGE Safe #-} - -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE TypeFamilies #-} +-- The following warning is disabled due to a necessary instance of Projectable +-- defined in this module. +{-# OPTIONS_GHC -fno-warn-orphans #-} -- | Combinators to deal with streams carrying arrays. module Copilot.Language.Operators.Array - ( (.!!) + ( (!) + , (!!) + , (=:) + , (=$) ) where -import Copilot.Core ( Typed - , Op2 (Index) - , typeOf - , Array - , InnerType - , Flatten) -import Copilot.Language.Stream (Stream (..)) - -import Data.Word (Word32) -import GHC.TypeLits (KnownNat) +import Copilot.Core (Array, Op2 (Index), + Op3 (UpdateArray), Typed, typeOf) +import Copilot.Language.Operators.Projection (Projectable(..)) +import Copilot.Language.Stream (Stream (..)) --------------------------------------------------------------------------------- +import Data.Word (Word32) +import GHC.TypeLits (KnownNat) +import Prelude hiding ((!!)) -- | Create a stream that carries an element of an array in another stream. -- -- This function implements a projection of the element of an array at a given -- position, over time. For example, if @s@ is a stream of type @Stream (Array --- '5 Word8)@, then @s .!! 3@ has type @Stream Word8@ and contains the 3rd +-- '5 Word8)@, then @s ! 3@ has type @Stream Word8@ and contains the 3rd -- element (starting from zero) of the arrays in @s@ at any point in time. -(.!!) :: ( KnownNat n - , t' ~ InnerType t - , Flatten t t' - , Typed t - , Typed t' - ) => Stream (Array n t) -> Stream Word32 -> Stream t -arr .!! n = Op2 (Index typeOf) arr n - --------------------------------------------------------------------------------- +(!) :: (KnownNat n, Typed t) + => Stream (Array n t) -> Stream Word32 -> Stream t +arr ! n = Op2 (Index typeOf) arr n + +-- | Pair a stream with an element accessor, without applying it to obtain the +-- value of the element. +-- +-- This function is needed to refer to an element accessor when the goal is to +-- update the element value, not just to read it. +(!!) :: Stream (Array n t) + -> Stream Word32 + -> Projection (Array n t) (Stream Word32) t +(!!) = ProjectionA + +-- | Update a stream of arrays. + +-- This is an orphan instance; we suppress the warning that GHC would +-- normally produce with a GHC option at the top. +instance (KnownNat n, Typed t) => Projectable (Array n t) (Stream Word32) t where + + -- | A projection of an element of a stream of arrays. + data Projection (Array n t) (Stream Word32) t = + ProjectionA (Stream (Array n t)) (Stream Word32) + + -- | Create a stream where an element of an array has been updated with + -- values from another stream. + -- + -- For example, if an array has two elements of type @Int32@, and @s@ is a + -- stream of such array type (@Stream (Array 2 Int32)@), and $v0$ is a stream + -- of type @Int32@, then @s !! 0 =: v0@ has type @Stream (Array 2 Int32)@ and + -- contains arrays where the value of the first element of each array is that + -- of @v0@ at each point in time, and the value of the second element in the + -- array is the same it had in @s@. + (=:) (ProjectionA s ix) v = Op3 (UpdateArray typeOf) s ix v + + -- | Create a stream where an element of an array has been updated by + -- applying a stream function to it. + -- + -- For example, if an array has two elements of type @Int32@, and @s@ is a + -- stream of such array type (@Stream (Array 2 Int32)@), and $f$ is function + -- of type @Stream Int32 -> Stream Int32@, then @s !! 0 =$ f@ has type + -- @Stream (Array 2 Int32)@ and contains arrays where the value of the first + -- element of each array is that of @f (s ! 0)@ at each point in time, and + -- the value of the second element in the array is the same it had in @s@. + (=$) (ProjectionA s ix) op = Op3 (UpdateArray typeOf) s ix (op (s ! ix)) diff --git a/copilot-language/src/Copilot/Language/Operators/BitWise.hs b/copilot-language/src/Copilot/Language/Operators/BitWise.hs index 376c876ee..3b3c99d13 100644 --- a/copilot-language/src/Copilot/Language/Operators/BitWise.hs +++ b/copilot-language/src/Copilot/Language/Operators/BitWise.hs @@ -1,7 +1,6 @@ --------------------------------------------------------------------------------- -- Copyright © 2011 National Institute of Aerospace / Galois, Inc. --------------------------------------------------------------------------------- +{-# LANGUAGE CPP #-} {-# LANGUAGE Safe #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -18,7 +17,12 @@ import Copilot.Core (Typed, typeOf) import qualified Copilot.Core as Core import Copilot.Language.Stream import qualified Prelude as P + +#if MIN_VERSION_base(4,17,0) +import Data.Bits hiding ((.>>.), (.<<.)) +#else import Data.Bits +#endif -- | Instance of the 'Bits' class for 'Stream's. -- @@ -38,9 +42,11 @@ instance (Typed a, Bits a) => Bits (Stream a) where bit = P.error "tbd: bit" popCount = P.error "tbd: popCount" +#if !MIN_VERSION_base(4,17,0) -- | See 'xor'. (.^.) :: Bits a => a -> a -> a (.^.) = xor -- Avoid redefinition of the Operators.Boolean xor +#endif -- | Shifting values of a stream to the left. (.<<.) :: (Bits a, Typed a, Typed b, P.Integral b) diff --git a/copilot-language/src/Copilot/Language/Operators/Boolean.hs b/copilot-language/src/Copilot/Language/Operators/Boolean.hs index bc60dc412..c6aa05f60 100644 --- a/copilot-language/src/Copilot/Language/Operators/Boolean.hs +++ b/copilot-language/src/Copilot/Language/Operators/Boolean.hs @@ -1,6 +1,4 @@ --------------------------------------------------------------------------------- -- Copyright © 2011 National Institute of Aerospace / Galois, Inc. --------------------------------------------------------------------------------- {-# LANGUAGE Safe #-} @@ -21,8 +19,6 @@ import Copilot.Language.Operators.Constant (constant) import Copilot.Language.Stream import qualified Prelude as P --------------------------------------------------------------------------------- - -- | A stream that contains the constant value 'True'. true :: Stream Bool true = constant True @@ -64,5 +60,3 @@ xor x y = ( not x && y ) || ( x && not y ) -- | Apply the implication ('==>') operator to two boolean streams, point-wise. (==>) :: Stream Bool -> Stream Bool -> Stream Bool x ==> y = not x || y - --------------------------------------------------------------------------------- diff --git a/copilot-language/src/Copilot/Language/Operators/Cast.hs b/copilot-language/src/Copilot/Language/Operators/Cast.hs index fddf8774c..aad498c02 100644 --- a/copilot-language/src/Copilot/Language/Operators/Cast.hs +++ b/copilot-language/src/Copilot/Language/Operators/Cast.hs @@ -1,9 +1,7 @@ --------------------------------------------------------------------------------- -- Copyright © 2011 National Institute of Aerospace / Galois, Inc. --------------------------------------------------------------------------------- -{-# LANGUAGE Safe #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Safe #-} -- | Type-safe casting operators. module Copilot.Language.Operators.Cast @@ -16,8 +14,6 @@ import Copilot.Language.Stream import Data.Int import Data.Word --------------------------------------------------------------------------------- - -- | Class to capture casting between types for which it can be performed -- safely. class Cast a b where @@ -30,16 +26,12 @@ class UnsafeCast a b where -- | Perform an unsafe cast from @Stream a@ to @Stream b@. unsafeCast :: (Typed a, Typed b) => Stream a -> Stream b --------------------------------------------------------------------------------- - -- | Cast a boolean stream to a stream of numbers, producing 1 if the -- value at a point in time is 'True', and 0 otherwise. castBool :: (Eq a, Num a, Typed a) => Stream Bool -> Stream a castBool (Const bool) = Const $ if bool then 1 else 0 castBool x = Op3 (C.Mux typeOf) x 1 0 --------------------------------------------------------------------------------- - -- | Identity casting. instance Cast Bool Bool where cast = id @@ -84,15 +76,11 @@ instance Cast Bool Int32 where instance Cast Bool Int64 where cast = castBool --------------------------------------------------------------------------------- - -- | Cast a stream carrying numbers to an integral using 'fromIntegral'. castIntegral :: (Integral a, Typed a, Num b, Typed b) => Stream a -> Stream b castIntegral (Const x) = Const (fromIntegral x) castIntegral x = Op1 (C.Cast typeOf typeOf) x --------------------------------------------------------------------------------- - -- | Identity casting. instance Cast Word8 Word8 where cast = castIntegral @@ -121,8 +109,6 @@ instance Cast Word8 Int32 where instance Cast Word8 Int64 where cast = castIntegral --------------------------------------------------------------------------------- - -- | Identity casting. instance Cast Word16 Word16 where cast = castIntegral @@ -143,8 +129,6 @@ instance Cast Word16 Int32 where instance Cast Word16 Int64 where cast = castIntegral --------------------------------------------------------------------------------- - -- | Identity casting. instance Cast Word32 Word32 where cast = castIntegral @@ -157,14 +141,10 @@ instance Cast Word32 Word64 where instance Cast Word32 Int64 where cast = castIntegral --------------------------------------------------------------------------------- - -- | Identity casting. instance Cast Word64 Word64 where cast = castIntegral --------------------------------------------------------------------------------- - -- | Identity casting. instance Cast Int8 Int8 where cast = castIntegral @@ -181,8 +161,6 @@ instance Cast Int8 Int32 where instance Cast Int8 Int64 where cast = castIntegral --------------------------------------------------------------------------------- - -- | Identity casting. instance Cast Int16 Int16 where cast = castIntegral @@ -195,8 +173,6 @@ instance Cast Int16 Int32 where instance Cast Int16 Int64 where cast = castIntegral --------------------------------------------------------------------------------- - -- | Identity casting. instance Cast Int32 Int32 where cast = castIntegral @@ -205,8 +181,6 @@ instance Cast Int32 Int32 where instance Cast Int32 Int64 where cast = castIntegral --------------------------------------------------------------------------------- - -- | Identity casting. instance Cast Int64 Int64 where cast = castIntegral diff --git a/copilot-language/src/Copilot/Language/Operators/Constant.hs b/copilot-language/src/Copilot/Language/Operators/Constant.hs index 4c8c97c95..38bab6209 100644 --- a/copilot-language/src/Copilot/Language/Operators/Constant.hs +++ b/copilot-language/src/Copilot/Language/Operators/Constant.hs @@ -1,10 +1,7 @@ --------------------------------------------------------------------------------- -- Copyright © 2011 National Institute of Aerospace / Galois, Inc. --------------------------------------------------------------------------------- {-# LANGUAGE Safe #-} - -- | Primitives to build constant streams. module Copilot.Language.Operators.Constant ( constant @@ -27,15 +24,11 @@ import Copilot.Language.Stream import Data.Word import Data.Int --------------------------------------------------------------------------------- - -- | Create a constant stream that is equal to the given argument, at any -- point in time. constant :: Typed a => a -> Stream a constant = Const --------------------------------------------------------------------------------- - -- | Create a constant stream carrying values of type 'Bool' that is equal to -- the given argument, at any point in time. constB :: Bool -> Stream Bool diff --git a/copilot-language/src/Copilot/Language/Operators/Eq.hs b/copilot-language/src/Copilot/Language/Operators/Eq.hs index 1699c06b4..27df11dfb 100644 --- a/copilot-language/src/Copilot/Language/Operators/Eq.hs +++ b/copilot-language/src/Copilot/Language/Operators/Eq.hs @@ -1,6 +1,4 @@ --------------------------------------------------------------------------------- -- Copyright © 2011 National Institute of Aerospace / Galois, Inc. --------------------------------------------------------------------------------- {-# LANGUAGE Safe #-} @@ -16,8 +14,6 @@ import Copilot.Language.Prelude import Copilot.Language.Stream import qualified Prelude as P --------------------------------------------------------------------------------- - -- | Compare two streams point-wise for equality. -- -- The output stream contains the value True at a point in time if both @@ -33,5 +29,3 @@ x == y = Op2 (Core.Eq typeOf) x y (/=) :: (P.Eq a, Typed a) => Stream a -> Stream a -> Stream Bool (Const x) /= (Const y) = Const (x P./= y) x /= y = Op2 (Core.Ne typeOf) x y - --------------------------------------------------------------------------------- diff --git a/copilot-language/src/Copilot/Language/Operators/Extern.hs b/copilot-language/src/Copilot/Language/Operators/Extern.hs index 1794a5024..b6ea32533 100644 --- a/copilot-language/src/Copilot/Language/Operators/Extern.hs +++ b/copilot-language/src/Copilot/Language/Operators/Extern.hs @@ -1,6 +1,4 @@ --------------------------------------------------------------------------------- -- Copyright © 2011 National Institute of Aerospace / Galois, Inc. --------------------------------------------------------------------------------- -- | Primitives to build streams connected to external variables. @@ -17,6 +15,7 @@ module Copilot.Language.Operators.Extern , externI16 , externI32 , externI64 + , externF , externD ) where @@ -25,8 +24,6 @@ import Copilot.Language.Stream import Data.Word import Data.Int --------------------------------------------------------------------------------- - -- | Create a stream populated by an external global variable. -- -- The Copilot compiler does not check that the type is correct. If the list @@ -41,8 +38,6 @@ extern :: Typed a -> Stream a extern = Extern --------------------------------------------------------------------------------- - -- | Create a stream carrying values of type Bool, populated by an external -- global variable. externB :: String -- ^ Name of the global variable to make accessible. @@ -111,6 +106,13 @@ externI64 :: String -- ^ Name of the global variable to make accessible. -> Stream Int64 externI64 = extern +-- | Create a stream carrying values of type Float, populated by an external +-- global variable. +externF :: String -- ^ Name of the global variable to make accessible. + -> Maybe [Float] -- ^ Values to be used exclusively for testing/simulation. + -> Stream Float +externF = extern + -- | Create a stream carrying values of type Double, populated by an external -- global variable. externD :: String -- ^ Name of the global variable to make accessible. diff --git a/copilot-language/src/Copilot/Language/Operators/Integral.hs b/copilot-language/src/Copilot/Language/Operators/Integral.hs index 8ffcc29cc..e4d052490 100644 --- a/copilot-language/src/Copilot/Language/Operators/Integral.hs +++ b/copilot-language/src/Copilot/Language/Operators/Integral.hs @@ -1,6 +1,4 @@ --------------------------------------------------------------------------------- -- Copyright © 2011 National Institute of Aerospace / Galois, Inc. --------------------------------------------------------------------------------- -- | Integral class operators applied point-wise on streams. @@ -14,6 +12,7 @@ module Copilot.Language.Operators.Integral import Copilot.Core (Typed, typeOf) import qualified Copilot.Core as Core +import qualified Copilot.Language.Error as Err import Copilot.Language.Operators.BitWise ((.<<.)) import Copilot.Language.Stream @@ -21,18 +20,16 @@ import qualified Data.Bits as B import qualified Prelude as P import Data.List (foldl', replicate) --------------------------------------------------------------------------------- - -- | Apply the 'Prelude.div' operation to two streams, point-wise. div :: (Typed a, P.Integral a) => Stream a -> Stream a -> Stream a (Const 0) `div` _ = Const 0 -_ `div` (Const 0) = Core.badUsage "in div: division by zero." +_ `div` (Const 0) = Err.badUsage "in div: division by zero." x `div` (Const 1) = x x `div` y = Op2 (Core.Div typeOf) x y -- | Apply the 'Prelude.mod' operation to two streams, point-wise. mod :: (Typed a, P.Integral a) => Stream a -> Stream a -> Stream a -_ `mod` (Const 0) = Core.badUsage "in mod: division by zero." +_ `mod` (Const 0) = Err.badUsage "in mod: division by zero." (Const 0) `mod` _ = (Const 0) (Const x) `mod` (Const y) = Const (x `P.mod` y) x `mod` y = Op2 (Core.Mod typeOf) x y @@ -49,6 +46,4 @@ x `mod` y = Op2 (Core.Mod typeOf) x y (Const x) ^ (Const y) = Const (x P.^ y) (Const 2) ^ y = (Const 1) .<<. y x ^ (Const y) = foldl' ((P.*)) (Const 1) (replicate (P.fromIntegral y) x) -_ ^ _ = Core.badUsage "in ^: in x ^ y, either x must be the constant 2, or y must be a constant. (Do not confuse ^ with bitwise XOR (.^.) or with ** for exponentation of floats/doubles.)" - --------------------------------------------------------------------------------- +_ ^ _ = Err.badUsage "in ^: in x ^ y, either x must be the constant 2, or y must be a constant. (Do not confuse ^ with bitwise XOR (.^.) or with ** for exponentation of floats/doubles.)" diff --git a/copilot-language/src/Copilot/Language/Operators/Label.hs b/copilot-language/src/Copilot/Language/Operators/Label.hs index 7d4e65a82..f5c2b3359 100644 --- a/copilot-language/src/Copilot/Language/Operators/Label.hs +++ b/copilot-language/src/Copilot/Language/Operators/Label.hs @@ -1,6 +1,4 @@ --------------------------------------------------------------------------------- -- Copyright © 2011 National Institute of Aerospace / Galois, Inc. --------------------------------------------------------------------------------- -- | Label a stream with additional information. @@ -13,8 +11,6 @@ module Copilot.Language.Operators.Label import Copilot.Core (Typed) import Copilot.Language.Stream (Stream (..)) --------------------------------------------------------------------------------- - -- | This function allows you to label a stream with a tag, which can be used -- by different backends to provide additional information either in error -- messages or in the generated code (e.g., for traceability purposes). @@ -24,5 +20,3 @@ import Copilot.Language.Stream (Stream (..)) -- is used in the code generated is a decision specific to each backend. label :: (Typed a) => String -> Stream a -> Stream a label = Label - --------------------------------------------------------------------------------- diff --git a/copilot-language/src/Copilot/Language/Operators/Local.hs b/copilot-language/src/Copilot/Language/Operators/Local.hs index 8c95e6b5f..c80eb4f06 100644 --- a/copilot-language/src/Copilot/Language/Operators/Local.hs +++ b/copilot-language/src/Copilot/Language/Operators/Local.hs @@ -1,6 +1,4 @@ --------------------------------------------------------------------------------- -- Copyright © 2011 National Institute of Aerospace / Galois, Inc. --------------------------------------------------------------------------------- -- | Let expressions. -- @@ -18,8 +16,6 @@ module Copilot.Language.Operators.Local import Copilot.Core (Typed) import Copilot.Language.Stream (Stream (..)) --------------------------------------------------------------------------------- - -- | Let expressions. -- -- Create a stream that results from applying a stream to a function on @@ -33,5 +29,3 @@ import Copilot.Language.Stream (Stream (..)) -- @ local :: (Typed a, Typed b) => Stream a -> (Stream a -> Stream b) -> Stream b local = Local - --------------------------------------------------------------------------------- diff --git a/copilot-language/src/Copilot/Language/Operators/Mux.hs b/copilot-language/src/Copilot/Language/Operators/Mux.hs index a4b804b0a..d462817b8 100644 --- a/copilot-language/src/Copilot/Language/Operators/Mux.hs +++ b/copilot-language/src/Copilot/Language/Operators/Mux.hs @@ -1,6 +1,4 @@ --------------------------------------------------------------------------------- -- Copyright © 2011 National Institute of Aerospace / Galois, Inc. --------------------------------------------------------------------------------- {-# LANGUAGE Safe #-} @@ -17,16 +15,12 @@ import Copilot.Language.Prelude import Copilot.Language.Stream import Prelude () --------------------------------------------------------------------------------- - -- | Convenient synonym for 'ifThenElse'. mux :: Typed a => Stream Bool -> Stream a -> Stream a -> Stream a mux (Const True) t _ = t mux (Const False) _ f = f mux b t f = Op3 (Core.Mux typeOf) b t f --------------------------------------------------------------------------------- - -- | If-then-else applied point-wise to three streams (a condition stream, a -- then-branch stream, and an else-branch stream). -- @@ -35,5 +29,3 @@ mux b t f = Op3 (Core.Mux typeOf) b t f -- that time, otherwise it contains the value in the third stream. ifThenElse :: Typed a => Stream Bool -> Stream a -> Stream a -> Stream a ifThenElse = mux - --------------------------------------------------------------------------------- diff --git a/copilot-language/src/Copilot/Language/Operators/Ord.hs b/copilot-language/src/Copilot/Language/Operators/Ord.hs index cc9c5811b..36a1a4ecc 100644 --- a/copilot-language/src/Copilot/Language/Operators/Ord.hs +++ b/copilot-language/src/Copilot/Language/Operators/Ord.hs @@ -1,6 +1,4 @@ --------------------------------------------------------------------------------- -- Copyright © 2011 National Institute of Aerospace / Galois, Inc. --------------------------------------------------------------------------------- {-# LANGUAGE Safe #-} @@ -18,8 +16,6 @@ import Copilot.Language.Prelude import Copilot.Language.Stream import qualified Prelude as P --------------------------------------------------------------------------------- - -- | Compare two streams point-wise for order. -- -- The output stream contains the value True at a point in time if the @@ -55,5 +51,3 @@ x < y = Op2 (Core.Lt typeOf) x y (>) :: (P.Ord a, Typed a) => Stream a -> Stream a -> Stream Bool (Const x) > (Const y) = Const (x P.> y) x > y = Op2 (Core.Gt typeOf) x y - --------------------------------------------------------------------------------- diff --git a/copilot-language/src/Copilot/Language/Operators/Projection.hs b/copilot-language/src/Copilot/Language/Operators/Projection.hs new file mode 100644 index 000000000..0d05c050f --- /dev/null +++ b/copilot-language/src/Copilot/Language/Operators/Projection.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE TypeFamilies #-} +-- | Interface to access portions of a larger data structure. +-- +-- Default operations to access elements from structs and arrays (e.g., a field +-- of a struct, an element of an array) allow obtaining the values of those +-- elements, but not modifying. +-- +-- This module defines a common interface to manipulate portions of a larger +-- data structure. We define the interface in a generic way, using a type +-- class with two operations: one to set the value of the sub-element, and +-- one to update the value of such element applying a stream function. +module Copilot.Language.Operators.Projection + ( Projectable (..) ) + where + +import Copilot.Language.Stream (Stream) + +infixl 8 =: +infixl 8 =$ + +-- | Common interface to manipulate portions of a larger data structure. +-- +-- A projectable d s t means that it is possible to manipulate a sub-element s +-- of type t carried in a stream of type d. +class Projectable d s t | d s -> t where + + -- | Unapplied projection or element access on a type. + data Projection d s t + + -- | Modify the value of a sub-element of a type in a stream of elements + -- of that type. + (=:) :: Projection d s t -> Stream t -> Stream d + + -- | Update the value of a sub-element of a type in a stream of elements of + -- that type, by applying a function on streams. + (=$) :: Projection d s t -> (Stream t -> Stream t) -> Stream d diff --git a/copilot-language/src/Copilot/Language/Operators/Propositional.hs b/copilot-language/src/Copilot/Language/Operators/Propositional.hs index 1641669ce..abef3b2b0 100644 --- a/copilot-language/src/Copilot/Language/Operators/Propositional.hs +++ b/copilot-language/src/Copilot/Language/Operators/Propositional.hs @@ -1,8 +1,9 @@ --------------------------------------------------------------------------------- -- Copyright © 2011 National Institute of Aerospace / Galois, Inc. --------------------------------------------------------------------------------- -{-# LANGUAGE Safe, FlexibleInstances, GADTs, MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Safe #-} -- | Implement negation over quantified extensions of boolean streams. -- @@ -16,8 +17,6 @@ import qualified Copilot.Language.Operators.Boolean as B import Copilot.Theorem --------------------------------------------------------------------------------- - -- | A proposition that can be negated. class Negatable a b where -- | Negate a proposition. @@ -30,5 +29,3 @@ instance Negatable (Prop Existential) (Prop Universal) where -- | Negation of a universally quantified proposition. instance Negatable (Prop Universal) (Prop Existential) where not (Forall p) = Exists $ B.not p - --------------------------------------------------------------------------------- diff --git a/copilot-language/src/Copilot/Language/Operators/Struct.hs b/copilot-language/src/Copilot/Language/Operators/Struct.hs index e604ad864..f16005e1f 100644 --- a/copilot-language/src/Copilot/Language/Operators/Struct.hs +++ b/copilot-language/src/Copilot/Language/Operators/Struct.hs @@ -1,17 +1,47 @@ -{-# LANGUAGE Safe #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE TypeFamilies #-} +-- The following warning is disabled due to a necessary instance of Projectable +-- defined in this module. +{-# OPTIONS_GHC -fno-warn-orphans #-} -- | Combinators to deal with streams carrying structs. +-- +-- We support two kinds of operations on structs: reading the fields of structs +-- and modifying the fields of structs. +-- +-- To obtain the values of field @x@ of a struct @s@, you can just write: +-- +-- @ +-- expr = s # x +-- @ +-- +-- If you want to update it, use instead a double hash to refer to the field. +-- You can either update the field: +-- +-- @ +-- expr = s ## x =: 75 +-- @ +-- +-- To update it by applying a function to it, for example, the function that +-- updates a stream by one unit, just do: +-- +-- @ +-- expr = s ## x =$ (+1) +-- @ module Copilot.Language.Operators.Struct - ( (#) + ( Projectable(..) + , (#) + , (##) ) where import Copilot.Core.Type import Copilot.Core.Operators -import Copilot.Language.Stream (Stream (..)) +import Copilot.Language.Operators.Projection +import Copilot.Language.Stream (Stream (..)) -import GHC.TypeLits (KnownSymbol) - --------------------------------------------------------------------------------- +import GHC.TypeLits (KnownSymbol) -- | Create a stream that carries a field of a struct in another stream. -- @@ -20,8 +50,48 @@ import GHC.TypeLits (KnownSymbol) -- of type @Word8@, and @s@ is a stream of type @Stream T@, then @s # t2@ has -- type @Stream Word8@ and contains the values of the @t2@ field of the structs -- in @s@ at any point in time. -(#) :: (KnownSymbol s, Typed t, Typed a, Struct a) - => Stream a -> (a -> Field s t) -> Stream t +(#) :: (KnownSymbol f, Typed t, Typed s, Struct s) + => Stream s -> (s -> Field f t) -> Stream t (#) s f = Op1 (GetField typeOf typeOf f) s --------------------------------------------------------------------------------- +-- | Pair a stream with a field accessor, without applying it to obtain the +-- value of the field. +-- +-- This function is needed to refer to a field accessor when the goal is to +-- update the field value, not just to read it. +(##) :: (KnownSymbol f, Typed t, Typed s, Struct s) + => Stream s -> (s -> Field f t) -> Projection s (s -> Field f t) t +(##) = ProjectionS + +-- | Update a stream of structs. + +-- This is an orphan instance; we suppress the warning that GHC would +-- normally produce with a GHC option at the top. +instance (KnownSymbol f, Typed s, Typed t, Struct s) + => Projectable s (s -> Field f t) t + where + + -- | A projection of a field of a stream of structs. + data Projection s (s -> Field f t) t = ProjectionS (Stream s) (s -> Field f t) + + -- | Create a stream where the field of a struct has been updated with values + -- from another stream. + -- + -- For example, if a struct of type @T@ has two fields, @t1@ of type @Int32@ + -- and @t2@ of type @Word8@, and @s@ is a stream of type @Stream T@, and + -- $sT1$ is a stream of type @Int32@ then @s ## t2 =: sT1@ has type @Stream + -- T@ and contains structs where the value of @t1@ is that of @sT1@ and the + -- value of @t2@ is the value that the same field had in @s@, at any point in + -- time. + (=:) (ProjectionS s f) v = Op2 (UpdateField typeOf typeOf f) s v + + -- | Create a stream where the field of a struct has been updated by applying + -- a function to it. + -- + -- For example, if a struct of type @T@ has two fields, @t1@ of type @Int32@ + -- and @t2@ of type @Word8@, and @s@ is a stream of type @Stream T@, and $f$ + -- is a function from @Stream Int32 -> Stream Int32@ then @s ## t2 =$ f@ has + -- type @Stream T@ and contains structs where the value of @t1@ is that of + -- @f@ applied to the original value of @t1@ in @s@, and the value of @t2@ is + -- the value that the same field had in @s@, at any point in time. + (=$) (ProjectionS s f) op = Op2 (UpdateField typeOf typeOf f) s (op (s # f)) diff --git a/copilot-language/src/Copilot/Language/Operators/Temporal.hs b/copilot-language/src/Copilot/Language/Operators/Temporal.hs index 852473985..37b0d9a22 100644 --- a/copilot-language/src/Copilot/Language/Operators/Temporal.hs +++ b/copilot-language/src/Copilot/Language/Operators/Temporal.hs @@ -1,7 +1,4 @@ --------------------------------------------------------------------------------- -- Copyright © 2011 National Institute of Aerospace / Galois, Inc. --------------------------------------------------------------------------------- - {-# LANGUAGE Safe #-} @@ -16,8 +13,6 @@ import Copilot.Language.Prelude import Copilot.Language.Stream import Prelude () --------------------------------------------------------------------------------- - infixr 1 ++ -- | Prepend a fixed number of samples to a stream. diff --git a/copilot-language/src/Copilot/Language/Prelude.hs b/copilot-language/src/Copilot/Language/Prelude.hs index 70596c2af..aa7ebf51e 100644 --- a/copilot-language/src/Copilot/Language/Prelude.hs +++ b/copilot-language/src/Copilot/Language/Prelude.hs @@ -1,6 +1,4 @@ --------------------------------------------------------------------------------- -- Copyright © 2011 National Institute of Aerospace / Galois, Inc. --------------------------------------------------------------------------------- -- | Reexports 'Prelude' from package "base" hiding identifiers redefined by -- Copilot. @@ -31,5 +29,3 @@ import Prelude hiding , cycle , take ) - --------------------------------------------------------------------------------- diff --git a/copilot-language/src/Copilot/Language/Reify.hs b/copilot-language/src/Copilot/Language/Reify.hs index 8fa697afc..60bae450b 100644 --- a/copilot-language/src/Copilot/Language/Reify.hs +++ b/copilot-language/src/Copilot/Language/Reify.hs @@ -1,23 +1,24 @@ --------------------------------------------------------------------------------- -- Copyright © 2011 National Institute of Aerospace / Galois, Inc. --------------------------------------------------------------------------------- -- | Transform a Copilot Language specification into a Copilot Core -- specification. -{-# LANGUAGE Safe #-} -{-# LANGUAGE ExistentialQuantification, Rank2Types #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE Safe #-} module Copilot.Language.Reify ( reify ) where import qualified Copilot.Core as Core -import Copilot.Core (Typed, Id, typeOf, impossible) +import Copilot.Core (Typed, Id, typeOf) import Copilot.Language.Analyze (analyze) +import Copilot.Language.Error (impossible) import Copilot.Language.Spec -import Copilot.Language.Stream (Stream (..), Arg (..)) +import Copilot.Language.Stream (Stream (..)) import Copilot.Theorem.Prove @@ -27,7 +28,6 @@ import System.Mem.StableName.Dynamic import System.Mem.StableName.Map (Map) import qualified System.Mem.StableName.Map as M import Control.Monad (liftM, unless) --------------------------------------------------------------------------------- -- | Transform a Copilot Language specification into a Copilot Core -- specification. @@ -57,8 +57,6 @@ reify spec = do return cspec --------------------------------------------------------------------------------- - -- | Transform a Copilot observer specification into a Copilot Core -- observer specification. {-# INLINE mkObserver #-} @@ -75,8 +73,6 @@ mkObserver refMkId refStreams refMap (Observer name e) = do , Core.observerExpr = w , Core.observerExprType = typeOf } --------------------------------------------------------------------------------- - -- | Transform a Copilot trigger specification into a Copilot Core -- trigger specification. {-# INLINE mkTrigger #-} @@ -101,8 +97,6 @@ mkTrigger refMkId refStreams refMap (Trigger name guard args) = do w <- mkExpr refMkId refStreams refMap e return $ Core.UExpr typeOf w --------------------------------------------------------------------------------- - -- | Transform a Copilot property specification into a Copilot Core -- property specification. {-# INLINE mkProperty #-} @@ -112,13 +106,22 @@ mkProperty -> IORef [Core.Stream] -> Property -> IO Core.Property -mkProperty refMkId refStreams refMap (Property name guard) = do - w1 <- mkExpr refMkId refStreams refMap guard +mkProperty refMkId refStreams refMap (Property name p) = do + p' <- mkProp refMkId refStreams refMap p return Core.Property { Core.propertyName = name - , Core.propertyExpr = w1 } - --------------------------------------------------------------------------------- + , Core.propertyProp = p' } + +-- | Transform a Copilot proposition into a Copilot Core proposition. +mkProp :: IORef Int + -> IORef (Map Core.Id) + -> IORef [Core.Stream] + -> Prop a + -> IO Core.Prop +mkProp refMkId refStreams refMap prop = + case prop of + Forall e -> Core.Forall <$> mkExpr refMkId refStreams refMap e + Exists e -> Core.Exists <$> mkExpr refMkId refStreams refMap e -- | Transform a Copilot stream expression into a Copilot Core expression. {-# INLINE mkExpr #-} @@ -209,8 +212,6 @@ mkExpr refMkId refStreams refMap = go w <- mkExpr refMkId refStreams refMap e return $ (name, Core.UExpr typeOf w) --------------------------------------------------------------------------------- - -- | Transform a Copilot stream expression into a Copilot Core stream -- expression. {-# INLINE mkStream #-} @@ -256,8 +257,6 @@ mkStream refMkId refStreams refMap e0 = do , Core.streamExprType = typeOf } return id --------------------------------------------------------------------------------- - -- | Create a fresh, unused 'Id'. mkId :: IORef Int -> IO Id mkId refMkId = atomicModifyIORef refMkId $ \ n -> (succ n, n) diff --git a/copilot-language/src/Copilot/Language/Spec.hs b/copilot-language/src/Copilot/Language/Spec.hs index f6a3def0c..0127cd24b 100644 --- a/copilot-language/src/Copilot/Language/Spec.hs +++ b/copilot-language/src/Copilot/Language/Spec.hs @@ -1,11 +1,9 @@ --------------------------------------------------------------------------------- -- Copyright © 2011 National Institute of Aerospace / Galois, Inc. --------------------------------------------------------------------------------- -{-# LANGUAGE Safe #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE Safe #-} -- | Copilot specifications consistute the main declaration of Copilot modules. -- @@ -24,11 +22,13 @@ module Copilot.Language.Spec , Trigger (..) , trigger, triggers , arg + , Arg(..) , Property (..) , Prop (..) , prop, properties , theorem, theorems - , forall, exists + , forAll + , exists , extractProp , Universal, Existential ) where @@ -43,8 +43,6 @@ import Copilot.Language.Stream import Copilot.Theorem.Prove --------------------------------------------------------------------------------- - -- | A specification is a list of declarations of triggers, observers, -- properties and theorems. -- @@ -68,8 +66,6 @@ type Spec = Writer [SpecItem] () -- can be used in subsequent actions. type Spec' a = Writer [SpecItem] a --------------------------------------------------------------------------------- - -- | Return the complete list of declarations inside a 'Spec' or 'Spec''. -- -- The word run in this function is unrelated to running the underlying @@ -78,8 +74,6 @@ type Spec' a = Writer [SpecItem] a runSpec :: Spec' a -> [SpecItem] runSpec = execWriter --------------------------------------------------------------------------------- - -- | Filter a list of spec items to keep only the observers. observers :: [SpecItem] -> [Observer] observers = @@ -120,8 +114,6 @@ theorems = TheoremItem p -> p : ls _ -> ls --------------------------------------------------------------------------------- - -- | An item of a Copilot specification. data SpecItem = ObserverItem Observer @@ -129,15 +121,11 @@ data SpecItem | PropertyItem Property | TheoremItem (Property, UProof) --------------------------------------------------------------------------------- - -- | An observer, representing a stream that we observe during execution at -- every sample. data Observer where Observer :: Typed a => String -> Stream a -> Observer --------------------------------------------------------------------------------- - -- | Define a new observer as part of a specification. This allows someone to -- print the value at every iteration during interpretation. Observers do not -- have any functionality outside the interpreter. @@ -148,15 +136,11 @@ observer :: Typed a -> Spec observer name e = tell [ObserverItem $ Observer name e] --------------------------------------------------------------------------------- - -- | A trigger, representing a function we execute when a boolean stream becomes -- true at a sample. data Trigger where Trigger :: Core.Name -> Stream Bool -> [Arg] -> Trigger --------------------------------------------------------------------------------- - -- | Define a new trigger as part of a specification. A trigger declares which -- external function, or handler, will be called when a guard defined by a -- boolean stream becomes true. @@ -166,14 +150,10 @@ trigger :: String -- ^ Name of the handler to be called. -> Spec trigger name e args = tell [TriggerItem $ Trigger name e args] --------------------------------------------------------------------------------- - -- | A property, representing a boolean stream that is existentially or -- universally quantified over time. data Property where - Property :: String -> Stream Bool -> Property - --------------------------------------------------------------------------------- + Property :: String -> Prop a -> Property -- | A proposition, representing the quantification of a boolean streams over -- time. @@ -182,41 +162,41 @@ data Prop a where Exists :: Stream Bool -> Prop Existential -- | Universal quantification of boolean streams over time. -forall :: Stream Bool -> Prop Universal -forall = Forall +forAll :: Stream Bool -> Prop Universal +forAll = Forall -- | Existential quantification of boolean streams over time. exists :: Stream Bool -> Prop Existential exists = Exists -- | Extract the underlying stream from a quantified proposition. +-- +-- Think carefully before using this function, as this function will remove the +-- quantifier from a proposition. Universally quantified streams usually require +-- separate treatment from existentially quantified ones, so carelessly using +-- this function to remove quantifiers can result in hard-to-spot soundness +-- bugs. extractProp :: Prop a -> Stream Bool extractProp (Forall p) = p extractProp (Exists p) = p --------------------------------------------------------------------------------- - -- | A proposition, representing a boolean stream that is existentially or -- universally quantified over time, as part of a specification. -- -- This function returns, in the monadic context, a reference to the -- proposition. prop :: String -> Prop a -> Writer [SpecItem] (PropRef a) -prop name e = tell [PropertyItem $ Property name (extractProp e)] +prop name e = tell [PropertyItem $ Property name e] >> return (PropRef name) --------------------------------------------------------------------------------- - -- | A theorem, or proposition together with a proof. -- -- This function returns, in the monadic context, a reference to the -- proposition. theorem :: String -> Prop a -> Proof a -> Writer [SpecItem] (PropRef a) -theorem name e (Proof p) = tell [TheoremItem (Property name (extractProp e), p)] +theorem name e (Proof p) = tell [TheoremItem (Property name e, p)] >> return (PropRef name) --------------------------------------------------------------------------------- - -- | Construct a function argument from a stream. -- -- 'Arg's can be used to pass arguments to handlers or trigger functions, to @@ -227,4 +207,6 @@ theorem name e (Proof p) = tell [TheoremItem (Property name (extractProp e), p)] arg :: Typed a => Stream a -> Arg arg = Arg --------------------------------------------------------------------------------- +-- | Wrapper to use 'Stream's as arguments to triggers. +data Arg where + Arg :: Typed a => Stream a -> Arg diff --git a/copilot-language/src/Copilot/Language/Stream.hs b/copilot-language/src/Copilot/Language/Stream.hs index d88a98ee9..3c2a2f838 100644 --- a/copilot-language/src/Copilot/Language/Stream.hs +++ b/copilot-language/src/Copilot/Language/Stream.hs @@ -1,31 +1,25 @@ --------------------------------------------------------------------------------- -- Copyright © 2011 National Institute of Aerospace / Galois, Inc. --------------------------------------------------------------------------------- -- | Abstract syntax for streams and operators. -{-# LANGUAGE Safe #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} -{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE Safe #-} module Copilot.Language.Stream ( Stream (..) - , Arg (..) - , StructArg (..) , Copilot.Language.Stream.ceiling , Copilot.Language.Stream.floor , Copilot.Language.Stream.atan2 ) where import Copilot.Core (Typed, typeOf) -import Copilot.Core.Error import qualified Copilot.Core as Core +import Copilot.Language.Error import Copilot.Language.Prelude import qualified Prelude as P --------------------------------------------------------------------------------- - -- | A stream in Copilot is an infinite succession of values of the same type. -- -- Streams can be built using simple primities (e.g., 'Const'), by applying @@ -53,30 +47,15 @@ data Stream :: * -> * where => Core.Op3 a b c d -> Stream a -> Stream b -> Stream c -> Stream d Label :: Typed a => String -> Stream a -> Stream a --------------------------------------------------------------------------------- - --- | Wrapper to use 'Stream's as arguments to triggers. -data Arg where - Arg :: Typed a => Stream a -> Arg - -data StructArg = StructArg { name_ :: String, arg' :: Arg } -{-# DEPRECATED StructArg "StructArg is deprecated" #-} - --------------------------------------------------------------------------------- - -- | Dummy instance in order to make 'Stream' an instance of 'Num'. instance Show (Stream a) where show _ = "Stream" --------------------------------------------------------------------------------- - -- | Dummy instance in order to make 'Stream' an instance of 'Num'. instance P.Eq (Stream a) where (==) = badUsage "'Prelude.(==)' isn't implemented for streams!" (/=) = badUsage "'Prelude.(/=)' isn't implemented for streams!" --------------------------------------------------------------------------------- - -- | Streams carrying numbers are instances of 'Num', and you can apply to them -- the 'Num' functions, point-wise. instance (Typed a, P.Eq a, Num a) => Num (Stream a) where @@ -104,8 +83,6 @@ instance (Typed a, P.Eq a, Num a) => Num (Stream a) where fromInteger = Const . fromInteger --------------------------------------------------------------------------------- - -- | Streams carrying fractional numbers are instances of 'Fractional', and you can -- apply to them the 'Fractional' functions, point-wise. @@ -119,8 +96,6 @@ instance (Typed a, P.Eq a, Fractional a) => Fractional (Stream a) where fromRational = Const . fromRational --------------------------------------------------------------------------------- - -- | Streams carrying floating point numbers are instances of 'Floating', and -- you can apply to them the 'Floating' functions, point-wise. @@ -146,8 +121,6 @@ instance (Typed a, Eq a, Floating a) => Floating (Stream a) where atanh = Op1 (Core.Atanh typeOf) acosh = Op1 (Core.Acosh typeOf) --------------------------------------------------------------------------------- - -- | Point-wise application of @ceiling@ to a stream. -- -- Unlike the Haskell variant of this function, this variant takes and returns @@ -180,9 +153,6 @@ ceiling = Op1 (Core.Ceiling typeOf) floor :: (Typed a, RealFrac a) => Stream a -> Stream a floor = Op1 (Core.Floor typeOf) - --------------------------------------------------------------------------------- - -- | Point-wise application of @atan2@ to the values of two streams. -- -- For each pair of real floating-point samples @x@ and @y@, one from each diff --git a/copilot-language/src/System/Mem/StableName/Dynamic.hs b/copilot-language/src/System/Mem/StableName/Dynamic.hs index fdea7036b..01771285d 100644 --- a/copilot-language/src/System/Mem/StableName/Dynamic.hs +++ b/copilot-language/src/System/Mem/StableName/Dynamic.hs @@ -1,8 +1,7 @@ --------------------------------------------------------------------------------- -- Copyright © 2011 National Institute of Aerospace / Galois, Inc. --------------------------------------------------------------------------------- -{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE Safe #-} module System.Mem.StableName.Dynamic ( DynStableName(..) @@ -10,19 +9,19 @@ module System.Mem.StableName.Dynamic , makeDynStableName ) where -import System.Mem.StableName (StableName, makeStableName, hashStableName) -import Unsafe.Coerce (unsafeCoerce) -- XXX Not safe! +import System.Mem.StableName (StableName, eqStableName, makeStableName, + hashStableName) -newtype DynStableName = DynStableName (StableName ()) +data DynStableName = forall a . DynStableName (StableName a) makeDynStableName :: a -> IO DynStableName makeDynStableName x = do stn <- makeStableName x - return (DynStableName (unsafeCoerce stn)) + return (DynStableName stn) hashDynStableName :: DynStableName -> Int hashDynStableName (DynStableName sn) = hashStableName sn instance Eq DynStableName where - DynStableName sn1 == DynStableName sn2 = sn1 == sn2 + DynStableName sn1 == DynStableName sn2 = eqStableName sn1 sn2 diff --git a/copilot-language/src/System/Mem/StableName/Map.hs b/copilot-language/src/System/Mem/StableName/Map.hs index 320a284ba..5577385dc 100644 --- a/copilot-language/src/System/Mem/StableName/Map.hs +++ b/copilot-language/src/System/Mem/StableName/Map.hs @@ -1,6 +1,4 @@ --------------------------------------------------------------------------------- -- Most of this code is taken from 'http://github.com/ekmett/stable-maps'. --------------------------------------------------------------------------------- {-# LANGUAGE Safe #-} @@ -25,7 +23,7 @@ import System.Mem.StableName.Dynamic import qualified Data.IntMap as IntMap import Data.IntMap (IntMap) -import Copilot.Core.Error (impossible) +import Copilot.Language.Error (impossible) data Map a = Map { getMap :: IntMap [(DynStableName, a)] , getSize :: Int } diff --git a/copilot-language/tests/Main.hs b/copilot-language/tests/Main.hs new file mode 100644 index 000000000..790b2c9b3 --- /dev/null +++ b/copilot-language/tests/Main.hs @@ -0,0 +1,18 @@ +-- | Test copilot-language. +module Main where + +-- External imports +import Test.Framework (Test, defaultMain) + +-- Internal imports +import qualified Test.Copilot.Language.Reify + +-- | Run all unit tests on copilot-language. +main :: IO () +main = defaultMain tests + +-- | All unit tests in copilot-language. +tests :: [Test.Framework.Test] +tests = + [ Test.Copilot.Language.Reify.tests + ] diff --git a/copilot-language/tests/Test/Copilot/Language/Reify.hs b/copilot-language/tests/Test/Copilot/Language/Reify.hs new file mode 100644 index 000000000..b9d5085ba --- /dev/null +++ b/copilot-language/tests/Test/Copilot/Language/Reify.hs @@ -0,0 +1,782 @@ +{-# LANGUAGE ExistentialQuantification #-} +-- | Test copilot-language:Copilot.Language.Reify. +-- +-- The gist of this evaluation is in 'SemanticsP' and 'checkSemanticsP' which +-- evaluates an expression using Copilot's evaluator and compares it against +-- its expected meaning. +module Test.Copilot.Language.Reify where + +-- External imports +import Data.Bits (Bits, complement, shiftL, shiftR, + xor, (.&.), (.|.)) +import Data.Int (Int16, Int32, Int64, Int8) +import Data.Maybe (fromMaybe) +import Data.Typeable (Typeable) +import Data.Word (Word16, Word32, Word64, Word8) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.QuickCheck (Arbitrary, Gen, Property, + arbitrary, chooseInt, elements, + forAll, forAllShow, frequency, + oneof, suchThat) +import Test.QuickCheck.Monadic (monadicIO, run) + +-- Internal imports: library modules being tested +import Copilot.Language (Typed) +import qualified Copilot.Language.Operators.BitWise as Copilot +import qualified Copilot.Language.Operators.Boolean as Copilot +import qualified Copilot.Language.Operators.Constant as Copilot +import qualified Copilot.Language.Operators.Eq as Copilot +import qualified Copilot.Language.Operators.Integral as Copilot +import qualified Copilot.Language.Operators.Mux as Copilot +import qualified Copilot.Language.Operators.Ord as Copilot +import Copilot.Language.Reify (reify) +import Copilot.Language.Spec (Spec, observer) +import Copilot.Language.Stream (Stream) +import qualified Copilot.Language.Stream as Copilot + +-- Internal imports: functions needed to test after reification +import Copilot.Interpret.Eval (ExecTrace (interpObservers), ShowType (Haskell), + eval) + +-- Internal imports: auxiliary functions +import Test.Extra (apply1, apply2, apply3) + +-- * Constants + +-- | Max length of the traces being tested. +maxTraceLength :: Int +maxTraceLength = 200 + +-- | All unit tests for copilot-language:Copilot.Language.Reify. +tests :: Test.Framework.Test +tests = + testGroup "Copilot.Language.Reify" + [ testProperty "eval Stream" testEvalExpr ] + +-- * Individual tests + +-- | Test for expression evaluation. +testEvalExpr :: Property +testEvalExpr = + forAll (chooseInt (0, maxTraceLength)) $ \steps -> + forAllShow arbitrarySemanticsP (semanticsShowK steps) $ \pair -> + monadicIO $ run (checkSemanticsP steps [] pair) + +-- * Random generators + +-- ** Random SemanticsP generators + +-- | An arbitrary expression, paired with its expected meaning. +-- +-- See the function 'checkSemanticsP' to evaluate the pair. +arbitrarySemanticsP :: Gen SemanticsP +arbitrarySemanticsP = oneof + [ SemanticsP <$> (arbitraryBoolExpr :: Gen (Semantics Bool)) + , SemanticsP <$> (arbitraryNumExpr :: Gen (Semantics Int8)) + , SemanticsP <$> (arbitraryNumExpr :: Gen (Semantics Int16)) + , SemanticsP <$> (arbitraryNumExpr :: Gen (Semantics Int32)) + , SemanticsP <$> (arbitraryNumExpr :: Gen (Semantics Int64)) + , SemanticsP <$> (arbitraryNumExpr :: Gen (Semantics Word8)) + , SemanticsP <$> (arbitraryNumExpr :: Gen (Semantics Word16)) + , SemanticsP <$> (arbitraryNumExpr :: Gen (Semantics Word32)) + , SemanticsP <$> (arbitraryNumExpr :: Gen (Semantics Word64)) + , SemanticsP <$> (arbitraryFloatingExpr :: Gen (Semantics Float)) + , SemanticsP <$> (arbitraryFloatingExpr :: Gen (Semantics Double)) + , SemanticsP <$> (arbitraryRealFracExpr :: Gen (Semantics Float)) + , SemanticsP <$> (arbitraryRealFracExpr :: Gen (Semantics Double)) + , SemanticsP <$> (arbitraryRealFloatExpr :: Gen (Semantics Float)) + , SemanticsP <$> (arbitraryRealFloatExpr :: Gen (Semantics Double)) + , SemanticsP <$> (arbitraryFractionalExpr :: Gen (Semantics Float)) + , SemanticsP <$> (arbitraryFractionalExpr :: Gen (Semantics Double)) + , SemanticsP <$> (arbitraryIntegralExpr :: Gen (Semantics Int8)) + , SemanticsP <$> (arbitraryIntegralExpr :: Gen (Semantics Int16)) + , SemanticsP <$> (arbitraryIntegralExpr :: Gen (Semantics Int32)) + , SemanticsP <$> (arbitraryIntegralExpr :: Gen (Semantics Int64)) + , SemanticsP <$> (arbitraryIntegralExpr :: Gen (Semantics Word8)) + , SemanticsP <$> (arbitraryIntegralExpr :: Gen (Semantics Word16)) + , SemanticsP <$> (arbitraryIntegralExpr :: Gen (Semantics Word32)) + , SemanticsP <$> (arbitraryIntegralExpr :: Gen (Semantics Word64)) + , SemanticsP <$> (arbitraryBitsExpr :: Gen (Semantics Bool)) + , SemanticsP <$> (arbitraryBitsExpr :: Gen (Semantics Int8)) + , SemanticsP <$> (arbitraryBitsExpr :: Gen (Semantics Int16)) + , SemanticsP <$> (arbitraryBitsExpr :: Gen (Semantics Int32)) + , SemanticsP <$> (arbitraryBitsExpr :: Gen (Semantics Int64)) + , SemanticsP <$> (arbitraryBitsExpr :: Gen (Semantics Word8)) + , SemanticsP <$> (arbitraryBitsExpr :: Gen (Semantics Word16)) + , SemanticsP <$> (arbitraryBitsExpr :: Gen (Semantics Word32)) + , SemanticsP <$> (arbitraryBitsExpr :: Gen (Semantics Word64)) + , SemanticsP <$> (arbitraryBitsIntegralExpr :: Gen (Semantics Int8)) + , SemanticsP <$> (arbitraryBitsIntegralExpr :: Gen (Semantics Int16)) + , SemanticsP <$> (arbitraryBitsIntegralExpr :: Gen (Semantics Int32)) + , SemanticsP <$> (arbitraryBitsIntegralExpr :: Gen (Semantics Int64)) + , SemanticsP <$> (arbitraryBitsIntegralExpr :: Gen (Semantics Word8)) + , SemanticsP <$> (arbitraryBitsIntegralExpr :: Gen (Semantics Word16)) + , SemanticsP <$> (arbitraryBitsIntegralExpr :: Gen (Semantics Word32)) + , SemanticsP <$> (arbitraryBitsIntegralExpr :: Gen (Semantics Word64)) + ] + +-- ** Random Stream generators + +-- | An arbitrary constant expression of any type, paired with its expected +-- meaning. +arbitraryConst :: (Arbitrary t, Typed t) + => Gen (Stream t, [t]) +arbitraryConst = (\v -> (Copilot.constant v, repeat v)) <$> arbitrary + +-- | Generator for constant boolean streams, paired with their expected +-- meaning. +arbitraryBoolOp0 :: Gen (Stream Bool, [Bool]) +arbitraryBoolOp0 = elements + [ (Copilot.false, repeat False) + , (Copilot.true, repeat True) + ] + +-- | An arbitrary boolean expression, paired with its expected meaning. +arbitraryBoolExpr :: Gen (Stream Bool, [Bool]) +arbitraryBoolExpr = + -- We use frequency instead of oneof because the random expression generator + -- seems to generate expressions that are too large and the test fails due + -- to running out of memory. + frequency + [ (10, arbitraryConst) + + , (5, arbitraryBoolOp0) + + , (5, apply1 <$> arbitraryBoolOp1 <*> arbitraryBoolExpr) + + , (1, apply2 <$> arbitraryBoolOp2 + <*> arbitraryBoolExpr + <*> arbitraryBoolExpr) + + , (1, apply2 <$> arbitraryEqOp2 + <*> arbitraryBoolExpr + <*> arbitraryBoolExpr) + + , (1, apply2 <$> arbitraryEqOp2 + <*> arbitraryBitsExpr + <*> (arbitraryBitsExpr :: Gen (Stream Int8, [Int8]))) + + , (1, apply2 <$> arbitraryEqOp2 + <*> arbitraryBitsExpr + <*> (arbitraryBitsExpr :: Gen (Stream Int16, [Int16]))) + + , (1, apply2 <$> arbitraryEqOp2 + <*> arbitraryBitsExpr + <*> (arbitraryBitsExpr :: Gen (Stream Int32, [Int32]))) + + , (1, apply2 <$> arbitraryEqOp2 + <*> arbitraryBitsExpr + <*> (arbitraryBitsExpr :: Gen (Stream Int64, [Int64]))) + + , (1, apply2 <$> arbitraryEqOp2 + <*> arbitraryBitsExpr + <*> (arbitraryBitsExpr :: Gen (Stream Word8, [Word8]))) + + , (1, apply2 <$> arbitraryEqOp2 + <*> arbitraryBitsExpr + <*> (arbitraryBitsExpr :: Gen (Stream Word16, [Word16]))) + + , (1, apply2 <$> arbitraryEqOp2 + <*> arbitraryBitsExpr + <*> (arbitraryBitsExpr :: Gen (Stream Word32, [Word32]))) + + , (1, apply2 <$> arbitraryEqOp2 + <*> arbitraryBitsExpr + <*> (arbitraryBitsExpr :: Gen (Stream Word64, [Word64]))) + + , (1, apply2 <$> arbitraryEqOp2 + <*> arbitraryNumExpr + <*> (arbitraryNumExpr :: Gen (Stream Int8, [Int8]))) + + , (1, apply2 <$> arbitraryEqOp2 + <*> arbitraryNumExpr + <*> (arbitraryNumExpr :: Gen (Stream Int16, [Int16]))) + + , (1, apply2 <$> arbitraryEqOp2 + <*> arbitraryNumExpr + <*> (arbitraryNumExpr :: Gen (Stream Int32, [Int32]))) + + , (1, apply2 <$> arbitraryEqOp2 + <*> arbitraryNumExpr + <*> (arbitraryNumExpr :: Gen (Stream Int64, [Int64]))) + + , (1, apply2 <$> arbitraryEqOp2 + <*> arbitraryNumExpr + <*> (arbitraryNumExpr :: Gen (Stream Word8, [Word8]))) + + , (1, apply2 <$> arbitraryEqOp2 + <*> arbitraryNumExpr + <*> (arbitraryNumExpr :: Gen (Stream Word16, [Word16]))) + + , (1, apply2 <$> arbitraryEqOp2 + <*> arbitraryNumExpr + <*> (arbitraryNumExpr :: Gen (Stream Word32, [Word32]))) + + , (1, apply2 <$> arbitraryEqOp2 + <*> arbitraryNumExpr + <*> (arbitraryNumExpr :: Gen (Stream Word64, [Word64]))) + + , (1, apply2 <$> arbitraryOrdOp2 + <*> arbitraryNumExpr + <*> (arbitraryNumExpr :: Gen (Stream Int8, [Int8]))) + + , (1, apply2 <$> arbitraryOrdOp2 + <*> arbitraryNumExpr + <*> (arbitraryNumExpr :: Gen (Stream Int16, [Int16]))) + + , (1, apply2 <$> arbitraryOrdOp2 + <*> arbitraryNumExpr + <*> (arbitraryNumExpr :: Gen (Stream Int32, [Int32]))) + + , (1, apply2 <$> arbitraryOrdOp2 + <*> arbitraryNumExpr + <*> (arbitraryNumExpr :: Gen (Stream Int64, [Int64]))) + + , (1, apply2 <$> arbitraryOrdOp2 + <*> arbitraryNumExpr + <*> (arbitraryNumExpr :: Gen (Stream Word8, [Word8]))) + + , (1, apply2 <$> arbitraryOrdOp2 + <*> arbitraryNumExpr + <*> (arbitraryNumExpr :: Gen (Stream Word16, [Word16]))) + + , (1, apply2 <$> arbitraryOrdOp2 + <*> arbitraryNumExpr + <*> (arbitraryNumExpr :: Gen (Stream Word32, [Word32]))) + + , (1, apply2 <$> arbitraryOrdOp2 + <*> arbitraryNumExpr + <*> (arbitraryNumExpr :: Gen (Stream Word64, [Word64]))) + + , (1, apply2 <$> arbitraryOrdOp2 + <*> arbitraryFloatingExpr + <*> (arbitraryFloatingExpr :: Gen (Stream Float, [Float]))) + + , (1, apply2 <$> arbitraryOrdOp2 + <*> arbitraryFloatingExpr + <*> (arbitraryFloatingExpr :: Gen (Stream Double, [Double]))) + + , (1, apply3 <$> arbitraryITEOp3 + <*> arbitraryBoolExpr + <*> arbitraryBoolExpr + <*> arbitraryBoolExpr) + ] + +-- | An arbitrary numeric expression, paired with its expected meaning. +arbitraryNumExpr :: (Arbitrary t, Typed t, Num t, Eq t) + => Gen (Stream t, [t]) +arbitraryNumExpr = + -- We use frequency instead of oneof because the random expression generator + -- seems to generate expressions that are too large and the test fails due + -- to running out of memory. + frequency + [ (10, arbitraryConst) + + , (5, apply1 <$> arbitraryNumOp1 <*> arbitraryNumExpr) + + , (2, apply2 <$> arbitraryNumOp2 <*> arbitraryNumExpr <*> arbitraryNumExpr) + + , (2, apply3 <$> arbitraryITEOp3 + <*> arbitraryBoolExpr + <*> arbitraryNumExpr + <*> arbitraryNumExpr) + ] + +-- | An arbitrary floating point expression, paired with its expected meaning. +arbitraryFloatingExpr :: (Arbitrary t, Typed t, Floating t, Eq t) + => Gen (Stream t, [t]) +arbitraryFloatingExpr = + -- We use frequency instead of oneof because the random expression generator + -- seems to generate expressions that are too large and the test fails due + -- to running out of memory. + frequency + [ (10, arbitraryConst) + + , (5, apply1 <$> arbitraryFloatingOp1 <*> arbitraryFloatingExpr) + + , (5, apply1 <$> arbitraryNumOp1 <*> arbitraryFloatingExpr) + + , (2, apply2 <$> arbitraryFloatingOp2 + <*> arbitraryFloatingExpr + <*> arbitraryFloatingExpr) + + , (2, apply2 <$> arbitraryNumOp2 + <*> arbitraryFloatingExpr + <*> arbitraryFloatingExpr) + + , (1, apply3 <$> arbitraryITEOp3 + <*> arbitraryBoolExpr + <*> arbitraryFloatingExpr + <*> arbitraryFloatingExpr) + ] + +-- | An arbitrary realfrac expression, paired with its expected meaning. +arbitraryRealFracExpr :: (Arbitrary t, Typed t, RealFrac t) + => Gen (Stream t, [t]) +arbitraryRealFracExpr = + -- We use frequency instead of oneof because the random expression generator + -- seems to generate expressions that are too large and the test fails due + -- to running out of memory. + frequency + [ (10, arbitraryConst) + + , (2, apply1 <$> arbitraryRealFracOp1 <*> arbitraryRealFracExpr) + + , (5, apply1 <$> arbitraryNumOp1 <*> arbitraryRealFracExpr) + + , (1, apply2 <$> arbitraryNumOp2 + <*> arbitraryRealFracExpr + <*> arbitraryRealFracExpr) + + , (1, apply3 <$> arbitraryITEOp3 + <*> arbitraryBoolExpr + <*> arbitraryRealFracExpr + <*> arbitraryRealFracExpr) + ] + +-- | An arbitrary realfloat expression, paired with its expected meaning. +arbitraryRealFloatExpr :: (Arbitrary t, Typed t, RealFloat t) + => Gen (Stream t, [t]) +arbitraryRealFloatExpr = + -- We use frequency instead of oneof because the random expression generator + -- seems to generate expressions that are too large and the test fails due + -- to running out of memory. + frequency + [ (10, arbitraryConst) + + , (2, apply1 <$> arbitraryNumOp1 <*> arbitraryRealFloatExpr) + + , (5, apply2 <$> arbitraryRealFloatOp2 + <*> arbitraryRealFloatExpr + <*> arbitraryRealFloatExpr) + + , (1, apply2 <$> arbitraryNumOp2 + <*> arbitraryRealFloatExpr + <*> arbitraryRealFloatExpr) + + , (1, apply3 <$> arbitraryITEOp3 + <*> arbitraryBoolExpr + <*> arbitraryRealFloatExpr + <*> arbitraryRealFloatExpr) + ] + +-- | An arbitrary fractional expression, paired with its expected meaning. +-- +-- We add the constraint Eq because we sometimes need to make sure numbers are +-- not zero. +arbitraryFractionalExpr :: (Arbitrary t, Typed t, Fractional t, Eq t) + => Gen (Stream t, [t]) +arbitraryFractionalExpr = + -- We use frequency instead of oneof because the random expression generator + -- seems to generate expressions that are too large and the test fails due + -- to running out of memory. + frequency + [ (10, arbitraryConst) + + , (5, apply1 <$> arbitraryFractionalOp1 <*> arbitraryFractionalExpr) + + , (5, apply1 <$> arbitraryNumOp1 <*> arbitraryFractionalExpr) + + , (2, apply2 <$> arbitraryFractionalOp2 + <*> arbitraryFractionalExpr + <*> arbitraryFractionalExprNonZero) + + , (1, apply3 <$> arbitraryITEOp3 + <*> arbitraryBoolExpr + <*> arbitraryFractionalExpr + <*> arbitraryFractionalExpr) + ] + where + + -- Generator for fractional expressions that are never zero. + -- + -- The list is infinite, so this generator checks up to maxTraceLength + -- elements. + arbitraryFractionalExprNonZero = arbitraryFractionalExpr + `suchThat` (notElem 0 . take maxTraceLength . snd) + +-- | An arbitrary integral expression, paired with its expected meaning. +-- +-- We add the constraint Eq because we sometimes need to make sure numbers are +-- not zero. +arbitraryIntegralExpr :: (Arbitrary t, Typed t, Integral t, Eq t) + => Gen (Stream t, [t]) +arbitraryIntegralExpr = + -- We use frequency instead of oneof because the random expression generator + -- seems to generate expressions that are too large and the test fails due + -- to running out of memory. + frequency + [ (10, arbitraryConst) + + , (5, apply1 <$> arbitraryNumOp1 <*> arbitraryIntegralExpr) + + , (2, apply2 <$> arbitraryNumOp2 + <*> arbitraryIntegralExpr + <*> arbitraryIntegralExpr) + + , (2, apply2 <$> arbitraryIntegralOp2 + <*> arbitraryIntegralExpr + <*> arbitraryIntegralExprNonZero) + + , (1, apply3 <$> arbitraryITEOp3 + <*> arbitraryBoolExpr + <*> arbitraryIntegralExpr + <*> arbitraryIntegralExpr) + ] + where + + -- Generator for integral expressions that are never zero. + -- + -- The list is infinite, so this generator checks up to maxTraceLength + -- elements. + arbitraryIntegralExprNonZero = arbitraryIntegralExpr + `suchThat` (notElem 0 . take maxTraceLength . snd) + +-- | An arbitrary Bits expression, paired with its expected meaning. +arbitraryBitsExpr :: (Arbitrary t, Typed t, Bits t) + => Gen (Stream t, [t]) +arbitraryBitsExpr = + -- We use frequency instead of oneof because the random expression generator + -- seems to generate expressions that are too large and the test fails due + -- to running out of memory. + frequency + [ (10, arbitraryConst) + + , (5, apply1 <$> arbitraryBitsOp1 <*> arbitraryBitsExpr) + + , (2, apply2 <$> arbitraryBitsOp2 + <*> arbitraryBitsExpr + <*> arbitraryBitsExpr) + + , (2, apply3 <$> arbitraryITEOp3 + <*> arbitraryBoolExpr + <*> arbitraryBitsExpr <*> arbitraryBitsExpr) + ] + +-- | An arbitrary expression for types that are instances of Bits and Integral, +-- paired with its expected meaning. +arbitraryBitsIntegralExpr :: (Arbitrary t, Typed t, Bits t, Integral t) + => Gen (Stream t, [t]) +arbitraryBitsIntegralExpr = + -- We use frequency instead of oneof because the random expression + -- generator seems to generate expressions that are too large and the + -- test fails due to running out of memory. + frequency + [ (10, arbitraryConst) + + , (2, apply1 <$> arbitraryNumOp1 <*> arbitraryBitsIntegralExpr) + + , (1, apply2 <$> arbitraryNumOp2 + <*> arbitraryBitsIntegralExpr + <*> arbitraryBitsIntegralExpr) + + , (5, apply2 <$> arbitraryBitsIntegralOp2 + <*> arbitraryBitsIntegralExpr + <*> arbitraryBitsIntegralExprConstPos) + + , (1, apply3 <$> arbitraryITEOp3 + <*> arbitraryBoolExpr + <*> arbitraryBitsIntegralExpr + <*> arbitraryBitsIntegralExpr) + ] + where + + -- Generator for constant bit integral expressions that, when converted to + -- type 't', result in a positive number. We use a constant generator, as + -- opposed to a generator based on the more comprehensive + -- arbitraryBitsIntegralExpr, because the latter runs out of memory easily + -- when nested and filtered with suchThat. + arbitraryBitsIntegralExprConstPos = + (\v -> (Copilot.constant v, repeat v)) <$> intThatFits + where + -- In this context: + -- + -- intThatFits :: Gen t + intThatFits = + suchThat arbitrary ((> 0) . (\x -> (fromIntegral x) :: Int)) + +-- ** Operators + +-- *** Op 1 + +-- | Generator for arbitrary boolean operators with arity 1, paired with their +-- expected meaning. +arbitraryBoolOp1 :: Gen (Stream Bool -> Stream Bool, [Bool] -> [Bool]) +arbitraryBoolOp1 = elements + [ (Copilot.not, fmap not) + ] + +-- | Generator for arbitrary numeric operators with arity 1, paired with their +-- expected meaning. +arbitraryNumOp1 :: (Typed t, Num t, Eq t) + => Gen (Stream t -> Stream t, [t] -> [t]) +arbitraryNumOp1 = elements + [ (abs, fmap abs) + , (signum, fmap signum) + ] + +-- | Generator for arbitrary floating point operators with arity 1, paired with +-- their expected meaning. +arbitraryFloatingOp1 :: (Typed t, Floating t, Eq t) + => Gen (Stream t -> Stream t, [t] -> [t]) +arbitraryFloatingOp1 = elements + [ (exp, fmap exp) + , (sqrt, fmap sqrt) + , (log, fmap log) + , (sin, fmap sin) + , (tan, fmap tan) + , (cos, fmap cos) + , (asin, fmap asin) + , (atan, fmap atan) + , (acos, fmap acos) + , (sinh, fmap sinh) + , (tanh, fmap tanh) + , (cosh, fmap cosh) + , (asinh, fmap asinh) + , (atanh, fmap atanh) + , (acosh, fmap acosh) + ] + +-- | Generator for arbitrary realfrac operators with arity 1, paired with their +-- expected meaning. +arbitraryRealFracOp1 :: (Typed t, RealFrac t) + => Gen (Stream t -> Stream t, [t] -> [t]) +arbitraryRealFracOp1 = elements + [ (Copilot.ceiling, fmap (fromIntegral . idI . ceiling)) + , (Copilot.floor, fmap (fromIntegral . idI . floor)) + ] + where + -- Auxiliary function to help the compiler determine which integral type + -- the result of ceiling must be converted to. An Integer ensures that the + -- result fits and there is no loss of precision due to the intermediate + -- casting. + idI :: Integer -> Integer + idI = id + +-- | Generator for arbitrary fractional operators with arity 1, paired with +-- their expected meaning. +arbitraryFractionalOp1 :: (Typed t, Fractional t, Eq t) + => Gen (Stream t -> Stream t, [t] -> [t]) +arbitraryFractionalOp1 = elements + [ (recip, fmap recip) + ] + +-- | Generator for arbitrary bitwise operators with arity 1, paired with their +-- expected meaning. +arbitraryBitsOp1 :: (Typed t, Bits t) + => Gen (Stream t -> Stream t, [t] -> [t]) +arbitraryBitsOp1 = elements + [ (complement, fmap complement) + ] + +-- *** Op 2 + +-- | Generator for arbitrary boolean operators with arity 2, paired with their +-- expected meaning. +arbitraryBoolOp2 :: Gen ( Stream Bool -> Stream Bool -> Stream Bool + , [Bool] -> [Bool] -> [Bool] + ) +arbitraryBoolOp2 = elements + [ ((Copilot.&&), zipWith (&&)) + , ((Copilot.||), zipWith (||)) + , ((Copilot.==>), zipWith (\x y -> not x || y)) + , ((Copilot.xor), zipWith (\x y -> (x || y) && not (x && y))) + ] + +-- | Generator for arbitrary numeric operators with arity 2, paired with their +-- expected meaning. +arbitraryNumOp2 :: (Typed t, Num t, Eq t) + => Gen (Stream t -> Stream t -> Stream t, [t] -> [t] -> [t]) +arbitraryNumOp2 = elements + [ ((+), zipWith (+)) + , ((-), zipWith (-)) + , ((*), zipWith (*)) + ] + +-- | Generator for arbitrary integral operators with arity 2, paired with their +-- expected meaning. +arbitraryIntegralOp2 :: (Typed t, Integral t) + => Gen ( Stream t -> Stream t -> Stream t + , [t] -> [t] -> [t] + ) +arbitraryIntegralOp2 = elements + [ (Copilot.mod, zipWith mod) + , (Copilot.div, zipWith quot) + ] + +-- | Generator for arbitrary fractional operators with arity 2, paired with +-- their expected meaning. +arbitraryFractionalOp2 :: (Typed t, Fractional t, Eq t) + => Gen ( Stream t -> Stream t -> Stream t + , [t] -> [t] -> [t] + ) +arbitraryFractionalOp2 = elements + [ ((/), zipWith (/)) + ] + +-- | Generator for arbitrary floating point operators with arity 2, paired with +-- their expected meaning. +arbitraryFloatingOp2 :: (Typed t, Floating t, Eq t) + => Gen ( Stream t -> Stream t -> Stream t + , [t] -> [t] -> [t] + ) +arbitraryFloatingOp2 = elements + [ ((**), zipWith (**)) + , (logBase, zipWith logBase) + ] + +-- | Generator for arbitrary floating point operators with arity 2, paired with +-- their expected meaning. +arbitraryRealFloatOp2 :: (Typed t, RealFloat t) + => Gen ( Stream t -> Stream t -> Stream t + , [t] -> [t] -> [t] + ) +arbitraryRealFloatOp2 = elements + [ (Copilot.atan2, zipWith atan2) + ] + +-- | Generator for arbitrary equality operators with arity 2, paired with their +-- expected meaning. +arbitraryEqOp2 :: (Typed t, Eq t) + => Gen ( Stream t -> Stream t -> Stream Bool + , [t] -> [t] -> [Bool] + ) +arbitraryEqOp2 = elements + [ ((Copilot.==), zipWith (==)) + , ((Copilot./=), zipWith (/=)) + ] + +-- | Generator for arbitrary ordering operators with arity 2, paired with their +-- expected meaning. +arbitraryOrdOp2 :: (Typed t, Ord t) + => Gen ( Stream t -> Stream t -> Stream Bool + , [t] -> [t] -> [Bool] + ) +arbitraryOrdOp2 = elements + [ ((Copilot.<=), zipWith (<=)) + , ((Copilot.<), zipWith (<)) + , ((Copilot.>=), zipWith (>=)) + , ((Copilot.>), zipWith (>)) + ] + +-- | Generator for arbitrary bitwise operators with arity 2, paired with their +-- expected meaning. +arbitraryBitsOp2 :: (Typed t, Bits t) + => Gen (Stream t -> Stream t -> Stream t, [t] -> [t] -> [t]) +arbitraryBitsOp2 = elements + [ ((.&.), zipWith (.&.)) + , ((.|.), zipWith (.|.)) + , (xor, zipWith xor) + ] + +-- | Generator for arbitrary bit shifting operators with arity 2, paired with +-- their expected meaning. +-- +-- This generator is a bit more strict in its type signature than the +-- underlying bit-shifting operators being tested, since it enforces both the +-- value being manipulated and the value that indicates how much to shift by to +-- have the same type. +arbitraryBitsIntegralOp2 :: (Typed t, Bits t, Integral t) + => Gen ( Stream t -> Stream t -> Stream t + , [t] -> [t] -> [t] + ) +arbitraryBitsIntegralOp2 = elements + [ ((Copilot..<<.), zipWith (\x y -> shiftL x (fromIntegral y))) + , ((Copilot..>>.), zipWith (\x y -> shiftR x (fromIntegral y))) + ] + +-- *** Op 3 + +-- | Generator for if-then-else operator (with arity 3), paired with its +-- expected meaning. +-- +-- Although this is constant and there is nothing arbitrary, we use the same +-- structure and naming convention as with others for simplicity. +arbitraryITEOp3 :: (Arbitrary t, Typed t) + => Gen ( Stream Bool -> Stream t -> Stream t -> Stream t + , [Bool] -> [t] -> [t] -> [t] + ) +arbitraryITEOp3 = return + (Copilot.mux, zipWith3 (\x y z -> if x then y else z)) + +-- * Semantics + +-- | Type that pairs an expression with its meaning as an infinite stream. +type Semantics t = (Stream t, [t]) + +-- | A phantom semantics pair is an existential type that encloses an +-- expression and its expected meaning as an infinite list of values. +-- +-- It is needed by the arbitrary expression generator, to create a +-- heterogeneous list. +data SemanticsP = forall t + . (Typeable t, Read t, Eq t, Show t, Typed t, Arbitrary t) + => SemanticsP + { semanticsPair :: (Stream t, [t]) + } + +-- | Show function for test triplets that limits the accompanying list +-- to a certain length. +semanticsShowK :: Int -> SemanticsP -> String +semanticsShowK steps (SemanticsP (expr, exprList)) = + show ("Cannot show stream", take steps exprList) + +-- | Check that the expression in the semantics pair is evaluated to the given +-- list, up to a number of steps. +-- +-- Some operations will overflow and return NaN. Because comparing any NaN +-- will, as per IEEE 754, always fail (i.e., return False), we handle that +-- specific case by stating that the test succeeds if any expected values +-- is NaN. +checkSemanticsP :: Int -> [a] -> SemanticsP -> IO Bool +checkSemanticsP steps _streams (SemanticsP (expr, exprList)) = do + -- Spec with just one observer of one expression. + -- + -- Because SemanticsP is an existential type, we need to help GHC figure + -- out the type of spec. + let spec :: Spec + spec = observer testObserverName expr + + -- Reified stream (low-level) + llSpec <- reify spec + + let trace = eval Haskell steps llSpec + + -- Limit expectation to the number of evaluation steps. + let expectation = take steps exprList + + -- Obtain the results by looking up the observer in the spec + -- and parsing the results into Haskell values. + let resultValues = fmap readResult results + results = lookupWithDefault testObserverName [] + $ interpObservers trace + + return $ any isNaN' expectation || resultValues == expectation + + where + + -- Fixed name for the observer. Used to obtain the result from the + -- trace. It should be the only observer in the trace. + testObserverName :: String + testObserverName = "res" + + -- | Is NaN with Eq requirement only. + isNaN' :: Eq a => a -> Bool + isNaN' x = x /= x + +-- * Auxiliary + +-- | Read a Haskell value from the output of the evaluator. +readResult :: Read a => String -> a +readResult = read . readResult' + where + readResult' :: String -> String + readResult' "false" = "False" + readResult' "true" = "True" + readResult' s = s + +-- | Variant of 'lookup' with an additional default value returned when the key +-- provided is not found in the map. +lookupWithDefault :: Ord k => k -> v -> [(k, v)] -> v +lookupWithDefault k def = fromMaybe def . lookup k diff --git a/copilot-language/tests/Test/Extra.hs b/copilot-language/tests/Test/Extra.hs new file mode 100644 index 000000000..f10d784c4 --- /dev/null +++ b/copilot-language/tests/Test/Extra.hs @@ -0,0 +1,31 @@ +-- | Auxiliary testing helper functions. +module Test.Extra where + +-- External imports +import Control.Arrow ((***)) + +-- * Function application + +-- | Apply a tuple with two functions to a tuple of arguments. +apply1 :: (a1 -> b1, a2 -> b2) -- ^ Pair with functions + -> (a1, a2) -- ^ Pair with arguments + -> (b1, b2) -- ^ Pair with results +apply1 = uncurry (***) + +-- | Apply a tuple with two functions on two arguments to their tupled +-- arguments. +apply2 :: (a1 -> b1 -> c1, a2 -> b2 -> c2) -- ^ Pair with functions + -> (a1, a2) -- ^ Pair with first arguments + -> (b1, b2) -- ^ Pair with second arguments + -> (c1, c2) -- ^ Pair with results +apply2 fs = apply1 . apply1 fs + +-- | Apply a tuple with two functions on three arguments to their tupled +-- arguments. +apply3 :: (a1 -> b1 -> c1 -> d1, a2 -> b2 -> c2 -> d2) + -- ^ Pair with functions + -> (a1, a2) -- ^ Pair with first arguments + -> (b1, b2) -- ^ Pair with second arguments + -> (c1, c2) -- ^ Pair with third arguments + -> (d1, d2) -- ^ Pair with results +apply3 fs = apply2 . apply1 fs diff --git a/copilot-libraries/CHANGELOG b/copilot-libraries/CHANGELOG index 8d86bb440..f84c75a48 100644 --- a/copilot-libraries/CHANGELOG +++ b/copilot-libraries/CHANGELOG @@ -1,4 +1,117 @@ -2021-10-19 +2026-11-07 + * Version bump (4.8.2). (#792) + * Add random stream generation module. (#766) + +2026-09-07 + * Version bump (4.8.1). (#760) + +2026-07-07 + * Version bump (4.8). (#745) + +2026-05-07 + * Version bump (4.7.1). (#730) + * Add stream analysis module. (#726) + * Add state machine module. (#728) + +2026-03-07 + * Version bump (4.7). (#714) + +2026-01-07 + * Version bump (4.6.1). (#705) + * Relax version constraint on containers. (#603) + +2025-11-07 + * Version bump (4.6). (#679) + +2025-09-07 + * Version bump (4.5.1). (#666) + +2025-07-07 + * Version bump (4.5). (#642) + +2025-05-07 + * Version bump (4.4). (#618) + +2025-03-07 + * Version bump (4.3). (#604) + * Remove deprecated function Copilot.Library.Utils.(!!). (#599) + +2025-01-07 + * Version bump (4.2). (#577) + * Bump upper version constraint on containers. (#570) + +2024-11-07 + * Version bump (4.1). (#561) + * Standardize changelog format. (#550) + +2024-09-07 + * Version bump (4.0). (#532) + * Rename operator to avoid name clash. (#36) + +2024-07-07 + * Version bump (3.20). (#522) + +2024-05-07 + * Version bump (3.19.1). (#512) + +2024-03-07 + * Version bump (3.19). (#504) + +2024-01-07 + * Version bump (3.18.1). (#493) + +2024-01-07 + * Version bump (3.18). (#487) + * Introduce testing infrastructure for Copilot.Library. (#475) + * Replace uses of forall with forAll. (#470) + +2023-11-07 + * Version bump (3.17). (#466) + +2023-09-07 + * Version bump (3.16.1). (#455) + * Fix semantics of since in Copilot.Library.PTLTL. (#443) + * Prevent the majority function from generating unused local variables. + (#408) + +2023-07-07 + * Version bump (3.16). (#448) + +2023-05-07 + * Version bump (3.15). (#438) + +2023-03-07 + * Version bump (3.14). (#422) + +2023-01-07 + * Version bump (3.13). (#406) + +2022-11-07 + * Version bump (3.12). (#389) + +2022-09-07 + * Version bump (3.11). (#376) + +2022-07-07 + * Version bump (3.10). (#356) + * Remove unnecessary dependencies from Cabal package. (#327) + * Remove duplicated compiler option. (#328) + * Relax version bounds of dependencies. (#335) + * Update 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) + +2021-11-07 + * Version bump (3.6). (#264) * Improve documentation of LTL module. (#131) * Fix outdated/broken links. (#252) @@ -20,8 +133,8 @@ * Completed the documentation. (#127) 2020-12-06 - * Version bump (3.2). - * Update description, bug-reports, homepage fields in cabal file (#129). + * Version bump (3.2). (#65) + * Update description, bug-reports, homepage fields in cabal file. (#129) -2019-11-22 Ivan Perez - * Version bump (3.1). +2019-11-22 + * Version bump (3.1). (#46) diff --git a/copilot-libraries/copilot-libraries.cabal b/copilot-libraries/copilot-libraries.cabal index 8a0f652d0..6e18aba84 100644 --- a/copilot-libraries/copilot-libraries.cabal +++ b/copilot-libraries/copilot-libraries.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: copilot-libraries -version: 3.5 +version: 4.8.2 synopsis: Libraries for the Copilot language. description: Libraries for the Copilot language. @@ -24,10 +24,12 @@ category: Language, Embedded build-type: Simple extra-source-files: README.md, CHANGELOG +x-curation: uncurated + source-repository head type: git - location: git://github.com/Copilot-Language/copilot.git - subdir: lib/copilot-libraries + location: https://github.com/Copilot-Language/copilot.git + subdir: copilot-libraries library default-language: Haskell2010 @@ -36,19 +38,20 @@ library build-depends: base >= 4.9 && < 5 - , array >= 0.5 && < 0.6 - , containers >= 0.4 && < 0.7 - , data-reify >= 0.6 && < 0.7 - , mtl >= 2.0 && < 2.3 + , containers >= 0.4 && < 0.9 + , mtl >= 2.0 && < 2.4 , parsec >= 2.0 && < 3.2 - , copilot-language >= 3.5 && < 3.6 + , copilot-language >= 4.8.2 && < 4.9 exposed-modules: - Copilot.Library.Libraries + Copilot.Library.Analysis + , Copilot.Library.Libraries , Copilot.Library.Clocks , Copilot.Library.LTL , Copilot.Library.PTLTL + , Copilot.Library.StateMachines , Copilot.Library.Statistics + , Copilot.Library.Random , Copilot.Library.RegExp , Copilot.Library.Utils , Copilot.Library.Voting @@ -56,5 +59,35 @@ library , Copilot.Library.MTL ghc-options: - -fwarn-tabs + -Wall + +test-suite unit-tests + type: + exitcode-stdio-1.0 + + main-is: + Main.hs + + other-modules: + Test.Copilot.Library.PTLTL + Test.Extra + + build-depends: + base + , QuickCheck + , test-framework + , test-framework-quickcheck2 + + , copilot-interpreter + , copilot-language + , copilot-libraries + , copilot-theorem + + hs-source-dirs: + tests + + default-language: + Haskell2010 + + ghc-options: -Wall diff --git a/copilot-libraries/src/Copilot/Library/Analysis.hs b/copilot-libraries/src/Copilot/Library/Analysis.hs new file mode 100644 index 000000000..240addd7c --- /dev/null +++ b/copilot-libraries/src/Copilot/Library/Analysis.hs @@ -0,0 +1,23 @@ +-- | Formally analyze streams. +module Copilot.Library.Analysis + ( triviallyTrue + , triviallyFalse + ) + where + +-- External imports. +import Prelude hiding (not) + +-- Internal imports. +import Copilot.Language (Stream, forAll, not) +import Copilot.Language.Spec (Prop, Universal) + +-- | Property that captures whether a stream is trivially true, meaning that +-- there is no way to make it false. +triviallyTrue :: Stream Bool -> Prop Universal +triviallyTrue = forAll + +-- | Property that captures whether a stream is trivially false, meaning that +-- there is no way to make it true. +triviallyFalse :: Stream Bool -> Prop Universal +triviallyFalse = triviallyTrue . not diff --git a/copilot-libraries/src/Copilot/Library/Clocks.hs b/copilot-libraries/src/Copilot/Library/Clocks.hs index f888ec6db..337e311ef 100644 --- a/copilot-libraries/src/Copilot/Library/Clocks.hs +++ b/copilot-libraries/src/Copilot/Library/Clocks.hs @@ -1,4 +1,4 @@ --- | +-- | -- Module: Clocks -- Description: Clocks based on a base period and phase -- Copyright: (c) 2011 National Institute of Aerospace / Galois, Inc. @@ -57,18 +57,18 @@ clk :: ( Integral a ) => -> Phase a -- ^ Phase @m@ of clock -> Stream Bool -- ^ Clock signal - 'True' on clock ticks, 'False' otherwise clk ( Period period' ) ( Phase phase' ) = clk' - where clk' = if period' P.< 1 then - badUsage ( "clk: clock period must be 1 or greater" ) - else if phase' P.< 0 then - badUsage ( "clk: clock phase must be 0 or greater" ) - else if phase' P.>= period' then - badUsage ( "clk: clock phase must be less than period") - else replicate ( fromIntegral phase' ) False - P.++ True : replicate - ( fromIntegral - $ period' P.- phase' P.- 1 ) False - ++ clk' - + where + clk' = if period' P.< 1 then + badUsage ( "clk: clock period must be 1 or greater" ) + else if phase' P.< 0 then + badUsage ( "clk: clock phase must be 0 or greater" ) + else if phase' P.>= period' then + badUsage ( "clk: clock phase must be less than period") + else replicate ( fromIntegral phase' ) False + P.++ True : replicate + ( fromIntegral + $ period' P.- phase' P.- 1 ) False + ++ clk' -- | This follows the same convention as 'clk', but uses a counter variable of -- integral type /a/ rather than an array. @@ -85,7 +85,7 @@ clk1 ( Period period' ) ( Phase phase' ) = badUsage ( "clk1: clock phase must be less than period") else let counter = [ P.fromInteger 0 ] - ++ mux ( counter /= ( constant $ + ++ mux ( counter /= ( constant $ period' P.- 1 ) ) ( counter P.+ 1 ) ( 0 ) diff --git a/copilot-libraries/src/Copilot/Library/LTL.hs b/copilot-libraries/src/Copilot/Library/LTL.hs index 1b4c2a18a..c8e613103 100644 --- a/copilot-libraries/src/Copilot/Library/LTL.hs +++ b/copilot-libraries/src/Copilot/Library/LTL.hs @@ -1,4 +1,4 @@ --- | +-- | -- Module: LTL -- Description: Bounded Linear Temporal Logic (LTL) operators -- Copyright: (c) 2011 National Institute of Aerospace / Galois, Inc. @@ -45,7 +45,6 @@ module Copilot.Library.LTL import Copilot.Language import Copilot.Library.Utils - -- | Property @s@ holds at the next period. For example: -- -- @ @@ -57,7 +56,6 @@ import Copilot.Library.Utils next :: Stream Bool -> Stream Bool next = drop ( 1 :: Int ) - -- | Property @s@ holds for the next @n@ periods. We require @n >= 0@. If @n == -- 0@, then @s@ holds in the current period, e.g., if @p = always 2 s@, then we -- have the following relationship between the streams generated: @@ -72,7 +70,6 @@ next = drop ( 1 :: Int ) always :: ( Integral a ) => a -> Stream Bool -> Stream Bool always n = nfoldl1 ( fromIntegral n + 1 ) (&&) - -- | Property @s@ holds at some period in the next @n@ periods. If @n == 0@, -- then @s@ holds in the current period. We require @n >= 0@. E.g., if @p = -- eventually 2 s@, then we have the following relationship between the streams @@ -90,7 +87,6 @@ eventually :: ( Integral a ) => -> Stream Bool eventually n = nfoldl1 ( fromIntegral n + 1 ) (||) - -- | @until n s0 s1@ means that @eventually n s1@, and up until at least the -- period before @s1@ holds, @s0@ continuously holds. -- @@ -99,11 +95,11 @@ eventually n = nfoldl1 ( fromIntegral n + 1 ) (||) until :: ( Integral a ) => a -> Stream Bool -> Stream Bool -> Stream Bool until 0 _ s1 = s1 until n s0 s1 = foldl (||) s1 v0 - where n' = fromIntegral n - v0 = [ always ( i :: Int ) s0 && drop ( i + 1 ) s1 - | i <- [ 0 .. n' - 1 ] - ] - + where + n' = fromIntegral n + v0 = [ always ( i :: Int ) s0 && drop ( i + 1 ) s1 + | i <- [ 0 .. n' - 1 ] + ] -- | @release n s0 s1@ means that either @always n s1@, or @s1@ holds up to and -- including the period at which @s0@ becomes true. @@ -113,7 +109,8 @@ until n s0 s1 = foldl (||) s1 v0 release :: ( Integral a ) => a -> Stream Bool -> Stream Bool -> Stream Bool release 0 _ s1 = s1 release n s0 s1 = always n s1 || foldl1 (||) v0 - where n' = fromIntegral n - v0 = [ always ( i :: Int ) s1 && drop i s0 - | i <- [ 0 .. n' - 1 ] - ] + where + n' = fromIntegral n + v0 = [ always ( i :: Int ) s1 && drop i s0 + | i <- [ 0 .. n' - 1 ] + ] diff --git a/copilot-libraries/src/Copilot/Library/Libraries.hs b/copilot-libraries/src/Copilot/Library/Libraries.hs index f6cd58a62..f378063bb 100644 --- a/copilot-libraries/src/Copilot/Library/Libraries.hs +++ b/copilot-libraries/src/Copilot/Library/Libraries.hs @@ -26,4 +26,3 @@ import Copilot.Library.RegExp import Copilot.Library.Utils import Copilot.Library.Voting import Copilot.Library.Stacks - diff --git a/copilot-libraries/src/Copilot/Library/PTLTL.hs b/copilot-libraries/src/Copilot/Library/PTLTL.hs index 1fae57473..de07eef90 100644 --- a/copilot-libraries/src/Copilot/Library/PTLTL.hs +++ b/copilot-libraries/src/Copilot/Library/PTLTL.hs @@ -1,4 +1,4 @@ --- | +-- | -- Module: PTLTL -- Description: Past-Time Linear-Temporal Logic -- Copyright: (c) 2011 National Institute of Aerospace / Galois, Inc. @@ -27,20 +27,18 @@ import Copilot.Language previous :: Stream Bool -> Stream Bool previous s = [ False ] ++ s - -- | Has @s@ always held (up to and including the current state)? alwaysBeen :: Stream Bool -> Stream Bool alwaysBeen s = s && tmp - where tmp = [ True ] ++ s && tmp - + where + tmp = [ True ] ++ s && tmp -- | Did @s@ hold at some time in the past (including the current state)? eventuallyPrev :: Stream Bool -> Stream Bool eventuallyPrev s = s || tmp - where tmp = [ False ] ++ s || tmp - + where + tmp = [ False ] ++ s || tmp --- | Once @s2@ holds, in the following state (period), does @s1@ continuously hold? -since :: Stream Bool -> Stream Bool -> Stream Bool -since s1 s2 = alwaysBeen ( tmp ==> s1 ) - where tmp = eventuallyPrev $ [ False ] ++ s2 +-- | Is there a time when @s2@ holds and after which @s1@ continuously holds? +since :: Stream Bool -> Stream Bool -> Stream Bool +since s1 s2 = eventuallyPrev (s2 ==> (alwaysBeen s1)) diff --git a/copilot-libraries/src/Copilot/Library/Random.hs b/copilot-libraries/src/Copilot/Library/Random.hs new file mode 100644 index 000000000..d4828e12b --- /dev/null +++ b/copilot-libraries/src/Copilot/Library/Random.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +-- | +-- Basic pseudo-random number generation. +-- +-- Information on performance of a selection of pseudo-random number generation +-- algorithms, including those implemented below, can be found at: +-- https://prng.di.unimi.it/ +-- +-- Important: these pseudo-random number generators are NOT cryptographically +-- secure generators. +module Copilot.Library.Random + ( randomW32 + , randomW64 + , boundedRandomIntegral + , proportionalRandomBool + , weightedRandomSelection + ) + where + +-- External imports +import Copilot.Language (Array, Stream, Typed, Word32, Word64, arrayElems, + constant, mod, mux, (!), (++), (.<<.), (.>>.), (.^.), + (<), (<=)) +import GHC.TypeLits (KnownNat, type (<=)) +import Prelude hiding (mod, (++), (<), (<=)) + +-- | Given two Word32 seeds, produce a pseudo-random stream of Word32 numbers, +-- which has a period of 2^32 - 1. Neither of the seeds should be zero, since +-- the underlying randomization algorithm maps zero to itself. +-- +-- This function uses an Xorshift+ algorithm. +randomW32 :: Word32 -> Word32 -> Stream Word32 +randomW32 0 _ = error "randomW32: seed cannot be zero." +randomW32 _ 0 = error "randomW32: seed cannot be zero." +randomW32 seed1 seed2 = s1 + s2 + + where + + s1 :: Stream Word32 + s1 = [seed1] ++ (xorshift32 s1) + + s2 :: Stream Word32 + s2 = [seed2] ++ (xorshift32 s2) + + -- This is a simple implementation of an Xorshift algorithm + xorshift32 :: Stream Word32 -> Stream Word32 + xorshift32 x1 = x4 -- Note: 0 maps to itself with this + where + x4 = x3 .^. (x3 .<<. (5 :: Stream Word32)) + x3 = x2 .^. (x2 .>>. (17 :: Stream Word32)) + x2 = x1 .^. (x1 .<<. (13 :: Stream Word32)) + +-- | Given two Word64 seeds, produce a pseudo-random stream of Word64 numbers, +-- which has a period of 2^128 - 1. Neither of the seeds should be zero, as +-- doing so will negatively impact the quality of the randomness. +-- +-- This function uses an Xorshiftrplus algorithm. +randomW64 :: Word64 -> Word64 -> Stream Word64 +randomW64 0 _ = error "randomW64: seed cannot be zero." +randomW64 _ 0 = error "randomW64: seed cannot be zero." +randomW64 seed1 seed2 = x + + where + + s0 :: Stream Word64 + s0 = [seed1] ++ s1 + + s1 :: Stream Word64 + s1 = [seed2] ++ (x + s1) + + x :: Stream Word64 + x = xorshiftr128plus s0 s1 + + xorshiftr128plus :: Stream Word64 -> Stream Word64 -> Stream Word64 + xorshiftr128plus x1 y = x4 + where + x4 = x3 .^. y + x3 = x2 .^. (x2 .>>. (17 :: Stream Word64)) + x2 = x1 .^. (x1 .<<. (23 :: Stream Word64)) + +-- | Given a stream of random integral numbers, a minimum value, and a maximum +-- value, produce a stream of random values greater than or equal to the +-- minimum and less than the maximum value, i.e., [@mN@, @mX@). +boundedRandomIntegral :: (Typed a, Integral a) + => Stream a -> a -> a -> Stream a +boundedRandomIntegral gen mN mX = (gen `mod` constant (mX - mN)) + constant mN + +-- | Given a stream of random integral numbers and two integers defining the +-- numerator and denominator of a rational probability, produce a boolean +-- stream that is randomly @True@ with the given probability. That is to say, +-- given a numerator @n@ and denominator @d@, then, over a sufficiently large +-- sample size, the resulting stream @s@ is @True@ @n@ out of @d@ times. +proportionalRandomBool :: (Typed a, Integral a) + => Stream a -> a -> a -> Stream Bool +proportionalRandomBool gen n d = (gen `mod` constant d) < constant n + +-- | Given a stream of random integral numbers, an array of values, and an +-- equal length array of weights, produce a stream of random values from the +-- given array with probabilities proportional to the given weights. +weightedRandomSelection :: forall a b s + . (KnownNat s, s <= MaxWord32, Typed a, Typed b, + Integral a, Bounded a) + => Stream a -> Array s b -> Array s a -> Stream b +weightedRandomSelection gen values weights + | overflow + = error "weightedRandomSelection: sum of weights overflows type" + + | signedType + = error "weightedRandomSelection: type of weights array must be unsigned" + + | otherwise + = constant values ! idx + + where + + -- Check if cumulativeSum decreases at any point. For unsigned integral + -- types, a decreasing element in this cumulative sequence corresponds to + -- an overflow. + overflow = or (zipWith (>) cumulativeSum (drop 1 cumulativeSum)) + + signedType = 0 > (minBound :: a) + + idx :: Stream Word32 + idx = countLeq cumulativeSum (gen `mod` constant totalSum) + + countLeq :: [a] -> Stream a -> Stream Word32 + countLeq xs v = sum [ mux (constant x <= v) 1 0 | x <- xs ] + -- ^ get number of elements in @xs@ less than or equal to @v@. + -- For non-decreasing @xs@, this is equal to the index of the first + -- element greater than @v@. + + cumulativeSum :: [a] + cumulativeSum = scanl1 (+) (arrayElems weights) + + totalSum :: a + totalSum = last cumulativeSum + +-- | Type-level representation of the upper bound on an unsigned 32-bit +-- integer. +type MaxWord32 = 4294967295 -- 2^32 - 1 diff --git a/copilot-libraries/src/Copilot/Library/RegExp.hs b/copilot-libraries/src/Copilot/Library/RegExp.hs index 375a0e3e2..174bfb9b9 100644 --- a/copilot-libraries/src/Copilot/Library/RegExp.hs +++ b/copilot-libraries/src/Copilot/Library/RegExp.hs @@ -9,8 +9,6 @@ -- For an example, see -- -{-# LANGUAGE FlexibleContexts #-} - module Copilot.Library.RegExp ( copilotRegexp, copilotRegexpB ) where import Text.ParserCombinators.Parsec @@ -54,7 +52,6 @@ data RegExp t = REpsilon | RStar ( RegExp t ) deriving Show - -- | Parsers for single characters. lquote, rquote, lparen, rparen, star, plus, qmark, point, minus, @@ -78,7 +75,6 @@ followedBy :: GenParser tok () a -> GenParser tok () a followedBy p p' = p >>= \ r -> p' >> return r - -- | Parsing a string p' with prefix p, returning both in order. cPrefix, optCPrefix :: GenParser tok () Char -> GenParser tok () String @@ -98,7 +94,6 @@ optCPrefix p p' = optionMaybe p ci :: String -> GenParser Char () String ci = mapM ( \ c -> ( char . toLower ) c <|> ( char . toUpper ) c ) - -- | Parser for regular expressions regexp :: ( SymbolParser t ) => GenParser Char () ( RegExp t ) regexp = chainr1 term opOr @@ -118,11 +113,9 @@ factor' = between lparen rparen regexp anySym :: ( SymbolParser t ) => GenParser Char () ( RegExp t ) anySym = point >> ( return . RSymbol ) ( NumSym Nothing Any ) - class SymbolParser t where parseSym :: GenParser Char () ( RegExp t ) - instance SymbolParser Bool where parseSym = do { truth <- ( ci "t" >> optional ( ci "rue" ) >> return True ) @@ -133,7 +126,6 @@ instance SymbolParser Bool where ; return $ RSymbol ( NumSym Nothing $ Sym truth ) } - parseWordSym :: ( Integral t ) => GenParser Char () ( RegExp t ) parseWordSym = do { num <- between lquote rquote $ many1 digit @@ -149,12 +141,10 @@ parseIntSym = do { num <- between lquote rquote $ $ fromIntegral ( read num :: Integer ) } - type StreamName = String newtype P = P { getName :: StreamName } deriving Eq - parsePSym :: GenParser Char () ( RegExp P ) parsePSym = do { pStream <- between lquote rquote $ cPrefix nondigit ( many $ nondigit <|> digit ) @@ -162,7 +152,6 @@ parsePSym = do { pStream <- between lquote rquote $ $ P pStream } - instance SymbolParser Word8 where parseSym = parseWordSym @@ -190,7 +179,6 @@ instance SymbolParser Int64 where instance SymbolParser P where parseSym = parsePSym - opOr :: GenParser Char () ( RegExp t -> RegExp t -> RegExp t ) opOr = char '|' >> return ROr @@ -215,7 +203,6 @@ parser :: ( SymbolParser t ) => GenParser Char () ( RegExp t ) parser = regexp `followedBy` eof - hasEpsilon :: RegExp t -> Bool hasEpsilon REpsilon = True hasEpsilon ( RSymbol _ ) = False @@ -223,7 +210,6 @@ hasEpsilon ( ROr r1 r2 ) = hasEpsilon r1 || hasEpsilon r2 hasEpsilon ( RConcat r1 r2 ) = hasEpsilon r1 && hasEpsilon r2 hasEpsilon ( RStar _ ) = True - first :: RegExp t -> [ NumSym t ] first REpsilon = [] first ( RSymbol s ) = [ s ] @@ -232,18 +218,15 @@ first ( RConcat r1 r2 ) = first r1 ++ if hasEpsilon r1 then first r2 else [] first ( RStar r ) = first r - reverse' :: RegExp t -> RegExp t reverse' ( ROr r1 r2 ) = ROr ( reverse' r1 ) ( reverse' r2 ) reverse' ( RConcat r1 r2 ) = RConcat ( reverse' r2 ) ( reverse' r1 ) reverse' ( RStar r ) = RStar ( reverse' r ) reverse' e = e - last' :: RegExp t -> [ NumSym t ] last' = first . reverse' - follow :: ( Eq t ) => RegExp t -> NumSym t -> [ NumSym t ] follow REpsilon _ = [] @@ -256,18 +239,15 @@ follow ( RStar r ) sNr = follow r sNr `union` if sNr `elem` last' r then first r else [] - preceding :: ( Eq t ) => RegExp t -> NumSym t -> [ NumSym t ] preceding = follow . reverse' - hasFinitePath :: RegExp t -> Bool hasFinitePath ( ROr r1 r2 ) = hasFinitePath r1 || hasFinitePath r2 hasFinitePath ( RConcat _ r2 ) = hasFinitePath r2 hasFinitePath ( RStar _ ) = False hasFinitePath _ = True - getSymbols :: RegExp t -> [ NumSym t ] getSymbols ( RSymbol s ) = [ s ] getSymbols ( ROr r1 r2 ) = getSymbols r1 ++ getSymbols r2 @@ -275,7 +255,6 @@ getSymbols ( RConcat r1 r2 ) = getSymbols r1 ++ getSymbols r2 getSymbols ( RStar r ) = getSymbols r getSymbols _ = [] - -- assign each symbol in the regular expression a -- unique number, counting up from 0 enumSyms :: RegExp t -> RegExp t @@ -299,7 +278,6 @@ enumSyms rexp = evalState ( enumSyms' rexp ) 0 enumSyms' other = return other - regexp2CopilotNFA :: ( C.Typed t, Eq t ) => C.Stream t -> RegExp t -> C.Stream Bool -> C.Stream Bool regexp2CopilotNFA inStream rexp reset = @@ -332,7 +310,6 @@ regexp2CopilotNFA inStream rexp reset = in outStream - -- | Regular expression matching over an arbitrary stream copilotRegexp :: ( C.Typed t, SymbolParser t, Eq t ) => C.Stream t -- ^ The stream to monitor. @@ -358,7 +335,6 @@ copilotRegexp inStream rexp reset = , "a distinct end-of-input symbol." ] else regexp2CopilotNFA inStream nrexp reset - regexp2CopilotNFAB :: RegExp P -> [ ( StreamName, C.Stream Bool ) ] -> C.Stream Bool -> C.Stream Bool regexp2CopilotNFAB rexp propositions reset = @@ -397,7 +373,6 @@ regexp2CopilotNFAB rexp propositions reset = in outStream - -- | Regular expression matching over a collection of boolean streams. -- -- Regular expressions can contain symbols, which are expanded to match diff --git a/copilot-libraries/src/Copilot/Library/Stacks.hs b/copilot-libraries/src/Copilot/Library/Stacks.hs index 3dd33b0b7..29c77cf09 100644 --- a/copilot-libraries/src/Copilot/Library/Stacks.hs +++ b/copilot-libraries/src/Copilot/Library/Stacks.hs @@ -1,8 +1,8 @@ --- | +-- | -- Module: Stacks -- Description: Stream for a stack machine -- Copyright: (c) 2011 National Institute of Aerospace / Galois, Inc. --- +-- -- This is a stream for a stack machine. -- -- The stack is created from a specified depth, a specified start value, and @@ -15,21 +15,21 @@ -- -- In 'stack' the push signal takes priority over the pop signal in the event -- that both are true in the same tick. This priority is reversed in 'stack''. --- +-- -- Here is an example sequence with one stack of each type, both depth 3 and -- starting value 0: -- --- @ --- popSignal: pushSignal: pushValue: stack: stack': --- false true 100 0 0 --- false true 101 100 100 --- true true 102 101 101 --- true false 103 100 102 --- true false 104 0 101 --- true false 105 0 100 --- true false 106 0 0 -- @ --- +-- popSignal: pushSignal: pushValue: stack: stack': +-- false true 100 0 0 +-- false true 101 100 100 +-- true true 102 101 101 +-- true false 103 100 102 +-- true false 104 0 101 +-- true false 105 0 100 +-- true false 106 0 0 +-- @ +-- -- Note the difference at the 4th tick after /popSignal/ and /pushSignal/ were -- both true. Note also that one cannot pop the start value off the stack - -- that is, the stack is never empty. diff --git a/copilot-libraries/src/Copilot/Library/StateMachines.hs b/copilot-libraries/src/Copilot/Library/StateMachines.hs new file mode 100644 index 000000000..37121b1a0 --- /dev/null +++ b/copilot-libraries/src/Copilot/Library/StateMachines.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE ScopedTypeVariables #-} +-- | Simulate state machines using streams. +module Copilot.Library.StateMachines where + +import Copilot.Language (Stream, Typed, constant, ifThenElse, (&&), (++), (==)) +import Prelude hiding ((&&), (++), (==)) + +-- | A definition of a state machine where some elements are defined +-- as streams. +-- +-- A state machine is defined by an initial state, a final state, a no +-- transition stream (true when tere is no input coming in), a list of +-- transitions, and a bad state. +type StateMachine a = (a, a, Stream Bool, [(a, Stream Bool, a)], a) + +-- | Produce a stream that, at any given time, contains the current state of +-- the state machine. +stateMachine :: forall a . (Eq a, Typed a) => StateMachine a -> Stream a +stateMachine (initial, final, noInputData, transitions, bad) = state + where + state = ifThenElses transitions + previousState = [initial] ++ state + + ifThenElses :: [(a, Stream Bool, a)] -> Stream a + ifThenElses [] = + ifThenElse (previousState == constant final && noInputData) + (constant final) + (constant bad) + + ifThenElses ((s1, i, s2):ss) = + ifThenElse + (previousState == constant s1 && i) + (constant s2) + (ifThenElses ss) + +-- | Produce a stream that, at any given time, contains the current state of +-- the state machine as the numeric representation of an enum. +stateMachineEnum :: (Eq b, Typed b, Num b, Enum a) + => StateMachine a + -> Stream b +stateMachineEnum (initial, final, noInputData, transitions, bad) = + stateMachine (fe initial, fe final, noInputData, transitionsE, fe bad) + where + transitionsE = map (\(s1, t, s2) -> (fe s1, t, fe s2)) transitions + fe = fromIntegral . fromEnum diff --git a/copilot-libraries/src/Copilot/Library/Statistics.hs b/copilot-libraries/src/Copilot/Library/Statistics.hs index 7a1a57ffb..d6e0330b9 100644 --- a/copilot-libraries/src/Copilot/Library/Statistics.hs +++ b/copilot-libraries/src/Copilot/Library/Statistics.hs @@ -1,4 +1,4 @@ --- | +-- | -- Module: Statistics -- Description: Basic bounded statistics -- Copyright: (c) 2011 National Institute of Aerospace / Galois, Inc. @@ -22,12 +22,14 @@ sum n s = nfoldl1 n (+) s -- | Maximum value. max :: ( Typed a, Ord a ) => Int -> Stream a -> Stream a max n s = nfoldl1 n largest s - where largest = \ x y -> mux ( x >= y ) x y + where + largest = \ x y -> mux ( x >= y ) x y -- | Minimum value. min :: ( Typed a, Ord a ) => Int -> Stream a -> Stream a min n s = nfoldl1 n smallest s - where smallest = \ x y -> mux ( x <= y ) x y + where + smallest = \ x y -> mux ( x <= y ) x y -- | Mean value. @n@ must not overflow -- for word size @a@ for streams over which computation is peformed. @@ -36,6 +38,6 @@ mean n s = ( sum n s ) / ( fromIntegral n ) -- | Mean value over the current set of streams passed in. meanNow :: ( Typed a, Integral a ) => [ Stream a ] -> Stream a -meanNow [] = +meanNow [] = badUsage "list of arguments to meanNow must be nonempty" meanNow ls = ( foldl1 (+) ls ) `div` ( fromIntegral $ length ls ) diff --git a/copilot-libraries/src/Copilot/Library/Utils.hs b/copilot-libraries/src/Copilot/Library/Utils.hs index 1e31b71b3..6785aa88d 100644 --- a/copilot-libraries/src/Copilot/Library/Utils.hs +++ b/copilot-libraries/src/Copilot/Library/Utils.hs @@ -13,7 +13,7 @@ module Copilot.Library.Utils -- ** Scans nscanl, nscanr, nscanl1, nscanr1, -- ** Indexing - case', (!!)) + case', (!!!)) where import Copilot.Language @@ -27,7 +27,6 @@ tails :: ( Typed a ) => Stream a -> [ Stream a ] tails s = [ drop x s | x <- [ 0 .. ] ] - -- | Given a stream and a number, produce a finite list of streams dropping an -- increasing number of elements of the given stream, up to that number. For -- example, for a given stream @s@, the expression @take 2 s@ is equal to @@ -118,7 +117,6 @@ nscanr1 :: ( Typed a ) -> Stream a -> [ Stream a ] nscanr1 n f s = scanr1 f $ take n s - -- | Case-like function: The index of the first predicate that is true -- in the predicate list selects the stream result. If no predicate -- is true, the last element is chosen (default element) @@ -136,24 +134,25 @@ case' predicates alternatives = -- | Index. -- -- WARNING: Very expensive! Consider using this only for very short lists. -(!!) :: (Typed a, Eq b, Num b, Typed b) => [Stream a] -> Stream b -> Stream a -ls !! n = let indices = map +(!!!) :: (Typed a, Eq b, Num b, Typed b) => [Stream a] -> Stream b -> Stream a +ls !!! n = let indices = map ( constant . fromIntegral ) [ 0 .. P.length ls - 1 ] - select [] _ = last ls - select - ( i : is ) - ( x : xs ) = mux ( i == n ) x ( select is xs ) - -- should not happen - select _ [] = badUsage ("in (!!) defined in Utils.hs " P.++ - "in copilot-libraries") - in if null ls then - badUsage ("in (!!) defined in Utils.hs " P.++ - "indexing the empty list with !! is not defined") - else - select indices ls + select [] _ = last ls + select + ( i : is ) + ( x : xs ) = mux ( i == n ) x ( select is xs ) + -- should not happen + select _ [] = badUsage ("in (!!) defined in Utils.hs " P.++ + "in copilot-libraries") + in if null ls then + badUsage ("in (!!) defined in Utils.hs " P.++ + "indexing the empty list with !! is not defined") + else + select indices ls -- | Cycle a list to form an infinite stream. cycle :: ( Typed a ) => [ a ] -> Stream a cycle ls = cycle' - where cycle' = ls ++ cycle' + where + cycle' = ls ++ cycle' diff --git a/copilot-libraries/src/Copilot/Library/Voting.hs b/copilot-libraries/src/Copilot/Library/Voting.hs index fb940b077..306fe424c 100644 --- a/copilot-libraries/src/Copilot/Library/Voting.hs +++ b/copilot-libraries/src/Copilot/Library/Voting.hs @@ -1,4 +1,4 @@ --- | +-- | -- Module: Voting -- Description: Implementation of the Boyer-Moore Majority Vote Algorithm -- Copyright: (c) 2011 National Institute of Aerospace / Galois, Inc. @@ -34,7 +34,7 @@ {-# LANGUAGE RebindableSyntax #-} -module Copilot.Library.Voting +module Copilot.Library.Voting ( majority, aMajority ) where import Copilot.Language @@ -53,11 +53,21 @@ majority' :: (P.Eq a, Typed a) majority' [] can _ = can majority' (x:xs) can cnt = local (cnt == 0) inZero - where + where inZero zero = local (if zero then x else can) inCan - where - inCan can' = local (if zero || x == can then cnt+1 else cnt-1) inCnt - where + where + inCan can' = + -- We include a special case for when `xs` is empty that immediately + -- returns `can'`. We could omit this special case without changing the + -- final result, but this has the downside that `local` would bind a + -- local variable that would go unused in `inCnt`. (Note that `inCnt` + -- recursively invokes `majority'`, which doesn't use its last argument + -- if the list of vote streams is empty.) These unused local variables + -- would result in C code that triggers compiler warnings. + case xs of + [] -> can' + _ -> local (if zero || x == can then cnt+1 else cnt-1) inCnt + where inCnt cnt' = majority' xs can' cnt' -- | Majority vote second pass: checking that a candidate indeed has more than diff --git a/copilot-libraries/tests/Main.hs b/copilot-libraries/tests/Main.hs new file mode 100644 index 000000000..018134083 --- /dev/null +++ b/copilot-libraries/tests/Main.hs @@ -0,0 +1,18 @@ +-- | Test copilot-libraries. +module Main where + +-- External imports +import Test.Framework (Test, defaultMain) + +-- Internal imports +import qualified Test.Copilot.Library.PTLTL + +-- | Run all unit tests on copilot-libraries. +main :: IO () +main = defaultMain tests + +-- | All unit tests in copilot-libraries. +tests :: [Test.Framework.Test] +tests = + [ Test.Copilot.Library.PTLTL.tests + ] diff --git a/copilot-libraries/tests/Test/Copilot/Library/PTLTL.hs b/copilot-libraries/tests/Test/Copilot/Library/PTLTL.hs new file mode 100644 index 000000000..58c002308 --- /dev/null +++ b/copilot-libraries/tests/Test/Copilot/Library/PTLTL.hs @@ -0,0 +1,72 @@ +-- | Test copilot-libraries:Copilot.Library.PTLTL +module Test.Copilot.Library.PTLTL + (tests) + where + +-- External imports +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.QuickCheck (Gen, Property) + +-- External imports: Copilot +import Copilot.Language (extern) +import qualified Copilot.Language.Operators.Boolean as Copilot +import Copilot.Language.Stream (Stream) +import Copilot.Theorem.What4 (SatResult (..)) + +-- Internal imports: auxiliary functions +import Test.Extra (arbitraryBoolExpr, testWithInterpreter, testWithTheorem) + +-- Internal imports: Modules being tested +import Copilot.Library.PTLTL (eventuallyPrev, previous) + +-- * Constants + +-- | Unit tests for copilot-libraries:Copilot.Library.PTLTL. +tests :: Test.Framework.Test +tests = + testGroup "Copilot.Library.PTLTL" + [ testProperty "previous x ==> eventuallyPrev x (theorem)" + testProvePreviousEventually + , testProperty "previous x ==> eventuallyPrev x (interpreter)" + testCheckPreviousEventually + ] + +-- * Individual tests + +-- | Test that Z3 is able to prove the following expression valid: +-- @ +-- previous x ==> eventuallyPrev x +-- @ +testProvePreviousEventually :: Property +testProvePreviousEventually = testWithTheorem pair + where + pair :: Gen (Stream Bool, SatResult) + pair = pure (stream, expectation) + + stream :: Stream Bool + stream = + previous boolStream Copilot.==> eventuallyPrev boolStream + where + boolStream = extern "x" Nothing + + expectation :: SatResult + expectation = Valid + +-- | Test that the following stream is always true: +-- @ +-- previous x ==> eventuallyPrev x +-- @ +testCheckPreviousEventually :: Property +testCheckPreviousEventually = testWithInterpreter pair + where + pair :: Gen (Stream Bool, [Bool]) + pair = do + -- We discard the expectation from the expression; the temporal formula + -- holds at all times regardless. + boolStream <- fst <$> arbitraryBoolExpr + let prop = previous boolStream Copilot.==> eventuallyPrev boolStream + return (prop, expectation) + + expectation :: [Bool] + expectation = repeat True diff --git a/copilot-libraries/tests/Test/Extra.hs b/copilot-libraries/tests/Test/Extra.hs new file mode 100644 index 000000000..da462cb05 --- /dev/null +++ b/copilot-libraries/tests/Test/Extra.hs @@ -0,0 +1,556 @@ +-- The following warning is disabled due to a necessary instance of SatResult +-- defined in this module. +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | Testing facilities based on the connection to SMT solvers and the +-- interpreter. +-- +-- This module provides functions to check if a stream meets some expectation, +-- and to generate random streams. +-- +-- The test against an expectation can be done by checking a boolean stream +-- with copilot-theorem and comparing it with the expected validity, or by +-- evaluating a stream with the interpreter and comparing it with the expected +-- list of values it should contain. +module Test.Extra + ( + -- * Test using copilot-theorem + testWithTheorem + + -- * Test using copilot-interpreter + , testWithInterpreter + + -- * Random Stream generators + , arbitraryConst + , arbitraryBoolExpr + , arbitraryNumExpr + , arbitraryFloatingExpr + , arbitraryBitsExpr + ) + where + +-- External imports +import Control.Arrow ((***)) +import Control.Monad (void) +import Data.Bits (Bits, complement, xor, (.&.), (.|.)) +import Data.Int (Int16, Int32, Int64, Int8) +import Data.Maybe (fromMaybe) +import Data.Word (Word16, Word32, Word64, Word8) +import Test.QuickCheck (Arbitrary, Gen, Property, arbitrary, chooseInt, + elements, forAll, forAllShow, frequency) +import Test.QuickCheck.Monadic (monadicIO, run) + +-- External imports: Copilot +import Copilot.Interpret.Eval (ExecTrace (interpObservers), + ShowType (Haskell), eval) +import Copilot.Language (Spec, Stream, Typed, + observer, prop) +import qualified Copilot.Language as Copilot +import qualified Copilot.Language.Operators.Boolean as Copilot +import qualified Copilot.Language.Operators.Constant as Copilot +import qualified Copilot.Language.Operators.Eq as Copilot +import qualified Copilot.Language.Operators.Mux as Copilot +import qualified Copilot.Language.Operators.Ord as Copilot +import Copilot.Language.Reify (reify) +import Copilot.Theorem.What4 (SatResult (..), + Solver (..), prove) + +-- * Test using copilot-theorem + +-- | Define a QuickCheck property based on a generator of boolean streams and +-- their validity as Copilot properties. +-- +-- Uses the connection to copilot-theorem to determine whether the expectation +-- is the same as what copilot-theorem determines. +testWithTheorem :: Gen (Stream Bool, SatResult) -> Property +testWithTheorem gen = + forAll gen $ \(stream, expectation) -> do + let propName :: String + propName = "prop" + + spec :: Spec + spec = void $ prop propName $ Copilot.forAll stream + + monadicIO $ run $ checkResult Z3 propName spec expectation + +-- | Check that the solver's satisfiability result for the given Copilot +-- property in the given spec matches the expectation. +checkResult :: Solver -> String -> Spec -> SatResult -> IO Bool +checkResult solver propName spec expectation = do + spec' <- reify spec + 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 + +-- | Equality for 'SatResult'. +-- +-- This is an orphan instance. 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 + +-- * Testing facilities based on copilot-interpreter + +-- | Max length of the traces being tested. +maxTraceLength :: Int +maxTraceLength = 200 + +-- | Define a QuickCheck property based on an interpretation of the stream and +-- a comparison with a list, up to a given 'maxTraceLength'. +-- +-- Uses the connection to copilot-interpreter to determine whether the +-- expectation is the same as what the interpreter determines. +testWithInterpreter :: (Eq t, Read t, Typed t) + => Gen (Stream t, [t]) + -> Property +testWithInterpreter stream = + forAll (chooseInt (0, maxTraceLength)) $ \steps -> + forAllShow stream (testPairShowK steps) $ \pair -> + monadicIO $ run (checkTestPairP steps pair) + +-- | Show function for test pairs that limits the accompanying list to a +-- certain length. +testPairShowK :: Show t => Int -> (Stream t, [t]) -> String +testPairShowK steps (_expr, exprList) = + show ("Cannot show stream", take steps exprList) + +-- | Check that the expression in the test pair is evaluated to the given list, +-- up to a number of steps. +-- +-- Some operations will overflow and return NaN. Because comparing any NaN +-- will, as per IEEE 754, always fail (i.e., return False), we handle that +-- specific case by stating that the test succeeds if any expected values is +-- NaN. +checkTestPairP :: (Eq t, Read t, Typed t, Show t) + => Int + -> (Stream t, [t]) + -> IO Bool +checkTestPairP steps (expr, exprList) = do + -- Spec with just one observer of one expression. + -- + -- We need to help GHC figure out the type of spec. + let spec :: Spec + spec = observer testObserverName expr + + -- Reified stream (low-level) + llSpec <- reify spec + + let trace = eval Haskell steps llSpec + + -- Limit expectation to the number of evaluation steps. + let expectation = take steps exprList + + -- Obtain the results by looking up the observer in the spec + -- and parsing the results into Haskell values. + let resultValues = fmap readResult results + results = lookupWithDefault testObserverName [] + $ interpObservers trace + + return $ any isNaN' expectation || resultValues == expectation + + where + + -- Fixed name for the observer. Used to obtain the result from the + -- trace. It should be the only observer in the trace. + testObserverName :: String + testObserverName = "res" + + -- | Is NaN with Eq requirement only. + isNaN' :: Eq a => a -> Bool + isNaN' x = x /= x + + -- | Read a Haskell value from the output of the evaluator. + readResult :: Read a => String -> a + readResult = read . readResult' + where + readResult' :: String -> String + readResult' "false" = "False" + readResult' "true" = "True" + readResult' s = s + +-- * Random Stream generators + +-- | An arbitrary constant expression of any type, paired with its expected +-- meaning. +arbitraryConst :: (Arbitrary t, Typed t) + => Gen (Stream t, [t]) +arbitraryConst = (\v -> (Copilot.constant v, repeat v)) <$> arbitrary + +-- | Generator for constant boolean streams, paired with their expected +-- meaning. +arbitraryBoolOp0 :: Gen (Stream Bool, [Bool]) +arbitraryBoolOp0 = elements + [ (Copilot.false, repeat False) + , (Copilot.true, repeat True) + ] + +-- | An arbitrary boolean expression, paired with its expected meaning. +arbitraryBoolExpr :: Gen (Stream Bool, [Bool]) +arbitraryBoolExpr = + -- We use frequency instead of oneof because the random expression generator + -- seems to generate expressions that are too large and the test fails due + -- to running out of memory. + frequency + [ (10, arbitraryConst) + + , (5, arbitraryBoolOp0) + + , (5, apply1 <$> arbitraryBoolOp1 <*> arbitraryBoolExpr) + + , (1, apply2 <$> arbitraryBoolOp2 + <*> arbitraryBoolExpr + <*> arbitraryBoolExpr) + + , (1, apply2 <$> arbitraryEqOp2 + <*> arbitraryBoolExpr + <*> arbitraryBoolExpr) + + , (1, apply2 <$> arbitraryEqOp2 + <*> arbitraryBitsExpr + <*> (arbitraryBitsExpr :: Gen (Stream Int8, [Int8]))) + + , (1, apply2 <$> arbitraryEqOp2 + <*> arbitraryBitsExpr + <*> (arbitraryBitsExpr :: Gen (Stream Int16, [Int16]))) + + , (1, apply2 <$> arbitraryEqOp2 + <*> arbitraryBitsExpr + <*> (arbitraryBitsExpr :: Gen (Stream Int32, [Int32]))) + + , (1, apply2 <$> arbitraryEqOp2 + <*> arbitraryBitsExpr + <*> (arbitraryBitsExpr :: Gen (Stream Int64, [Int64]))) + + , (1, apply2 <$> arbitraryEqOp2 + <*> arbitraryBitsExpr + <*> (arbitraryBitsExpr :: Gen (Stream Word8, [Word8]))) + + , (1, apply2 <$> arbitraryEqOp2 + <*> arbitraryBitsExpr + <*> (arbitraryBitsExpr :: Gen (Stream Word16, [Word16]))) + + , (1, apply2 <$> arbitraryEqOp2 + <*> arbitraryBitsExpr + <*> (arbitraryBitsExpr :: Gen (Stream Word32, [Word32]))) + + , (1, apply2 <$> arbitraryEqOp2 + <*> arbitraryBitsExpr + <*> (arbitraryBitsExpr :: Gen (Stream Word64, [Word64]))) + + , (1, apply2 <$> arbitraryEqOp2 + <*> arbitraryNumExpr + <*> (arbitraryNumExpr :: Gen (Stream Int8, [Int8]))) + + , (1, apply2 <$> arbitraryEqOp2 + <*> arbitraryNumExpr + <*> (arbitraryNumExpr :: Gen (Stream Int16, [Int16]))) + + , (1, apply2 <$> arbitraryEqOp2 + <*> arbitraryNumExpr + <*> (arbitraryNumExpr :: Gen (Stream Int32, [Int32]))) + + , (1, apply2 <$> arbitraryEqOp2 + <*> arbitraryNumExpr + <*> (arbitraryNumExpr :: Gen (Stream Int64, [Int64]))) + + , (1, apply2 <$> arbitraryEqOp2 + <*> arbitraryNumExpr + <*> (arbitraryNumExpr :: Gen (Stream Word8, [Word8]))) + + , (1, apply2 <$> arbitraryEqOp2 + <*> arbitraryNumExpr + <*> (arbitraryNumExpr :: Gen (Stream Word16, [Word16]))) + + , (1, apply2 <$> arbitraryEqOp2 + <*> arbitraryNumExpr + <*> (arbitraryNumExpr :: Gen (Stream Word32, [Word32]))) + + , (1, apply2 <$> arbitraryEqOp2 + <*> arbitraryNumExpr + <*> (arbitraryNumExpr :: Gen (Stream Word64, [Word64]))) + + , (1, apply2 <$> arbitraryOrdOp2 + <*> arbitraryNumExpr + <*> (arbitraryNumExpr :: Gen (Stream Int8, [Int8]))) + + , (1, apply2 <$> arbitraryOrdOp2 + <*> arbitraryNumExpr + <*> (arbitraryNumExpr :: Gen (Stream Int16, [Int16]))) + + , (1, apply2 <$> arbitraryOrdOp2 + <*> arbitraryNumExpr + <*> (arbitraryNumExpr :: Gen (Stream Int32, [Int32]))) + + , (1, apply2 <$> arbitraryOrdOp2 + <*> arbitraryNumExpr + <*> (arbitraryNumExpr :: Gen (Stream Int64, [Int64]))) + + , (1, apply2 <$> arbitraryOrdOp2 + <*> arbitraryNumExpr + <*> (arbitraryNumExpr :: Gen (Stream Word8, [Word8]))) + + , (1, apply2 <$> arbitraryOrdOp2 + <*> arbitraryNumExpr + <*> (arbitraryNumExpr :: Gen (Stream Word16, [Word16]))) + + , (1, apply2 <$> arbitraryOrdOp2 + <*> arbitraryNumExpr + <*> (arbitraryNumExpr :: Gen (Stream Word32, [Word32]))) + + , (1, apply2 <$> arbitraryOrdOp2 + <*> arbitraryNumExpr + <*> (arbitraryNumExpr :: Gen (Stream Word64, [Word64]))) + + , (1, apply2 <$> arbitraryOrdOp2 + <*> arbitraryFloatingExpr + <*> (arbitraryFloatingExpr :: Gen (Stream Float, [Float]))) + + , (1, apply2 <$> arbitraryOrdOp2 + <*> arbitraryFloatingExpr + <*> (arbitraryFloatingExpr :: Gen (Stream Double, [Double]))) + + , (1, apply3 <$> arbitraryITEOp3 + <*> arbitraryBoolExpr + <*> arbitraryBoolExpr + <*> arbitraryBoolExpr) + ] + +-- | An arbitrary numeric expression, paired with its expected meaning. +arbitraryNumExpr :: (Arbitrary t, Typed t, Num t, Eq t) + => Gen (Stream t, [t]) +arbitraryNumExpr = + -- We use frequency instead of oneof because the random expression generator + -- seems to generate expressions that are too large and the test fails due + -- to running out of memory. + frequency + [ (10, arbitraryConst) + + , (5, apply1 <$> arbitraryNumOp1 <*> arbitraryNumExpr) + + , (2, apply2 <$> arbitraryNumOp2 <*> arbitraryNumExpr <*> arbitraryNumExpr) + + , (2, apply3 <$> arbitraryITEOp3 + <*> arbitraryBoolExpr + <*> arbitraryNumExpr + <*> arbitraryNumExpr) + ] + +-- | An arbitrary floating point expression, paired with its expected meaning. +arbitraryFloatingExpr :: (Arbitrary t, Typed t, Floating t, Eq t) + => Gen (Stream t, [t]) +arbitraryFloatingExpr = + -- We use frequency instead of oneof because the random expression generator + -- seems to generate expressions that are too large and the test fails due + -- to running out of memory. + frequency + [ (10, arbitraryConst) + + , (5, apply1 <$> arbitraryFloatingOp1 <*> arbitraryFloatingExpr) + + , (5, apply1 <$> arbitraryNumOp1 <*> arbitraryFloatingExpr) + + , (2, apply2 <$> arbitraryFloatingOp2 + <*> arbitraryFloatingExpr + <*> arbitraryFloatingExpr) + + , (2, apply2 <$> arbitraryNumOp2 + <*> arbitraryFloatingExpr + <*> arbitraryFloatingExpr) + + , (1, apply3 <$> arbitraryITEOp3 + <*> arbitraryBoolExpr + <*> arbitraryFloatingExpr + <*> arbitraryFloatingExpr) + ] + +-- | An arbitrary Bits expression, paired with its expected meaning. +arbitraryBitsExpr :: (Arbitrary t, Typed t, Bits t) + => Gen (Stream t, [t]) +arbitraryBitsExpr = + -- We use frequency instead of oneof because the random expression generator + -- seems to generate expressions that are too large and the test fails due + -- to running out of memory. + frequency + [ (10, arbitraryConst) + + , (5, apply1 <$> arbitraryBitsOp1 <*> arbitraryBitsExpr) + + , (2, apply2 <$> arbitraryBitsOp2 + <*> arbitraryBitsExpr + <*> arbitraryBitsExpr) + + , (2, apply3 <$> arbitraryITEOp3 + <*> arbitraryBoolExpr + <*> arbitraryBitsExpr <*> arbitraryBitsExpr) + ] + +-- ** Operators + +-- *** Op 1 + +-- | Generator for arbitrary boolean operators with arity 1, paired with their +-- expected meaning. +arbitraryBoolOp1 :: Gen (Stream Bool -> Stream Bool, [Bool] -> [Bool]) +arbitraryBoolOp1 = elements + [ (Copilot.not, fmap not) + ] + +-- | Generator for arbitrary numeric operators with arity 1, paired with their +-- expected meaning. +arbitraryNumOp1 :: (Typed t, Num t, Eq t) + => Gen (Stream t -> Stream t, [t] -> [t]) +arbitraryNumOp1 = elements + [ (abs, fmap abs) + , (signum, fmap signum) + ] + +-- | Generator for arbitrary floating point operators with arity 1, paired with +-- their expected meaning. +arbitraryFloatingOp1 :: (Typed t, Floating t, Eq t) + => Gen (Stream t -> Stream t, [t] -> [t]) +arbitraryFloatingOp1 = elements + [ (exp, fmap exp) + , (sqrt, fmap sqrt) + , (log, fmap log) + , (sin, fmap sin) + , (tan, fmap tan) + , (cos, fmap cos) + , (asin, fmap asin) + , (atan, fmap atan) + , (acos, fmap acos) + , (sinh, fmap sinh) + , (tanh, fmap tanh) + , (cosh, fmap cosh) + , (asinh, fmap asinh) + , (atanh, fmap atanh) + , (acosh, fmap acosh) + ] + +-- | Generator for arbitrary bitwise operators with arity 1, paired with their +-- expected meaning. +arbitraryBitsOp1 :: (Typed t, Bits t) + => Gen (Stream t -> Stream t, [t] -> [t]) +arbitraryBitsOp1 = elements + [ (complement, fmap complement) + ] + +-- *** Op 2 + +-- | Generator for arbitrary boolean operators with arity 2, paired with their +-- expected meaning. +arbitraryBoolOp2 :: Gen ( Stream Bool -> Stream Bool -> Stream Bool + , [Bool] -> [Bool] -> [Bool] + ) +arbitraryBoolOp2 = elements + [ ((Copilot.&&), zipWith (&&)) + , ((Copilot.||), zipWith (||)) + , ((Copilot.==>), zipWith (\x y -> not x || y)) + , ((Copilot.xor), zipWith (\x y -> (x || y) && not (x && y))) + ] + +-- | Generator for arbitrary numeric operators with arity 2, paired with their +-- expected meaning. +arbitraryNumOp2 :: (Typed t, Num t, Eq t) + => Gen (Stream t -> Stream t -> Stream t, [t] -> [t] -> [t]) +arbitraryNumOp2 = elements + [ ((+), zipWith (+)) + , ((-), zipWith (-)) + , ((*), zipWith (*)) + ] + +-- | Generator for arbitrary floating point operators with arity 2, paired with +-- their expected meaning. +arbitraryFloatingOp2 :: (Typed t, Floating t, Eq t) + => Gen ( Stream t -> Stream t -> Stream t + , [t] -> [t] -> [t] + ) +arbitraryFloatingOp2 = elements + [ ((**), zipWith (**)) + , (logBase, zipWith logBase) + ] + +-- | Generator for arbitrary equality operators with arity 2, paired with their +-- expected meaning. +arbitraryEqOp2 :: (Typed t, Eq t) + => Gen ( Stream t -> Stream t -> Stream Bool + , [t] -> [t] -> [Bool] + ) +arbitraryEqOp2 = elements + [ ((Copilot.==), zipWith (==)) + , ((Copilot./=), zipWith (/=)) + ] + +-- | Generator for arbitrary ordering operators with arity 2, paired with their +-- expected meaning. +arbitraryOrdOp2 :: (Typed t, Ord t) + => Gen ( Stream t -> Stream t -> Stream Bool + , [t] -> [t] -> [Bool] + ) +arbitraryOrdOp2 = elements + [ ((Copilot.<=), zipWith (<=)) + , ((Copilot.<), zipWith (<)) + , ((Copilot.>=), zipWith (>=)) + , ((Copilot.>), zipWith (>)) + ] + +-- | Generator for arbitrary bitwise operators with arity 2, paired with their +-- expected meaning. +arbitraryBitsOp2 :: (Typed t, Bits t) + => Gen (Stream t -> Stream t -> Stream t, [t] -> [t] -> [t]) +arbitraryBitsOp2 = elements + [ ((.&.), zipWith (.&.)) + , ((.|.), zipWith (.|.)) + , (xor, zipWith xor) + ] + +-- *** Op 3 + +-- | Generator for if-then-else operator (with arity 3), paired with its +-- expected meaning. +-- +-- Although this is constant and there is nothing arbitrary, we use the same +-- structure and naming convention as with others for simplicity. +arbitraryITEOp3 :: (Arbitrary t, Typed t) + => Gen ( Stream Bool -> Stream t -> Stream t -> Stream t + , [Bool] -> [t] -> [t] -> [t] + ) +arbitraryITEOp3 = return + (Copilot.mux, zipWith3 (\x y z -> if x then y else z)) + +-- * Auxiliary + +-- | Apply a tuple with two functions to a tuple of arguments. +apply1 :: (a1 -> b1, a2 -> b2) -- ^ Pair with functions + -> (a1, a2) -- ^ Pair with arguments + -> (b1, b2) -- ^ Pair with results +apply1 = uncurry (***) + +-- | Apply a tuple with two functions on two arguments to their tupled +-- arguments. +apply2 :: (a1 -> b1 -> c1, a2 -> b2 -> c2) -- ^ Pair with functions + -> (a1, a2) -- ^ Pair with first arguments + -> (b1, b2) -- ^ Pair with second arguments + -> (c1, c2) -- ^ Pair with results +apply2 fs = apply1 . apply1 fs + +-- | Apply a tuple with two functions on three arguments to their tupled +-- arguments. +apply3 :: (a1 -> b1 -> c1 -> d1, a2 -> b2 -> c2 -> d2) + -- ^ Pair with functions + -> (a1, a2) -- ^ Pair with first arguments + -> (b1, b2) -- ^ Pair with second arguments + -> (c1, c2) -- ^ Pair with third arguments + -> (d1, d2) -- ^ Pair with results +apply3 fs = apply2 . apply1 fs + +-- | Variant of 'lookup' with an additional default value returned when the key +-- provided is not found in the map. +lookupWithDefault :: Ord k => k -> v -> [(k, v)] -> v +lookupWithDefault k def = fromMaybe def . lookup k diff --git a/copilot-prettyprinter/CHANGELOG b/copilot-prettyprinter/CHANGELOG new file mode 100644 index 000000000..bbe715c47 --- /dev/null +++ b/copilot-prettyprinter/CHANGELOG @@ -0,0 +1,85 @@ +2026-11-07 + * Version bump (4.8.2). (#792) + +2026-09-07 + * Version bump (4.8.1). (#760) + +2026-07-07 + * Version bump (4.8). (#745) + +2026-05-07 + * Version bump (4.7.1). (#730) + +2026-03-07 + * Version bump (4.7). (#714) + +2026-01-07 + * Version bump (4.6.1). (#705) + +2025-11-07 + * Version bump (4.6). (#679) + +2025-09-07 + * Version bump (4.5.1). (#666) + +2025-07-07 + * Version bump (4.5). (#642) + +2025-05-07 + * Version bump (4.4). (#618) + +2025-03-07 + * Version bump (4.3). (#604) + * Update pretty-printing to handle Props. (#254) + +2025-01-07 + * Version bump (4.2). (#577) + * Remove uses of Copilot.Core.Expr.UExpr.uExprExpr. (#565) + +2024-11-07 + * Version bump (4.1). (#561) + +2024-09-07 + * Version bump (4.0). (#532) + * Add support for pretty-printing struct update expressions. (#526) + * Add support for pretty-printing array update expressions. (#36) + +2024-07-07 + * Version bump (3.20). (#522) + +2024-05-07 + * Version bump (3.19.1). (#512) + +2024-03-07 + * Version bump (3.19). (#504) + +2024-01-07 + * Version bump (3.18.1). (#493) + +2024-01-07 + * Version bump (3.18). (#487) + +2023-11-07 + * Version bump (3.17). (#466) + +2023-11-05 + * 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) + +2023-01-07 + * Version bump (3.13). (#406) + +2022-11-07 + * Version bump (3.12). (#389) + * Create new library for pretty-printer. (#383) diff --git a/copilot-prettyprinter/LICENSE b/copilot-prettyprinter/LICENSE new file mode 100644 index 000000000..d4ed5bc4c --- /dev/null +++ b/copilot-prettyprinter/LICENSE @@ -0,0 +1,29 @@ +2009 +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. diff --git a/copilot-prettyprinter/README.md b/copilot-prettyprinter/README.md new file mode 100644 index 000000000..a1ca540c4 --- /dev/null +++ b/copilot-prettyprinter/README.md @@ -0,0 +1,33 @@ +[![Build Status](https://travis-ci.com/Copilot-Language/copilot.svg?branch=master)](https://app.travis-ci.com/github/Copilot-Language/copilot) + +# Copilot: a stream DSL +Copilot-prettyprinter implements a pretty-printer of Copilot Core +specifications. + +Copilot is a runtime verification framework written in Haskell. It allows the +user to write programs in a simple but powerful way using a stream-based +approach. + +Programs can be interpreted for testing, or translated C99 code to be +incorporated in a project, or as a standalone application. The C99 backend +ensures us that the output is constant in memory and time, making it suitable +for systems with hard realtime requirements. + + +## Installation +Copilot-prettyprinter can be found on +[Hackage](https://hackage.haskell.org/package/copilot-prettyprinter). It is +typically only installed as part of the complete Copilot distribution. For +installation instructions, please refer to the [Copilot +website](https://copilot-language.github.io). + + +## Further information +For further information, install instructions and documentation, please visit +the Copilot website: +[https://copilot-language.github.io](https://copilot-language.github.io) + + +## License +Copilot is distributed under the BSD-3-Clause license, which can be found +[here](https://raw.githubusercontent.com/Copilot-Language/copilot/master/copilot-prettyprinter/LICENSE). diff --git a/copilot-prettyprinter/Setup.hs b/copilot-prettyprinter/Setup.hs new file mode 100644 index 000000000..9a994af67 --- /dev/null +++ b/copilot-prettyprinter/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/copilot-prettyprinter/copilot-prettyprinter.cabal b/copilot-prettyprinter/copilot-prettyprinter.cabal new file mode 100644 index 000000000..35c5c7d7c --- /dev/null +++ b/copilot-prettyprinter/copilot-prettyprinter.cabal @@ -0,0 +1,57 @@ +cabal-version: >=1.10 +name: copilot-prettyprinter +version: 4.8.2 +synopsis: A prettyprinter of Copilot Specifications. +description: + A prettyprinter of Copilot specifications. + . + 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 + . + +author: Frank Dedden, Lee Pike, Robin Morisset, Alwyn Goodloe, + Sebastian Niller, Nis Nordbyop Wegmann, Ivan Perez +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 + +x-curation: uncurated + +source-repository head + type: git + location: https://github.com/Copilot-Language/copilot.git + subdir: copilot-prettyprinter + +library + + default-language: Haskell2010 + + hs-source-dirs: src + + ghc-options: + -Wall + -fno-warn-orphans + + build-depends: + base >= 4.9 && < 5, + pretty >= 1.0 && < 1.2, + + copilot-core >= 4.8.2 && < 4.9 + + exposed-modules: + + Copilot.PrettyPrint + + other-modules: + + Copilot.PrettyPrint.Error + Copilot.PrettyPrint.Type diff --git a/copilot-core/src/Copilot/Core/PrettyPrint.hs b/copilot-prettyprinter/src/Copilot/PrettyPrint.hs similarity index 82% rename from copilot-core/src/Copilot/Core/PrettyPrint.hs rename to copilot-prettyprinter/src/Copilot/PrettyPrint.hs index dcd82ac3c..4bbad626b 100644 --- a/copilot-core/src/Copilot/Core/PrettyPrint.hs +++ b/copilot-prettyprinter/src/Copilot/PrettyPrint.hs @@ -1,32 +1,27 @@ --------------------------------------------------------------------------------- -- Copyright © 2011 National Institute of Aerospace / Galois, Inc. --------------------------------------------------------------------------------- -- | A pretty printer for Copilot specifications. -{-# LANGUAGE Safe #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE Safe #-} -module Copilot.Core.PrettyPrint +module Copilot.PrettyPrint ( prettyPrint , ppExpr ) where import Copilot.Core -import Copilot.Core.Type.Show (showWithType, ShowType(..), showType) +import Copilot.PrettyPrint.Error (impossible) +import Copilot.PrettyPrint.Type (showWithType, ShowType(..), showType) import Prelude hiding (id, (<>)) import Text.PrettyPrint.HughesPJ import Data.List (intersperse) --------------------------------------------------------------------------------- - -- | Create a unique stream name by prefixing the given ID by a lowercase -- letter @"s"@. strmName :: Int -> Doc strmName id = text "s" <> int id --------------------------------------------------------------------------------- - -- | Pretty-print a Copilot expression. -- -- The type is ignored, and only the expression is pretty-printed. @@ -48,7 +43,7 @@ ppExpr e0 = case e0 of -- -- The type is ignored, and only the expression is pretty-printed. ppUExpr :: UExpr -> Doc -ppUExpr UExpr { uExprExpr = e0 } = ppExpr e0 +ppUExpr (UExpr _ e0) = ppExpr e0 -- | Pretty-print a unary operation. ppOp1 :: Op1 a b -> Doc -> Doc @@ -76,8 +71,8 @@ ppOp1 op = case op of Floor _ -> ppPrefix "floor" BwNot _ -> ppPrefix "~" Cast _ _ -> ppPrefix "(cast)" - GetField (Struct _) _ f -> \e -> ppInfix "#" e (text $ accessorname f) - GetField _ _ _ -> impossible "ppOp1" "Copilot.Core.PrettyPrint" + GetField (Struct _) _ f -> \e -> ppInfix "#" e (text $ accessorName f) + GetField _ _ _ -> impossible "ppOp1" "Copilot.PrettyPrint" -- | Pretty-print a binary operation. ppOp2 :: Op2 a b c -> Doc -> Doc -> Doc @@ -104,7 +99,10 @@ ppOp2 op = case op of BwXor _ -> ppInfix "^" BwShiftL _ _ -> ppInfix "<<" BwShiftR _ _ -> ppInfix ">>" - Index _ -> ppInfix ".!!" + Index _ -> ppInfix "!" + UpdateField (Struct _) _ f -> \ doc1 doc2 -> + parens $ doc1 <+> text "##" <+> text (accessorName f) <+> text "=:" <+> doc2 + UpdateField _ _ _ -> impossible "ppOp2" "Copilot.PrettyPrint" -- | Pretty-print a ternary operation. ppOp3 :: Op3 a b c d -> Doc -> Doc -> Doc -> Doc @@ -113,8 +111,8 @@ ppOp3 op = case op of text "(if" <+> doc1 <+> text "then" <+> doc2 <+> text "else" <+> doc3 <> text ")" - --------------------------------------------------------------------------------- + UpdateArray _ -> \ doc1 doc2 doc3 -> + parens $ doc1 <+> text "!!" <+> doc2 <+> text "=:" <+> doc3 -- | Parenthesize two 'Doc's, separated by an infix 'String'. ppInfix :: String -> Doc -> Doc -> Doc @@ -124,8 +122,6 @@ ppInfix cs doc1 doc2 = parens $ doc1 <+> text cs <+> doc2 ppPrefix :: String -> Doc -> Doc ppPrefix cs = (text cs <+>) --------------------------------------------------------------------------------- - -- | Pretty-print a Copilot stream as a case of a top-level function for -- streams of that type, by pattern matching on the stream name. ppStream :: Stream -> Doc @@ -146,8 +142,6 @@ ppStream <+> text "++" <+> ppExpr e --------------------------------------------------------------------------------- - -- | Pretty-print a Copilot trigger as a case of a top-level @trigger@ -- function, by pattern matching on the trigger name. ppTrigger :: Trigger -> Doc @@ -164,8 +158,6 @@ ppTrigger map (\a -> text "arg" <+> ppUExpr a) args)) $$ nest 2 rbrack --------------------------------------------------------------------------------- - -- | Pretty-print a Copilot observer as a case of a top-level @observer@ -- function, by pattern matching on the observer name. ppObserver :: Observer -> Doc @@ -177,20 +169,21 @@ ppObserver <+> text "=" <+> ppExpr e --------------------------------------------------------------------------------- - -- | Pretty-print a Copilot property as a case of a top-level @property@ -- function, by pattern matching on the property name. ppProperty :: Property -> Doc ppProperty Property { propertyName = name - , propertyExpr = e } + , propertyProp = p } = text "property \"" <> text name <> text "\"" <+> text "=" - <+> ppExpr e + <+> ppProp p --------------------------------------------------------------------------------- +-- | Pretty-print a Copilot proposition. +ppProp :: Prop -> Doc +ppProp (Forall e) = text "forall" <+> parens (ppExpr e) +ppProp (Exists e) = text "exists" <+> parens (ppExpr e) -- | Pretty-print a Copilot specification, in the following order: -- @@ -206,10 +199,6 @@ ppSpec spec = cs $$ ds $$ es $$ fs es = foldr (($$) . ppObserver) empty (specObservers spec) fs = foldr (($$) . ppProperty) empty (specProperties spec) --------------------------------------------------------------------------------- - -- | Pretty-print a Copilot specification. prettyPrint :: Spec -> String prettyPrint = render . ppSpec - --------------------------------------------------------------------------------- diff --git a/copilot-core/src/Copilot/Core/Error.hs b/copilot-prettyprinter/src/Copilot/PrettyPrint/Error.hs similarity index 82% rename from copilot-core/src/Copilot/Core/Error.hs rename to copilot-prettyprinter/src/Copilot/PrettyPrint/Error.hs index 0debccdf9..1c1fce024 100644 --- a/copilot-core/src/Copilot/Core/Error.hs +++ b/copilot-prettyprinter/src/Copilot/PrettyPrint/Error.hs @@ -1,11 +1,9 @@ --------------------------------------------------------------------------------- -- Copyright © 2011 National Institute of Aerospace / Galois, Inc. --------------------------------------------------------------------------------- {-# LANGUAGE Safe #-} -- | Custom functions to report error messages to users. -module Copilot.Core.Error +module Copilot.PrettyPrint.Error ( impossible , badUsage ) where diff --git a/copilot-core/src/Copilot/Core/Type/Show.hs b/copilot-prettyprinter/src/Copilot/PrettyPrint/Type.hs similarity index 67% rename from copilot-core/src/Copilot/Core/Type/Show.hs rename to copilot-prettyprinter/src/Copilot/PrettyPrint/Type.hs index 95930bb7b..2f6f95f07 100644 --- a/copilot-core/src/Copilot/Core/Type/Show.hs +++ b/copilot-prettyprinter/src/Copilot/PrettyPrint/Type.hs @@ -1,48 +1,39 @@ --------------------------------------------------------------------------------- -- Copyright © 2011 National Institute of Aerospace / Galois, Inc. --------------------------------------------------------------------------------- -{-# LANGUAGE Safe #-} -{-# LANGUAGE ExistentialQuantification, GADTs #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE Safe #-} -- | Show Copilot Core types and typed values. -module Copilot.Core.Type.Show - ( ShowWit (..) - , showWit - , showWithType +module Copilot.PrettyPrint.Type + ( showWithType , ShowType(..) , showType ) where import Copilot.Core.Type --------------------------------------------------------------------------------- - --- | Witness datatype for showing a value, used by 'showWithType'. -data ShowWit a = Show a => ShowWit - --------------------------------------------------------------------------------- +-- Are we proving equivalence with a C backend, in which case we want to show +-- Booleans as '0' and '1'. --- | Turn a type into a show witness. -{-# DEPRECATED showWit "This function is deprecated in Copilot 3.4." #-} -showWit :: Type a -> ShowWit a -showWit t = - case t of - Bool -> ShowWit - Int8 -> ShowWit - Int16 -> ShowWit - Int32 -> ShowWit - Int64 -> ShowWit - Word8 -> ShowWit - Word16 -> ShowWit - Word32 -> ShowWit - Word64 -> ShowWit - Float -> ShowWit - Double -> ShowWit - Array t -> ShowWit - Struct t -> ShowWit +-- | Target language for showing a typed value. Used to adapt the +-- representation of booleans. +data ShowType = C | Haskell --------------------------------------------------------------------------------- +-- | Show a value. The representation depends on the type and the target +-- language. Booleans are represented differently depending on the backend. +showWithType :: ShowType -> Type a -> a -> String +showWithType showT t x = + case showT of + C -> case t of + Bool -> if x then "1" else "0" + _ -> sw + Haskell -> case t of + Bool -> if x then "true" else "false" + _ -> sw + where + sw = case showWit t of + ShowWit -> show x -- | Show Copilot Core type. showType :: Type a -> String @@ -62,30 +53,25 @@ showType t = Array t -> "Array " ++ showType t Struct t -> "Struct" --------------------------------------------------------------------------------- +-- * Auxiliary show instance --- Are we proving equivalence with a C backend, in which case we want to show --- Booleans as '0' and '1'. - --- | Target language for showing a typed value. Used to adapt the --- representation of booleans. -data ShowType = C | Haskell - --------------------------------------------------------------------------------- - --- | Show a value. The representation depends on the type and the target --- language. Booleans are represented differently depending on the backend. -showWithType :: ShowType -> Type a -> a -> String -showWithType showT t x = - case showT of - C -> case t of - Bool -> if x then "1" else "0" - _ -> sw - Haskell -> case t of - Bool -> if x then "true" else "false" - _ -> sw - where - sw = case showWit t of - ShowWit -> show x +-- | Witness datatype for showing a value, used by 'showWithType'. +data ShowWit a = Show a => ShowWit --------------------------------------------------------------------------------- +-- | Turn a type into a show witness. +showWit :: Type a -> ShowWit a +showWit t = + case t of + Bool -> ShowWit + Int8 -> ShowWit + Int16 -> ShowWit + Int32 -> ShowWit + Int64 -> ShowWit + Word8 -> ShowWit + Word16 -> ShowWit + Word32 -> ShowWit + Word64 -> ShowWit + Float -> ShowWit + Double -> ShowWit + Array t -> ShowWit + Struct t -> ShowWit diff --git a/copilot-theorem/CHANGELOG b/copilot-theorem/CHANGELOG index bf4c54f52..0207c5446 100644 --- a/copilot-theorem/CHANGELOG +++ b/copilot-theorem/CHANGELOG @@ -1,4 +1,137 @@ -2021-09-16 +2026-11-07 + * Version bump (4.8.2). (#792) + +2026-09-07 + * Version bump (4.8.1). (#760) + * Remove unnecessary extension. (#733) + +2026-07-07 + * Version bump (4.8). (#745) + * Extend range of versions of Kind2. (#734) + +2026-05-07 + * Version bump (4.7.1). (#730) + * Handle special Float values correctly for counterexamples. (#697) + * Update examples to compile with copilot-theorem >= 3.0. (#692) + +2026-03-07 + * Version bump (4.7). (#714) + +2026-01-07 + * Version bump (4.6.1). (#705) + * Relax version constraint on containers, random. (#603) + +2025-11-07 + * Version bump (4.6). (#679) + +2025-09-07 + * Version bump (4.5.1). (#666) + * Remove unused function Copilot.Theorem.Misc.SExpr.parseSExpr. (#661) + +2025-07-07 + * Version bump (4.5). (#642) + * Removed unused pragmas. (#613) + * Relax version constraint on what4. (#611) + +2025-05-07 + * Version bump (4.4). (#618) + * Translate quantifiers correctly in Kind2 backend. (#594) + +2025-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 @@ -11,18 +144,18 @@ * Version bump (3.4). (#231) 2021-05-07 - * Version bump (3.3). (#217). - * Adjust contraints on version of what4. (#90). + * 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). + * Version bump (3.2.1). (#92) + * Completed the documentation. (#95, #93) 2020-12-06 - * Version bump (3.2). - * Update description, bug-reports and homepage field in cabal file - (#97). + * Version bump (3.2). (#65) + * Update description, bug-reports and homepage field in cabal file. + (#97) -2019-11-22 Ivan Perez - * Version bump (3.1). - * Remove ExternFun (#99). +2019-11-22 + * Version bump (3.1). (#46) + * Remove ExternFun. (#99) diff --git a/copilot-theorem/README.md b/copilot-theorem/README.md index 4d75004b3..47a4b6081 100644 --- a/copilot-theorem/README.md +++ b/copilot-theorem/README.md @@ -4,7 +4,7 @@ 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. +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: @@ -17,9 +17,9 @@ properties on Copilot programs. It includes: proving basic k-inductive properties and for pedagogical purposes. * A prover producing native inputs for the *Kind2* model checker, developed at - 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 + 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 @@ -28,25 +28,24 @@ properties on Copilot programs. It includes: *copilot-theorem* needs the following dependencies to be installed: -* The *copilot-core* and *copilot-language* Haskell libraries +* 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` +* The *Kind2* model checker (version 1.0 or newer): `kind2` must be in your + `$PATH` -To build it, just clone this repository and use `cabal install`. You will find -some examples in the `examples` folder, which can be built with `cabal install` -too, producing an executable `copilot-theorem-example` in your `.cabal/bin` -folder. +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 which express the idea that +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 latters are out of the scope of *copilot-theorem*. +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 @@ -58,131 +57,40 @@ For instance, here is a straightforward specification declaring one property: ```haskell spec :: Spec spec = do - prop "gt0" (x > 0) + 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 :: -Prover -> ProofScheme -> Spec -> IO ()` function exported by `Copilot.Theorem`. +Copilot.Core.Spec.Spec -> String -> UProof -> IO Bool` function exported by +`Copilot.Theorem`. This function takes three arguments: -* The prover we want to use. For now, two provers are available, exported by - the `Copilot.Theorem.Light` and `Copilot.Theorem.Kind2` module. -* A *proof scheme*, which is a sequence of instructions like *check*, *assume*, - *assert*... -* The Copilot specification +* A reified Copilot.Language.Spec. +* The name of the proposition we want to check. +* A strategy to prove the proposition. -Here, we can just write +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 -prove (lightProver def) (check "gt0") spec +main = do + spec' <- reify spec + prove spec' "gt0" (tell [Check $ kind2Prover def]) ``` -where `lightProver def` stands for the *light prover* with default +where `kind2Prover def` stands for the *Kind2 prover* with the default configuration. -### The Prover interface - -The `Copilot.Theorem.Prover` defines a general interface for provers. Therefore, -it is really easy to add a new prover by creating a new object of type -`Prover`. The latter is defined like this: - -```haskell -data Cex = Cex - -type Infos = [String] - -data Output = Output Status Infos - -data Status - = Valid - | Invalid (Maybe Cex) - | Unknown - | Error - -data Feature = GiveCex | HandleAssumptions - -data Prover = forall r . Prover - { proverName :: String - , hasFeature :: Feature -> Bool - , startProver :: Core.Spec -> IO r - , askProver :: r -> [PropId] -> PropId -> IO Output - , closeProver :: r -> IO () - } -``` - -Each prover mostly has to provide a `askProver` function which takes as an -argument -* The prover descriptor -* A list of assumptions -* A conclusion - -and checks if the assumptions logically entail the conclusion. - -Two provers are provided by default: `Light` and `Kind2`. - -#### The light prover - -The *light prover* is a really simple prover which uses the Yices SMT solver -with the `QF_UFLIA` theory and is limited to prove *k-inductive* properties, -that is properties such that there exists some *k* such that: - -* The property holds during the first *k* steps of the algorithm. -* From the hypothesis the property has held during *k* consecutive steps, we - can prove it is still true one step further. - -For instance, in this example - -```haskell -spec :: Spec -spec = do - prop "gt0" (x > 0) - prop "neq0" (x /= 0) - where - x = [1] ++ (1 + x) -``` -the property `"gt0"` is inductive (1-inductive) but the property `"neq0"` is -not. - - -The *light prover* is defined in `Copilot.Theorem.Light`. This module exports the -`lightProver :: Options -> Prover` function which builds a prover from a record -of type `Options` : - -```haskell -data Options = Options - { kTimeout :: Integer - , onlyBmc :: Bool - , debugMode :: Bool } -``` - -Here, - -* `kTimeout` is the maximum number of steps of the k-induction algorithm the - prover executes before giving up. -* If `onlyBmc` is set to `True`, the prover will only search for - counterexamples and won't try to prove the properties discharged to it. -* If `debugMode` is set to `True`, the SMTLib queries produced by the prover - are displayed in the standard output. - -`Options` is an instance of the `Data.Default` typeclass: - -```haskell -instance Default Options where - def = Options - { kTimeout = 100 - , debugMode = False - , onlyBmc = False } -``` - -Therefore, `def` stands for the default configuration. - #### The Kind2 prover -The *Kind2* prover uses the model checker with the same name, from Iowa -university. It translates the Copilot specification into a *modular transition -system* (the Kind2 native format) and then calls the `kind2` executable. +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. Kind2 version 1.0 or newer is required: the native input format +and the command-line options used by this prover were introduced in Kind2 +1.0, and remain supported as of Kind2 3.0. It is provided by the `Copilot.Theorem.Kind2` module, which exports a `kind2Prover :: Options -> Prover` where the `Options` type is defined as @@ -190,73 +98,13 @@ It is provided by the `Copilot.Theorem.Kind2` module, which exports a `kind2Prov ```haskell data Options = Options { bmcMax :: Int } ``` -and where `bmcMax` corresponds to the `--bmc_max` option of *kind2* and is -equivalent to the `kTimeout` option of the light prover. Its default value is +and where `bmcMax` corresponds to the `--unroll_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. -#### Combining provers - -The `combine :: Prover -> Prover -> Prover` function lets you merge two provers -A and B into a prover C which launches both A and B and returns the *most -precise* output. It would be interesting to implement other merging behaviours -in the future. For instance, a *lazy* one such that C launches B only if A has -returns *unknown* or *error*. - -As an example, the following prover is used in `Driver.hs`: - -```haskell -prover = - lightProver def {onlyBmc = True, kTimeout = 5} - `combine` kind2Prover def -``` - -We will discuss the internals and the experimental results of these provers -later. - -### Proof schemes - -Let's consider again this example: - -```haskell -spec :: Spec -spec = do - prop "gt0" (x > 0) - prop "neq0" (x /= 0) - where - x = [1] ++ (1 + x) -``` - -and let's say we want to prove `"neq0"`. Currently, the two available solvers -fail at showing this non-inductive property (we will discuss this limitation -later). Therefore, we can prove the more general inductive lemma `"gt0"` and -deduce our main goal from this. For this, we use the proof scheme - -```haskell -assert "gt0" >> check "neq0" -``` -instead of just `check "neq0"`. A proof scheme is chain of primitives schemes -glued by the `>>` operator. For now, the available primitives are: - -* `check "prop"` checks whether or not a given property is true in the current - context. -* `assume "prop"` adds an assumption in the current context. -* `assert "prop"` is a shortcut for `check "prop" >> assume "prop"`. -* `assuming :: [PropId] -> ProofScheme -> ProofScheme` is such that `assuming - props scheme` assumes the list of properties *props*, executes the proof - scheme *scheme* in this context, and forgets the assumptions. -* `msg "..."` displays a string in the standard output - -We will discuss the limitations of this tool and a way to use it in practice -later. - ### Some examples -Some examples are in the *examples* folder. The `Driver.hs` contains the `main` -function to run any example. Each other example file exports a specification -`spec` and a proof scheme `scheme`. You can change the example being run just -by changing one *import* directive in `Driver.hs`. - -These examples include: +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 @@ -273,7 +121,7 @@ These examples include: ### 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 in a self sufficient +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. @@ -288,8 +136,8 @@ 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]. The *light - prover* works with this format. + 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 @@ -303,16 +151,13 @@ contains at least * `PrettyPrint.hs` for pretty printing (useful for debugging) * `Translate.hs` where the translation process from `Core.Spec` is defined. -These three formats share a simplified set of types and operators, defined -respectively in `Misc.Type` and `Misc.Operator`. - ##### An example The following program: ```haskell spec = do - prop "pos" (fib > 0) + void $ prop "pos" (forAll $ fib > 0) where fib :: Stream Word64 @@ -375,90 +220,16 @@ 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-corectness of the specification, in the same spirit it is done in the -other Copilot libraries. *copilot-theorem* handles only three types which are -`Integer`, `Real` and `Bool` and which are handled by the SMTLib standard. +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 rules of translation between Copilot types and *copilot-theorem* types are -defined in `Misc/Cast`. - -#### Operators - -The operators provided by `Misc.Operator` mostly consists in boolean -connectors, linear operators, equality and inequality operators. If other -operators are used in the Copilot program, they are handled using -non-determinism or uninterpreted functions. - -The file `CoreUtils/Operators` contains helper functions to translate Copilot -operators into *copilot-theorem* operators. - - -#### The Light prover - -As said in the tutorial, the *light prover* is a simple tool implementing the -basic *k-induction* algorithm [1]. The `Light` directory contains three files: - -* `Prover.hs`: the prover and the *k-induction* algorithm are implemented in - this file. -* `SMT.hs` contains some functions to interact with the Yices SMT provers. -* `SMTLib.hs` is a set of functions to output SMTLib directives. It uses the - `Misc.SExpr` module to deal with S-expressions. - -The code is both concise and simple and should be worth a look. - -The prover first translates the copilot specification into the *IL* format. -This translation is implemented in `IL.Translate`. It is straightforward as the -*IL* format does not differ a lot from the *copilot core* format. This is the -case because the reification process has transformed the copilot program such -that the `++` operator only occurs at the top of a stream definition. -Therefore, each stream definition directly gives us a recurrence equation and -initial conditions for the associated sequence. - -The translation process mostly: - -* converts the types and operators, using uninterpreted functions to handle - non-linear operators and external functions. -* creates a sequence for each stream, local stream ands external stream. - -The reader is invited to use the *light prover* on the examples with `debugMode -= true`, in order to have a look at the SMTLib code produced. For instance, if -we check the property `"pos"` on the previous example involving the Fibonacci -sequence, we get: - -``` - (set-logic QF_UFLIA) - (declare-fun n () Int) - (declare-fun s0 (Int) Int) - (assert (= (s0 (+ n 2)) (+ (s0 (+ n 0)) (s0 (+ n 1))))) - (assert (= (s0 (+ n 3)) (+ (s0 (+ n 1)) (s0 (+ n 2))))) - (assert (> (s0 (+ n 0)) 0)) - (push 1) - (assert (or false (not (> (s0 (+ n 1)) 0)))) - (check-sat) - (pop 1) - (assert (= (s0 (+ n 4)) (+ (s0 (+ n 2)) (s0 (+ n 3))))) - (assert (> (s0 (+ n 1)) 0)) - (push 1) - (assert (or false (not (> (s0 (+ n 2)) 0)))) - (check-sat) -unsat - (pop 1) -``` - -Here, we just kept the outputs related to the `` psolver, which is the -solver trying to prove the *continuation step*. - -You can see that the SMT solver is used in an incremental way (`push` and `pop` -instructions), so we don't need to restart it at each step of the algorithm -(see [2]). - - #### The Kind2 prover -The *Kind2 prover* first translates the copilot specification into a *modular +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` @@ -467,7 +238,7 @@ this process. ##### Modular transition systems -Let's look at the definition of a *modular transition systems*, in the +Let's look at the definition of a *modular transition system*, in the `TransSys.Spec` module: ```haskell @@ -528,10 +299,10 @@ types of variables: ##### The translation process -First, a copilot specification is translated into a modular transition system. +First, a Copilot specification is translated into a modular transition system. This process is defined in the `TransSys.Translate` module. 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* +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: @@ -567,16 +338,21 @@ process. 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. +file format*. The native input format of Kind2 (version 1.0 and newer) does +not support predicate calls inside the initial state and transition relation +predicates of a node, so the modular structure of the transition system cannot +be expressed directly in it. Therefore, the system is first turned into an +equivalent non-modular transition system with only one node by the +`inline :: Spec -> Spec` function, defined in `TransSys.Transform`: +```haskell +inline :: Spec -> Spec +inline spec = mergeNodes [nodeId n | n <- specNodes spec] spec +``` -This function relies on the `mergeNodes :: [NodeId] -> Spec -> Spec` function -which signature is self-explicit. The latter solves name conflicts by using the -`Misc.Renaming` monad. Some code complexity has been added so the variable -names remains as clear as possible after merging two nodes. +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 @@ -587,7 +363,7 @@ 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 +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 @@ -607,7 +383,7 @@ 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: +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`. @@ -615,17 +391,17 @@ 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 organized in two categories: the limitations related to the -Copilot language itself and its implementation, and the limitations related to -the model-checking techniques we are using. +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 looses many -informations 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 occurences will be inlined. Moreover, let's look at the -`intCounter` function defined in the example `Grey.hs`: +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 @@ -646,8 +422,8 @@ There are many problems with this: * 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 -inconvenients as these informations are lost by GHC itself before it occurs. -The only solution we can see would be to use *Template Haskell* to generate +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. @@ -656,7 +432,7 @@ introduced. ##### 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 softwares are +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. @@ -666,34 +442,34 @@ 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 fo *Kind2* are often too weak. Some +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 a near future. +made in this area in the near future. -A workaround to this problem would be to write kind of 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 +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 technicity. +requires a high level of technical knowledge. ##### Limitations related to the SMT solvers -The use of SMT solvers introduces two kind of limitations: +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 *light prover*, Yices2 does not terminate. However, the *z3* +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 *light prover* uses uninterpreted functions for encoding streams instead -of simple integer variables, which is the case when the copilot program is +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 -*light prover* still terminates instantaneously on the `BoyerMoore` example, +*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 @@ -705,12 +481,11 @@ 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 which is +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 by -*bounded* universal quantification by assuming all the elements of the input -stream are in the finite list `allowed` and using the function `forAllCst` -defined in `Copilot.Kind.Lib`: +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 @@ -721,13 +496,13 @@ forAllCst l f = conj $ map (f . constant) l ``` However, this solution isn't completely satisfying because the size of the -property generated is proportionnal to the cardinal of `allowed`. +property generated is proportional to the length of `allowed`. #### Some scalability issues -A standard way to prove large programs is to rely on its logical structure by -writing a specification for each of its functions. This very natural approach -is hard to follow in our case because of +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 @@ -737,7 +512,7 @@ is hard to follow in our case because of 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. +complete specification for large-scale programs. ## Future work @@ -746,19 +521,23 @@ complete specification for large scale programs. These features are not currently provided due to the lack of important features in the Kind2 SMT solver. -#### Counterexamples displaying +#### 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 counterexamples displaying in *copilot-theorem*. For -this, we recommend to keep some informations about *observers* in -`TransSys.Spec` and to add one variable per observer in the Kind2 output file. +support the output of counterexamples for systems expressed in its native input +format (the counterexample printing functions in Kind2's +[`src/inputSystem.ml`](https://github.com/kind2-mc/kind2/blob/v3.0.0/src/inputSystem.ml) +fail with an internal error for native input). If Kind2 adds this feature, 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 of uninterpreted functions in the Kind2 native format. A -good way to handle these would be to use uninterpreted functions. With this +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 @@ -767,7 +546,7 @@ 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* fail with the last example, as the results of +Currently, the *Kind2 prover* fails with the last example, as the results of unknown functions are turned into fresh unconstrained variables. ### Simple extensions @@ -776,20 +555,11 @@ 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 the [1]). + (*Counterexample To The Inductiveness*, see [1]). + Use Template Haskell to declare automatically some observers with the same names used in the original program. -### Refactoring suggestions - -+ Implement a cleaner way to deal with arbitrary streams and arbitrary - constants by extending the `Copilot.Core.Expr type`. See the - `Copilot.Kind.Lib` module to observe how inelegant the current solution is. - -+ Use `Cnub` as an intermediary step in the translation from `Core.Spec` to - `IL.Spec` and `TransSys.Spec`. - ### More advanced enhancements + Enhance the proof scheme system such that when proving a property depending @@ -802,37 +572,29 @@ architecture of Kind2. - Declare assumptions and invariants next to the associated code instead of gathering all properties in a single place. - - Declare a frequent code pattern which should be factorized in the - transition problem (see the section about Copilot limitations) + - Declare a frequent code pattern that can be factorized in the transition + problem (see the section about Copilot limitations) ## FAQ -### Why does the light prover not deliver counterexamples ? - -The problem is the light prover is using uninterpreted functions to represent -streams and Yices2 can't give you values for uninterpreted functions when you -ask it for a valid assignment. Maybe we could get better performances and -easily counterexample display if we rewrite the *light prover* so that it works -with *transition systems* instead of *IL*. - -### Why does the code related to transition systems look so complex ? +### Why does the code related to transition systems look so complex? -It is true 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. +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* node. 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 parametrized streams like Lustre does and - everything is inlined during the reification process). +* Each node 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 structure informations. +* 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 diff --git a/copilot-theorem/copilot-theorem.cabal b/copilot-theorem/copilot-theorem.cabal index 69d68b80e..da29f566a 100644 --- a/copilot-theorem/copilot-theorem.cabal +++ b/copilot-theorem/copilot-theorem.cabal @@ -14,7 +14,7 @@ description: . -version : 3.5 +version : 4.8.2 license : BSD3 license-file : LICENSE maintainer : Ivan Perez @@ -28,51 +28,43 @@ extra-source-files : README.md 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 -fwarn-tabs + ghc-options : -Wall -fno-warn-name-shadowing -fno-warn-unused-binds -fno-warn-missing-signatures -fcontext-stack=100 - -- -fpackage-trust - -- -trust=array - -- -trust=base - -- -trust=containers - -- -- -trust=copilot-core - -- -trust=directory - -- -- -trust=exceptions - -- -trust=process - -- -- -trust=random - -- -trust=unix - -- -- -trust=parsec - -- -trust=bytestring - -- -- -trust=text - - build-depends : base >= 4.9 && < 5 - , ansi-terminal >= 0.8 && < 0.10 - , bimap >= 0.3 && < 0.4 - , bv-sized >= 1.0.2 && < 1.1 - , containers >= 0.4 && < 0.7 - , data-default >= 0.7 && < 0.8 - , directory >= 1.3 && < 1.4 - , filepath >= 1.4.2 && < 1.5 - , libBF >= 0.6.2 && < 0.7 - , mtl >= 2.0 && < 2.3 - , 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.2 - , transformers >= 0.5 && < 0.6 - , xml >= 1.3 && < 1.4 - , what4 >= 1.1 && < 1.2 - - , copilot-core >= 3.5 && < 3.6 + 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.9 + , data-default >= 0.7 && < 0.9 + , directory >= 1.3 && < 1.4 + , extra >= 1.7 && < 1.9 + , fp-ieee >= 0.1 && < 0.2 + , libBF >= 0.6.2 && < 0.7 + , mtl >= 2.0 && < 2.4 + , panic >= 0.4.0 && < 0.5 + , parameterized-utils >= 2.1.1 && < 2.2 + , pretty >= 1.0 && < 1.2 + , process >= 1.6 && < 1.7 + , random >= 1.1 && < 1.4 + , transformers >= 0.5 && < 0.7 + , what4 >= 1.3 && < 1.8 + + , copilot-core >= 4.8.2 && < 4.9 + , copilot-prettyprinter >= 4.8.2 && < 4.9 exposed-modules : Copilot.Theorem , Copilot.Theorem.Prove @@ -115,3 +107,33 @@ library , 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 diff --git a/copilot-theorem/examples/BoyerMoore.hs b/copilot-theorem/examples/BoyerMoore.hs index 5c213a2ba..47fe790af 100644 --- a/copilot-theorem/examples/BoyerMoore.hs +++ b/copilot-theorem/examples/BoyerMoore.hs @@ -1,15 +1,13 @@ --------------------------------------------------------------------------------- - -{-# LANGUAGE RebindableSyntax, ScopedTypeVariables #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} module BoyerMoore where import Copilot.Language hiding (length) import Copilot.Theorem -import Copilot.Theorem.Prover.Z3 +import Copilot.Theorem.Prover.SMT (debug, def, induction, z3) import Copilot.Core.Type -import Copilot.Core.Type.Uninitialized import Prelude () import Control.Monad (forM_) @@ -18,8 +16,6 @@ import Data.String (fromString) import qualified Prelude as P import qualified Data.List as L --------------------------------------------------------------------------------- - length :: [a] -> Stream Word8 length l = constant (fromInteger $ L.genericLength l) @@ -32,8 +28,6 @@ arbitraryCst s = c i = extern s Nothing c = if t == 0 then i else [uninitialized (typeOf :: Type a)] ++ c --------------------------------------------------------------------------------- - majorityVote :: forall a . (Typed a, Eq a) => [Stream a] -> Stream a majorityVote [] = error "empty list" majorityVote (x : xs) = aux x 1 xs @@ -45,7 +39,6 @@ majorityVote (x : xs) = aux x 1 xs local (if s == 0 || l == p then s + 1 else s - 1) $ \s' -> aux p' s' ls - okWith :: forall a . (Typed a, Eq a) => Stream a -> [Stream a] -> Stream a -> Stream Bool @@ -56,16 +49,14 @@ okWith a l maj = (a /= maj) ==> ((2 * count a l) <= length l) count _e [] = 0 count e (x : xs) = (if x == e then 1 else 0) + count e xs --------------------------------------------------------------------------------- - spec = do forM_ (zip [1..] ss) $ \(k :: Int, s) -> observer ((P.++) "s" (show k)) s observer "maj" maj - i1 <- prop "i1" (forall $ s1 == 1 && s2 == 1 && s3 == 1 && s4 == 1) - theorem "r1" (forall $ maj == 1) $ assume i1 >> induct - theorem "OK" (forall $ okWith (arbitraryCst "n") ss maj) induct + i1 <- prop "i1" (forAll $ s1 == 1 && s2 == 1 && s3 == 1 && s4 == 1) + theorem "r1" (forAll $ maj == 1) $ assume i1 >> induct + theorem "OK" (forAll $ okWith (arbitraryCst "n") ss maj) induct where s1 = externW8 "s1" (Just $ repeat 1) @@ -79,8 +70,23 @@ spec = do maj = majorityVote ss --------------------------------------------------------------------------------- - induct :: Proof Universal -induct = induction def { nraNLSat = False, debug = False } - +induct = induction def { debug = False } z3 + +-- | Initial value for a given type. +-- +-- Does not support structs or arrays. +uninitialized :: Type a -> a +uninitialized t = + case t of + Bool -> False + Int8 -> 0 + Int16 -> 0 + Int32 -> 0 + Int64 -> 0 + Word8 -> 0 + Word16 -> 0 + Word32 -> 0 + Word64 -> 0 + Float -> 0 + Double -> 0 diff --git a/copilot-theorem/examples/Grey.hs b/copilot-theorem/examples/Grey.hs index 184ce4c90..91500ba1a 100644 --- a/copilot-theorem/examples/Grey.hs +++ b/copilot-theorem/examples/Grey.hs @@ -4,7 +4,7 @@ module Grey where import Copilot.Language import Copilot.Theorem -import Copilot.Theorem.Prover.Z3 +import Copilot.Theorem.Prover.SMT (Options (..), def, induction, kInduction, z3) import Prelude () import Data.String (fromString) @@ -15,7 +15,6 @@ intCounter reset = time time = if reset then 0 else [0] ++ if time == 3 then 0 else time + 1 - greyTick :: Stream Bool -> Stream Bool greyTick reset = a && b where @@ -23,8 +22,8 @@ greyTick reset = a && b b = (not reset) && ([False] ++ a) spec = do - theorem "iResetOk" (forall $ r ==> (ic == 0)) induct - theorem "eqCounters" (forall $ it == gt) $ kinduct 3 + theorem "iResetOk" (forAll $ r ==> (ic == 0)) induct + theorem "eqCounters" (forAll $ it == gt) $ kinduct 3 where ic = intCounter r @@ -33,7 +32,7 @@ spec = do r = extern "reset" Nothing induct :: Proof Universal -induct = induction def { nraNLSat = False, debug = False } +induct = induction def { debug = False } z3 kinduct :: Word32 -> Proof Universal -kinduct k = kInduction def { nraNLSat = False, startK = k, maxK = k, debug = False } +kinduct k = kInduction def { startK = k, maxK = k, debug = False } z3 diff --git a/copilot-theorem/examples/Incr.hs b/copilot-theorem/examples/Incr.hs index 3e392cc4b..dd6ccdc42 100644 --- a/copilot-theorem/examples/Incr.hs +++ b/copilot-theorem/examples/Incr.hs @@ -4,16 +4,16 @@ import Prelude () import Copilot.Language import Copilot.Theorem -import Copilot.Theorem.Prover.Z3 +import Copilot.Theorem.Prover.SMT (debug, def, induction, z3) spec = do - bounds <- prop "bounds" (forall $ x < 255) - theorem "gt1" (forall $ x > 1) (assume bounds >> induct) - theorem "neq0" (forall $ x /= 0) (assume bounds >> induct) + bounds <- prop "bounds" (forAll $ x < 255) + theorem "gt1" (forAll $ x > 1) (assume bounds >> induct) + theorem "neq0" (forAll $ x /= 0) (assume bounds >> induct) where x :: Stream Word8 x = [2] ++ (1 + x) induct :: Proof Universal -induct = induction def { nraNLSat = False, debug = True } +induct = induction def { debug = True } z3 diff --git a/copilot-theorem/examples/SerialBoyerMoore.hs b/copilot-theorem/examples/SerialBoyerMoore.hs index f8a2e69c3..eb858a6a6 100644 --- a/copilot-theorem/examples/SerialBoyerMoore.hs +++ b/copilot-theorem/examples/SerialBoyerMoore.hs @@ -1,17 +1,14 @@ --------------------------------------------------------------------------------- {-# LANGUAGE RebindableSyntax #-} module SerialBoyerMoore where import Copilot.Language import Copilot.Theorem -import Copilot.Theorem.Prover.Z3 +import Copilot.Theorem.Prover.SMT (Options (..), def, induction, kInduction, z3) import Prelude () import Data.String (fromString) --------------------------------------------------------------------------------- - conj :: [Stream Bool] -> Stream Bool conj = foldl (&&) true @@ -36,7 +33,8 @@ majority l = (p, s, j) k = [0] ++ (1 + k) count m = cnt - where cnt = [0] ++ if l == m then cnt + 1 else cnt + where + cnt = [0] ++ if l == m then cnt + 1 else cnt j = forAllCst allowed $ \m -> local (count m) $ \cnt -> @@ -50,18 +48,15 @@ spec = do observer "s" s observer "j" j - inRange <- prop "inRange" (forall $ input < 3) - theorem "J" (forall j) $ assume inRange >> induct + inRange <- prop "inRange" (forAll $ input < 3) + theorem "J" (forAll j) $ assume inRange >> induct where input = externW64 "in" (Just [1, 1, 2, 1, 2, 2, 1, 2, 2, 1, 2, 1]) (p, s, j) = majority input - --------------------------------------------------------------------------------- - induct :: Proof Universal -induct = induction def { nraNLSat = False, debug = False } +induct = induction def { debug = False } z3 kinduct :: Word32 -> Proof Universal -kinduct k = kInduction def { nraNLSat = False, startK = k, maxK = k, debug = False } +kinduct k = kInduction def { startK = k, maxK = k, debug = False } z3 diff --git a/copilot-theorem/examples/SphericalWCV.hs b/copilot-theorem/examples/SphericalWCV.hs index f690c46f8..06d203adf 100644 --- a/copilot-theorem/examples/SphericalWCV.hs +++ b/copilot-theorem/examples/SphericalWCV.hs @@ -8,7 +8,7 @@ import Prelude () import Copilot.Language import Copilot.Language.Reify import Copilot.Theorem -import Copilot.Theorem.Prover.Z3 +import Copilot.Theorem.Prover.SMT (debug, def, onlySat, onlyValidity, z3) import qualified Copilot.Language.Operators.Propositional as P @@ -41,12 +41,13 @@ tcoathr = extern "tcoathr" Nothing spherical2xyz :: Stream Double -> Stream Double -> Vect3 spherical2xyz lat lon = (x, y, z) - where r = 6371000 -- Radius of the earth in meters - theta = pi / 2 - lat - phi = pi - lon - x = r * sin theta * cos phi - y = r * sin theta * sin phi - z = r * cos theta + where + r = 6371000 -- Radius of the earth in meters + theta = pi / 2 - lat + phi = pi - lon + x = r * sin theta * cos phi + y = r * sin theta * sin phi + z = r * cos theta dot3 :: Vect3 -> Vect3 -> Stream Double dot3 (x1, y1, z1) (x2, y2, z2) = x1 * x2 + y1 * y2 + z1 * z2 @@ -65,7 +66,8 @@ vect3_orthog_toz v = v `cross3` vect3_orthog_toy v unit :: Vect3 -> Vect3 unit (x, y, z) = (x / n, y / n, z / n) - where n = norm3 (x, y, z) + where + n = norm3 (x, y, z) vect3_orthonorm_toy :: Vect3 -> Vect3 vect3_orthonorm_toy = unit . vect3_orthog_toy @@ -75,8 +77,9 @@ vect3_orthonorm_toz = unit . vect3_orthog_toz sphere_to_2D_plane :: Vect3 -> Vect3 -> Vect2 sphere_to_2D_plane nzv w = (ymult `dot3` w, zmult `dot3` w) - where ymult = vect3_orthonorm_toy nzv - zmult = vect3_orthonorm_toz nzv + where + ymult = vect3_orthonorm_toy nzv + zmult = vect3_orthonorm_toz nzv pO :: Vect3 pO = spherical2xyz latO lonO @@ -89,7 +92,8 @@ sOx, sOy, sOz :: Stream Double sIx, sIy, sIz :: Stream Double (sIx, sIy, sIz) = (sI2x, sI2y, altI) - where (sI2x, sI2y) = sphere_to_2D_plane pO pI + where + (sI2x, sI2y) = sphere_to_2D_plane pO pI vOx, vOy, vOz :: Stream Double (vOx, vOy, vOz) = (gsO * sin trkO, gsO * cos trkO, vsO) @@ -97,9 +101,7 @@ vOx, vOy, vOz :: Stream Double vIx, vIy, vIz :: Stream Double (vIx, vIy, vIz) = (gsI * sin trkI, gsI * cos trkI, vsI) --------------------------------- -- latI velocity/position -- --------------------------------- vx, vy, vz :: Stream Double (vx, vy, vz) = (vOx - vIx, vOy - vIy, vOz - vIz) @@ -113,9 +115,7 @@ sx, sy, sz :: Stream Double s :: Vect2 s = (sx, sy) ------------------- -- Vector stuff -- ------------------- (|*|) :: Vect2 -> Vect2 -> Stream Double (|*|) (x1, y1) (x2, y2) = (x1 * x2) + (y1 * y2) @@ -135,9 +135,7 @@ a ~= b = abs (a - b) < 0.001 neg :: Vect2 -> Vect2 neg (x, y) = (negate x, negate y) --------------------- -- Time variables -- --------------------- tau :: Vect2 -> Vect2 -> Stream Double tau s v = mux (s |*| v < 0) ((-(sq s)) / (s |*| v)) (-1) @@ -160,9 +158,7 @@ delta s v d = d * d * sq v - (det s v * det s v) theta :: Vect2 -> Vect2 -> Stream Double -> Stream Double -> Stream Double theta s v d e = (-(s |*| v) + e * sqrt (delta s v d)) / sq v --------------------------- -- Some tools for times -- --------------------------- tcoa :: Stream Double -> Stream Double -> Stream Double tcoa sz vz = mux ((sz * vz) < 0) ((-sz) / vz) (-1) @@ -170,9 +166,7 @@ tcoa sz vz = mux ((sz * vz) < 0) ((-sz) / vz) (-1) dcpa :: Vect2 -> Vect2 -> Stream Double dcpa s@(sx, sy) v@(vx, vy) = norm (sx + tcpa s v * vx, sy + tcpa s v * vy) --------------------------- -- Well clear Violation -- --------------------------- wcv :: (Vect2 -> Vect2 -> Stream Double) -> Vect2 -> Stream Double -> @@ -186,60 +180,48 @@ verticalWCV sz vz = (abs sz <= zthr) || (0 <= tcoa sz vz && tcoa sz vz <= tcoath horizontalWCV :: (Vect2 -> Vect2 -> Stream Double) -> Vect2 -> Vect2 -> Stream Bool horizontalWCV tvar s v = (norm s <= dthr) || ((dcpa s v <= dthr) && (0 <= tvar s v) && (tvar s v <= tthr)) --------------- -- Theorems -- --------------- -------------------------- -- Horizontal symmetry -- -------------------------- horizSymmetry = do - theorem "1a" (forall $ tau s v ~= tau (neg s) (neg v)) arith - theorem "1b" (forall $ tcpa s v ~= tcpa (neg s) (neg v)) arith - theorem "1c" (forall $ taumod s v ~= taumod (neg s) (neg v)) arith - theorem "1d" (forall $ tep s v ~= tep (neg s) (neg v)) arith + theorem "1a" (forAll $ tau s v ~= tau (neg s) (neg v)) arith + theorem "1b" (forAll $ tcpa s v ~= tcpa (neg s) (neg v)) arith + theorem "1c" (forAll $ taumod s v ~= taumod (neg s) (neg v)) arith + theorem "1d" (forAll $ tep s v ~= tep (neg s) (neg v)) arith -------------------------- -- Horizontal ordering -- -------------------------- horizOrdering = do - theorem "2a" (forall $ ((s |*| v) < 0 && norm s > dthr && dcpa s v <= dthr) + theorem "2a" (forAll $ ((s |*| v) < 0 && norm s > dthr && dcpa s v <= dthr) ==> (tep s v <= taumod s v)) arith - theorem "2b" (forall $ ((s |*| v) < 0 && norm s > dthr && dcpa s v <= dthr) + theorem "2b" (forAll $ ((s |*| v) < 0 && norm s > dthr && dcpa s v <= dthr) ==> (taumod s v <= tcpa s v)) arith - theorem "2c" (forall $ ((s |*| v) < 0 && norm s > dthr && dcpa s v <= dthr) + theorem "2c" (forAll $ ((s |*| v) < 0 && norm s > dthr && dcpa s v <= dthr) ==> (tcpa s v <= tau s v)) arith --------------- -- Symmetry -- --------------- symmetry = do - theorem "3a" (forall $ wcv tau s sz v vz == wcv tau (neg s) (-sz) (neg v) (-vz)) + theorem "3a" (forAll $ wcv tau s sz v vz == wcv tau (neg s) (-sz) (neg v) (-vz)) arith - theorem "3b" (forall $ wcv tcpa s sz v vz == wcv tcpa (neg s) (-sz) (neg v) (-vz)) + theorem "3b" (forAll $ wcv tcpa s sz v vz == wcv tcpa (neg s) (-sz) (neg v) (-vz)) arith - theorem "3c" (forall $ wcv taumod s sz v vz == wcv taumod (neg s) (-sz) (neg v) (-vz)) + theorem "3c" (forAll $ wcv taumod s sz v vz == wcv taumod (neg s) (-sz) (neg v) (-vz)) arith - theorem "3d" (forall $ wcv tep s sz v vz == wcv tep (neg s) (-sz) (neg v) (-vz)) + theorem "3d" (forAll $ wcv tep s sz v vz == wcv tep (neg s) (-sz) (neg v) (-vz)) arith ---------------- -- Inclusion -- ---------------- inclusion = do - theorem "4i" (forall $ wcv tau s sz v vz ==> wcv tcpa s sz v vz) + theorem "4i" (forAll $ wcv tau s sz v vz ==> wcv tcpa s sz v vz) arith - theorem "4ii" (forall $ wcv tcpa s sz v vz ==> wcv taumod s sz v vz ) + theorem "4ii" (forAll $ wcv tcpa s sz v vz ==> wcv taumod s sz v vz ) arith - theorem "4iii" (forall $ wcv taumod s sz v vz ==> wcv tep s sz v vz) + theorem "4iii" (forAll $ wcv taumod s sz v vz ==> wcv tep s sz v vz) arith ---------------------- -- Local convexity -- ---------------------- t1, t2, t3 :: Stream Double t1 = extern "t1" Nothing @@ -253,15 +235,13 @@ locallyConvex tvar = (0 <= t1 && t1 <= t2 && t2 <= t3) && wcv tvar (sx + t3*vx, sy + t3*vy) (sz + t3*vz) v vz) localConvexity = do - theorem "5a" (forall $ locallyConvex tcpa) arith - theorem "5b" (forall $ locallyConvex taumod) arith - theorem "5c" (forall $ locallyConvex tep) arith - theorem "6" (P.not (forall $ locallyConvex tau)) arithSat - --------------------------------------------------------------------------------- + theorem "5a" (forAll $ locallyConvex tcpa) arith + theorem "5b" (forAll $ locallyConvex taumod) arith + theorem "5c" (forAll $ locallyConvex tep) arith + theorem "6" (P.not (forAll $ locallyConvex tau)) arithSat arith :: Proof Universal -arith = onlyValidity def { nraNLSat = True, debug = False } +arith = onlyValidity def { debug = False } z3 arithSat :: Proof Existential -arithSat = onlySat def { nraNLSat = True, debug = False } +arithSat = onlySat def { debug = False } z3 diff --git a/copilot-theorem/examples/Trig.hs b/copilot-theorem/examples/Trig.hs index d18e68bac..bfcf44671 100644 --- a/copilot-theorem/examples/Trig.hs +++ b/copilot-theorem/examples/Trig.hs @@ -25,37 +25,37 @@ arithSat = onlySat def { debug = False } dReal a ~= b = abs (a - b) < 0.001 spec = do - bounds <- prop "bounds" (forall $ bounds) + bounds <- prop "bounds" (forAll $ bounds) -- dReal/metit fails this one. - -- theorem "dist_eq" (forall $ d1 ~= d2) + -- theorem "dist_eq" (forAll $ d1 ~= d2) -- $ assume bounds >> arith - theorem_ "2sin" (forall $ (2 * (sin x)) <= 3) + theorem_ "2sin" (forAll $ (2 * (sin x)) <= 3) $ assume bounds >> arith - theorem_ "sin_cos" (forall $ ((sin x) ** 2 + (cos x) ** 2) ~= 1) + theorem_ "sin_cos" (forAll $ ((sin x) ** 2 + (cos x) ** 2) ~= 1) $ assume bounds >> arith - theorem_ "sin_cos_pi" ( forall $ ((sin x) ** 2 + (cos $ x + pi) ** 2) ~= 1) + theorem_ "sin_cos_pi" ( forAll $ ((sin x) ** 2 + (cos $ x + pi) ** 2) ~= 1) $ assume bounds >> arith - theorem_ "sin_2pi" ( forall $ (sin x) ~= (sin $ x + 2 * pi)) + theorem_ "sin_2pi" ( forAll $ (sin x) ~= (sin $ x + 2 * pi)) $ assume bounds >> arith - theorem_ "cos_2pi" ( forall $ (cos x) ~= (cos $ x + 2 * pi)) + theorem_ "cos_2pi" ( forAll $ (cos x) ~= (cos $ x + 2 * pi)) $ assume bounds >> arith - theorem_ "sin_eq_cos_pi2" ( forall $ (sin x) ~= (cos $ x - (pi/2))) + theorem_ "sin_eq_cos_pi2" ( forAll $ (sin x) ~= (cos $ x - (pi/2))) $ assume bounds >> arith - theorem_ "x^2_2" ( forall $ (x ** 2 + 1) >= x) + theorem_ "x^2_2" ( forAll $ (x ** 2 + 1) >= x) $ assume bounds >> arith - theorem_ "sqrt_x" ( forall $ (x > 2) ==> ((sqrt x) < x)) + theorem_ "sqrt_x" ( forAll $ (x > 2) ==> ((sqrt x) < x)) $ assume bounds >> arith - theorem_ "x = y" (P.not $ forall $ x == y) + theorem_ "x = y" (P.not $ forAll $ x == y) $ assume bounds >> arithSat - theorem_ "sin_cos_3" (P.not $ forall $ ((sin x) ** 2 + (cos $ x + 3) ** 2) ~= 1) + theorem_ "sin_cos_3" (P.not $ forAll $ ((sin x) ** 2 + (cos $ x + 3) ** 2) ~= 1) $ assume bounds >> arithSat - theorem_ "sin_pi" (P.not $ forall $ (sin x) ~= (sin $ x + pi)) + theorem_ "sin_pi" (P.not $ forAll $ (sin x) ~= (sin $ x + pi)) $ assume bounds >> arithSat - theorem_ "sin_eq_cos_3" (P.not $ forall $ (sin x) ~= (cos $ x - (3/2))) + theorem_ "sin_eq_cos_3" (P.not $ forAll $ (sin x) ~= (cos $ x - (3/2))) $ assume bounds >> arithSat - theorem_ "sin_eq_cos" (P.not $ forall $ (sin x) ~= (cos x)) + theorem_ "sin_eq_cos" (P.not $ forAll $ (sin x) ~= (cos x)) $ assume bounds >> arithSat where @@ -77,4 +77,3 @@ spec = do d1 = acos ((sin lat1) * (sin lat2) + (cos lat1) * (cos lat2) * (cos (lon1 - lon2))) d2 = 2 * asin (sqrt ( (sin ((lat1 - lat2)/2)) ** 2 + (cos lat1) * (cos lat2) * ((sin ((lon1 - lon2)/2)) ** 2))) - diff --git a/copilot-theorem/examples/WCV.hs b/copilot-theorem/examples/WCV.hs index 8eb2a493c..c0f267c68 100644 --- a/copilot-theorem/examples/WCV.hs +++ b/copilot-theorem/examples/WCV.hs @@ -5,7 +5,7 @@ import Prelude () import Copilot.Language import Copilot.Language.Reify import Copilot.Theorem -import Copilot.Theorem.Prover.Z3 +import Copilot.Theorem.Prover.SMT (debug, def, onlySat, onlyValidity, z3) import qualified Copilot.Language.Operators.Propositional as P @@ -17,9 +17,7 @@ tcoathr = extern "tcoathr" Nothing type Vect2 = (Stream Double, Stream Double) --------------------------------- -- Relative velocity/position -- --------------------------------- vx, vy, vz :: Stream Double vx = extern "relative_velocity_x" Nothing @@ -37,9 +35,7 @@ sz = extern "relative_position_z" Nothing s :: (Stream Double, Stream Double) s = (sx, sy) ------------------- -- Vector stuff -- ------------------- (|*|) :: Vect2 -> Vect2 -> Stream Double (|*|) (x1, y1) (x2, y2) = (x1 * x2) + (y1 * y2) @@ -59,9 +55,7 @@ a ~= b = (abs (a - b)) < 0.001 neg :: Vect2 -> Vect2 neg (x, y) = (negate x, negate y) --------------------- -- Time variables -- --------------------- tau :: Vect2 -> Vect2 -> Stream Double tau s v = mux (s |*| v < 0) ((-(sq s)) / (s |*| v)) (-1) @@ -84,9 +78,7 @@ delta s v d = (d*d) * (sq v) - ((det s v)*(det s v)) theta :: Vect2 -> Vect2 -> Stream Double -> Stream Double -> Stream Double theta s v d e = (-(s |*| v) + e * (sqrt $ delta s v d)) / (sq v) --------------------------- -- Some tools for times -- --------------------------- tcoa :: Stream Double -> Stream Double -> Stream Double tcoa sz vz = mux ((sz * vz) < 0) ((-sz) / vz) (-1) @@ -94,9 +86,7 @@ tcoa sz vz = mux ((sz * vz) < 0) ((-sz) / vz) (-1) dcpa :: Vect2 -> Vect2 -> Stream Double dcpa s@(sx, sy) v@(vx, vy) = norm (sx + (tcpa s v) * vx, sy + (tcpa s v) * vy) --------------------------- -- Well clear Violation -- --------------------------- wcv :: (Vect2 -> Vect2 -> Stream Double) -> Vect2 -> Stream Double -> @@ -114,60 +104,48 @@ horizontalWCV tvar s v = (norm s <= dthr) || (((dcpa s v) <= dthr) && (0 <= (tvar s v)) && ((tvar s v) <= tthr)) --------------- -- Theorems -- --------------- -------------------------- -- Horizontal symmetry -- -------------------------- horizSymmetry = do - theorem "1a" (forall $ (tau s v) ~= (tau (neg s) (neg v))) arith - theorem "1b" (forall $ (tcpa s v) ~= (tcpa (neg s) (neg v))) arith - theorem "1c" (forall $ (taumod s v) ~= (taumod (neg s) (neg v))) arith - theorem "1d" (forall $ (tep s v) ~= (tep (neg s) (neg v))) arith + theorem "1a" (forAll $ (tau s v) ~= (tau (neg s) (neg v))) arith + theorem "1b" (forAll $ (tcpa s v) ~= (tcpa (neg s) (neg v))) arith + theorem "1c" (forAll $ (taumod s v) ~= (taumod (neg s) (neg v))) arith + theorem "1d" (forAll $ (tep s v) ~= (tep (neg s) (neg v))) arith -------------------------- -- Horizontal ordering -- -------------------------- horizOrdering = do - theorem "2a" (forall $ ((s |*| v) < 0 && (norm s) > dthr && (dcpa s v) <= dthr) + theorem "2a" (forAll $ ((s |*| v) < 0 && (norm s) > dthr && (dcpa s v) <= dthr) ==> ((tep s v) <= (taumod s v))) arith - theorem "2b" (forall $ ((s |*| v) < 0 && (norm s) > dthr && (dcpa s v) <= dthr) + theorem "2b" (forAll $ ((s |*| v) < 0 && (norm s) > dthr && (dcpa s v) <= dthr) ==> ((taumod s v) <= (tcpa s v))) arith - theorem "2c" (forall $ ((s |*| v) < 0 && (norm s) > dthr && (dcpa s v) <= dthr) + theorem "2c" (forAll $ ((s |*| v) < 0 && (norm s) > dthr && (dcpa s v) <= dthr) ==> ((tcpa s v) <= (tau s v))) arith --------------- -- Symmetry -- --------------- symmetry = do - theorem "3a" (forall $ (wcv tau s sz v vz) == (wcv tau (neg s) (-sz) (neg v) (-vz))) + theorem "3a" (forAll $ (wcv tau s sz v vz) == (wcv tau (neg s) (-sz) (neg v) (-vz))) arith - theorem "3b" (forall $ (wcv tcpa s sz v vz) == (wcv tcpa (neg s) (-sz) (neg v) (-vz))) + theorem "3b" (forAll $ (wcv tcpa s sz v vz) == (wcv tcpa (neg s) (-sz) (neg v) (-vz))) arith - theorem "3c" (forall $ (wcv taumod s sz v vz) == (wcv taumod (neg s) (-sz) (neg v) (-vz))) + theorem "3c" (forAll $ (wcv taumod s sz v vz) == (wcv taumod (neg s) (-sz) (neg v) (-vz))) arith - theorem "3d" (forall $ (wcv tep s sz v vz) == (wcv tep (neg s) (-sz) (neg v) (-vz))) + theorem "3d" (forAll $ (wcv tep s sz v vz) == (wcv tep (neg s) (-sz) (neg v) (-vz))) arith ---------------- -- Inclusion -- ---------------- inclusion = do - theorem "4i" (forall $ (wcv tau s sz v vz) ==> (wcv tcpa s sz v vz)) + theorem "4i" (forAll $ (wcv tau s sz v vz) ==> (wcv tcpa s sz v vz)) arith - theorem "4ii" (forall $ (wcv tcpa s sz v vz) ==> (wcv taumod s sz v vz )) + theorem "4ii" (forAll $ (wcv tcpa s sz v vz) ==> (wcv taumod s sz v vz )) arith - theorem "4iii" (forall $ (wcv taumod s sz v vz) ==> (wcv tep s sz v vz)) + theorem "4iii" (forAll $ (wcv taumod s sz v vz) ==> (wcv tep s sz v vz)) arith ---------------------- -- Local convexity -- ---------------------- t1, t2, t3 :: Stream Double t1 = extern "t1" Nothing @@ -181,16 +159,13 @@ locallyConvex tvar = (0 <= t1 && t1 <= t2 && t2 <= t3) && (wcv tvar (sx + t3*vx, sy + t3*vy) (sz + t3*vz) v vz)) localConvexity = do - theorem "5a" (forall $ locallyConvex tcpa) arith - theorem "5b" (forall $ locallyConvex taumod) arith - theorem "5c" (forall $ locallyConvex tep) arith - theorem "6" (P.not (forall $ locallyConvex tau)) arithSat - --------------------------------------------------------------------------------- + theorem "5a" (forAll $ locallyConvex tcpa) arith + theorem "5b" (forAll $ locallyConvex taumod) arith + theorem "5c" (forAll $ locallyConvex tep) arith + theorem "6" (P.not (forAll $ locallyConvex tau)) arithSat arith :: Proof Universal -arith = onlyValidity def { nraNLSat = True, debug = False } +arith = onlyValidity def { debug = False } z3 arithSat :: Proof Existential -arithSat = onlySat def { nraNLSat = True, debug = False } - +arithSat = onlySat def { debug = False } z3 diff --git a/copilot-theorem/src/Copilot/Theorem.hs b/copilot-theorem/src/Copilot/Theorem.hs index ea7098bb8..510d5d6fc 100644 --- a/copilot-theorem/src/Copilot/Theorem.hs +++ b/copilot-theorem/src/Copilot/Theorem.hs @@ -1,5 +1,3 @@ --------------------------------------------------------------------------------- - {-# LANGUAGE Safe #-} -- | Highly automated proof techniques are a necessary step for the widespread @@ -22,5 +20,3 @@ module Copilot.Theorem import Copilot.Theorem.Tactics as X import Copilot.Theorem.Prove - --------------------------------------------------------------------------------- diff --git a/copilot-theorem/src/Copilot/Theorem/IL.hs b/copilot-theorem/src/Copilot/Theorem/IL.hs index dde596c6e..acd4064ba 100644 --- a/copilot-theorem/src/Copilot/Theorem/IL.hs +++ b/copilot-theorem/src/Copilot/Theorem/IL.hs @@ -1,5 +1,3 @@ --------------------------------------------------------------------------------- - {-# LANGUAGE Safe #-} -- | Each prover first translates the Copilot specification into an @@ -16,5 +14,3 @@ 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 - --------------------------------------------------------------------------------- diff --git a/copilot-theorem/src/Copilot/Theorem/IL/PrettyPrint.hs b/copilot-theorem/src/Copilot/Theorem/IL/PrettyPrint.hs index 37d36a262..196873060 100644 --- a/copilot-theorem/src/Copilot/Theorem/IL/PrettyPrint.hs +++ b/copilot-theorem/src/Copilot/Theorem/IL/PrettyPrint.hs @@ -1,7 +1,6 @@ ---------------------------------------------------------------------------------- - -{-# LANGUAGE NamedFieldPuns, GADTs #-} -{-# LANGUAGE Safe #-} +{-# 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. @@ -13,8 +12,6 @@ import qualified Data.Map as Map import Prelude hiding ((<>)) --------------------------------------------------------------------------------- - -- | Pretty print an IL specification. prettyPrint :: IL -> String prettyPrint = render . ppSpec @@ -87,5 +84,3 @@ ppOp1 = text . show ppOp2 :: Op2 -> Doc ppOp2 = text . show - --------------------------------------------------------------------------------- diff --git a/copilot-theorem/src/Copilot/Theorem/IL/Spec.hs b/copilot-theorem/src/Copilot/Theorem/IL/Spec.hs index 19773b4fd..62ed692bd 100644 --- a/copilot-theorem/src/Copilot/Theorem/IL/Spec.hs +++ b/copilot-theorem/src/Copilot/Theorem/IL/Spec.hs @@ -1,7 +1,7 @@ --------------------------------------------------------------------------------- - -{-# LANGUAGE ExistentialQuantification, GADTs, LambdaCase #-} -{-# LANGUAGE Safe #-} +{-# 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 @@ -35,8 +35,6 @@ module Copilot.Theorem.IL.Spec import Data.Map (Map) import Data.Function (on) --------------------------------------------------------------------------------- - -- | Identifier of a sequence. type SeqId = String @@ -77,8 +75,6 @@ data Expr | 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 @@ -92,8 +88,6 @@ instance Eq VarDescr where instance Ord VarDescr where compare = compare `on` varName --------------------------------------------------------------------------------- - -- | Identifier for a property. type PropId = String @@ -111,8 +105,6 @@ data IL = IL , inductive :: Bool } --------------------------------------------------------------------------------- - -- | Unary operators. data Op1 = Not | Neg | Abs | Exp | Sqrt | Log | Sin | Tan | Cos | Asin | Atan | Acos | Sinh | Tanh | Cosh | Asinh | Atanh | Acosh @@ -122,8 +114,6 @@ data Op1 = Not | Neg | Abs | Exp | Sqrt | Log | Sin | Tan | Cos | Asin | Atan 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 -> "-" @@ -167,8 +157,6 @@ instance Show Op2 where Lt -> "<" Gt -> ">" -------------------------------------------------------------------------------- - -- | Return the type of an expression. typeOf :: Expr -> Type typeOf e = case e of @@ -202,5 +190,3 @@ 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) - --------------------------------------------------------------------------------- diff --git a/copilot-theorem/src/Copilot/Theorem/IL/Transform.hs b/copilot-theorem/src/Copilot/Theorem/IL/Transform.hs index 481835a8e..4bdaa47f3 100644 --- a/copilot-theorem/src/Copilot/Theorem/IL/Transform.hs +++ b/copilot-theorem/src/Copilot/Theorem/IL/Transform.hs @@ -1,5 +1,5 @@ {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE Safe #-} +{-# LANGUAGE Safe #-} -- | Simplify IL expressions by partly evaluating operations on booleans. module Copilot.Theorem.IL.Transform ( bsimpl ) where @@ -45,4 +45,3 @@ bsimpl = until (\x -> bsimpl' x == x) bsimpl' FunApp t f args -> FunApp t f (map bsimpl' args) e -> e - diff --git a/copilot-theorem/src/Copilot/Theorem/IL/Translate.hs b/copilot-theorem/src/Copilot/Theorem/IL/Translate.hs index bdff2dc3b..c1a6606ba 100644 --- a/copilot-theorem/src/Copilot/Theorem/IL/Translate.hs +++ b/copilot-theorem/src/Copilot/Theorem/IL/Translate.hs @@ -1,8 +1,9 @@ --------------------------------------------------------------------------------- - -{-# LANGUAGE RankNTypes, NamedFieldPuns, ScopedTypeVariables, GADTs, - LambdaCase #-} -{-# LANGUAGE Safe #-} +{-# 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 @@ -13,6 +14,7 @@ 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 @@ -24,8 +26,6 @@ import GHC.Float (float2Double) import Data.Typeable (Typeable) --------------------------------------------------------------------------------- - -- 'nc' stands for naming convention. ncSeq :: C.Id -> SeqId ncSeq = printf "s%d" @@ -43,8 +43,6 @@ 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 @@ -65,8 +63,13 @@ translate' b (C.Spec {C.specStreams, C.specProperties}) = runTrans b $ do localConstraints <- popLocalConstraints properties <- Map.fromList <$> forM specProperties - (\(C.Property {C.propertyName, C.propertyExpr}) -> do - e' <- expr propertyExpr + (\(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'))) @@ -88,22 +91,24 @@ bound s t = case t of 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)) + 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 + 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 @@ -116,8 +121,6 @@ streamRec (C.Stream { C.streamId = id 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 @@ -134,7 +137,8 @@ expr (C.Local ta _ name ea eb) = do 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_ + where + s = SVal (trType t) (ncExternVar name) _n_ expr (C.Op1 (C.Sign ta) e) = case ta of C.Int8 -> trSign ta e @@ -144,15 +148,16 @@ expr (C.Op1 (C.Sign ta) e) = case ta of 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))) + 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) @@ -160,19 +165,22 @@ 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 + 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 + 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 + where + (op', t') = trOp2 op expr (C.Op3 (C.Mux t) cond e1 e2) = do cond' <- expr cond @@ -193,14 +201,15 @@ trConst t v = case t of 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 + 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 @@ -225,7 +234,7 @@ trOp1 = \case C.Acosh t -> (Acosh, trType t) -- C.BwNot t -> -- C.Cast t -> - _ -> error "Unsupported unary operator in input." -- TODO(chathhorn) + _ -> error "Unsupported unary operator in input." trOp2 :: C.Op2 a b c -> (Op2, Type) trOp2 = \case @@ -258,7 +267,7 @@ trOp2 = \case -- C.BwShiftL t _ -> -- C.BwShiftR t _ -> - _ -> error "Unsupported binary operator in input." -- TODO(chathhorn) + _ -> error "Unsupported binary operator in input." trType :: C.Type a -> Type trType = \case @@ -274,8 +283,6 @@ trType = \case C.Float -> Real C.Double -> Real --------------------------------------------------------------------------------- - -- | Translation state. data TransST = TransST { localConstraints :: [Expr] @@ -294,14 +301,16 @@ newMux c t e1 e2 = do modify $ \st -> st { muxes = (v, mux) : ms } return v Just (v, _) -> return v - where mux = (c, t, e1, e2) + 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) - ] + 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 @@ -321,6 +330,3 @@ popLocalConstraints = liftM2 (++) (localConstraints <$> get) getMuxes runTrans :: Bool -> Trans a -> a runTrans b m = evalState m $ TransST [] [] 0 b - --------------------------------------------------------------------------------- - diff --git a/copilot-theorem/src/Copilot/Theorem/Kind2.hs b/copilot-theorem/src/Copilot/Theorem/Kind2.hs index 5002d749a..09edd94b3 100644 --- a/copilot-theorem/src/Copilot/Theorem/Kind2.hs +++ b/copilot-theorem/src/Copilot/Theorem/Kind2.hs @@ -1,5 +1,3 @@ --------------------------------------------------------------------------------- - {-# LANGUAGE Safe #-} -- | Copilot backend for the SMT @@ -11,5 +9,3 @@ 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 - --------------------------------------------------------------------------------- diff --git a/copilot-theorem/src/Copilot/Theorem/Kind2/AST.hs b/copilot-theorem/src/Copilot/Theorem/Kind2/AST.hs index a8cf7e0bf..efd493a6d 100644 --- a/copilot-theorem/src/Copilot/Theorem/Kind2/AST.hs +++ b/copilot-theorem/src/Copilot/Theorem/Kind2/AST.hs @@ -1,31 +1,54 @@ --------------------------------------------------------------------------------- - {-# LANGUAGE Safe #-} --- | Abstract syntax tree of Kind2 files. +-- | Abstract syntax tree of Kind2 native input files. +-- +-- This represents the native transition system input format supported by +-- Kind2 1.0 and newer (@--input_format native@), in which a file is a +-- sequence of @define-node@ forms, each declaring a state transition system +-- by means of an initial state predicate and a transition relation predicate. +-- The last node defined in a file is the top system analyzed by Kind2, and +-- the properties to check are attached to it. +-- +-- The native input format is largely undocumented, and Kind2's user +-- documentation only covers its Lustre frontend. The best available +-- references for the native format are the parser in the Kind2 sources +-- ([nativeInput.ml] +-- (https://github.com/kind2-mc/kind2/blob/v3.0.0/src/nativeInput.ml)), +-- which includes a sketch of the grammar in a comment near the end of the +-- file) and the example file +-- [two_counters.kind2] +-- (https://github.com/kind2-mc/kind2/blob/develop/examples/two_counters.kind2). module Copilot.Theorem.Kind2.AST where --------------------------------------------------------------------------------- - --- | A file is a sequence of predicates and propositions. +-- | A file is a sequence of node definitions, together with a distinguished +-- top node and a series of propositions about the top node. +-- +-- Kind2 analyzes the last node defined in a file as the top system, so the +-- top node is always printed after all the other nodes. data File = File - { filePreds :: [PredDef] - , fileProps :: [Prop] } + { fileNodes :: [Node] -- ^ Nodes other than the top node, in dependency + -- order (a node may only refer to nodes defined + -- before it). + , fileTopNode :: Node -- ^ The top node, which the propositions are + -- attached to. + , fileProps :: [Prop] -- ^ Propositions about the top node. + } -- | 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 +-- | A node definition. +data Node = Node + { nodeId :: String -- ^ Identifier for the node. + , nodeStateVars :: [StateVarDef] -- ^ Variables identifying the states in + -- the underlying state transition system. + , nodeInit :: Term -- ^ Predicate that holds for initial -- states. - , predTrans :: Term -- ^ Predicate that holds for two states, if - -- there is state transition between them. + , nodeTrans :: Term -- ^ Predicate that holds for two states, + -- if there is a state transition between + -- them. } -- | A definition of a state variable. @@ -54,5 +77,3 @@ data Term = | StateVar String | FunApp String [Term] | PredApp String PredType [Term] - --------------------------------------------------------------------------------- diff --git a/copilot-theorem/src/Copilot/Theorem/Kind2/Output.hs b/copilot-theorem/src/Copilot/Theorem/Kind2/Output.hs index 05621dafb..8a1d29c28 100644 --- a/copilot-theorem/src/Copilot/Theorem/Kind2/Output.hs +++ b/copilot-theorem/src/Copilot/Theorem/Kind2/Output.hs @@ -1,56 +1,100 @@ --------------------------------------------------------------------------------- - {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE Safe #-} +{-# 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 Data.List.Extra (isInfixOf, splitOn, stripInfix, trim) +import Data.Maybe (mapMaybe) -import qualified Copilot.Theorem.Misc.Error as Err +import Copilot.Theorem.Prove as P --------------------------------------------------------------------------------- +import qualified Copilot.Core as C -simpleName s = QName s Nothing Nothing +import qualified Copilot.Theorem.Misc.Error as Err -- | Parse output of Kind2. +-- +-- The output is expected to be in XML format, as produced by Kind2's @-xml@ +-- flag and documented at +-- . +-- Note that this function does not parse the output as XML: when given a +-- system in the native transition system format, Kind2 produces output that +-- is not always well-formed XML (e.g., counterexamples to invariant +-- properties cannot be printed for systems in that format -- the +-- counterexample printing functions in Kind2's @src/inputSystem.ml@ fail with +-- an internal error for native input -- and Kind2 reports the error in the +-- middle of the XML output). Instead, this function looks for the +-- @\@ tag for the given property and extracts the answers in the +-- @\@ tags it contains. parseOutput :: String -- ^ Property whose validity is being checked. + -> C.Prop -- ^ The property's quantifier. -> String -- ^ XML output of Kind2 -> P.Output -parseOutput prop xml = fromJust $ do - root <- parseXMLDoc xml - case findAnswer . findPropTag $ root of - "valid" -> return (Output Valid []) - "invalid" -> return (Output Invalid []) - s -> err $ "Unrecognized status : " ++ s +parseOutput propId propQuantifier xml + | "valid" `elem` answers = quantified (Output Valid []) + (Output Invalid []) + | "falsifiable" `elem` answers = quantified (Output Invalid []) + (Output Valid []) + | "unknown" `elem` answers = Output Unknown [] + | null answers = err $ "Answer for property " ++ propId ++ " not found" + | otherwise = err $ "Unrecognized status : " ++ unwords answers 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" + -- Pick an output based on the quantifier of the property. The first + -- argument is returned when the property Kind2 was asked about is valid, + -- and the second one when it is invalid. + -- + -- We encode a universally quantified property P as ∀x.P(x) in Kind2, so + -- the original property is valid iff the Kind2 property is valid. + -- + -- We encode an existentially quantified property P as ¬(∀x.¬(P(x))) in + -- Kind2, so the original property is valid iff the Kind2 property is + -- invalid. + quantified ifValid ifInvalid = case propQuantifier of + C.Forall {} -> ifValid + C.Exists {} -> ifInvalid + + -- All the answers reported for the property, in the order in which they + -- appear in the output. A conclusive answer (valid or falsifiable), if + -- any, takes precedence over inconclusive (unknown) ones, which Kind2 may + -- also report when the analysis terminates without an answer for all + -- properties. + answers = mapMaybe answerText + $ filter isRightProperty + $ propertyElems xml + + -- Substrings of the output following a @\') elem' + + -- The contents of the first @\@ tag in the given element, if + -- any. + answerText elem' = do + (_, rest) <- stripInfix "" rest + let answer = trim $ takeWhile (/= '<') rest' + if null answer then Nothing else Just answer err :: forall a . String -> a err msg = Err.fatal $ "Parse error while reading the Kind2 XML output : \n" ++ msg ++ "\n\n" ++ xml --------------------------------------------------------------------------------- +-- | Escape a string for use as an XML attribute value. +escapeAttr :: String -> String +escapeAttr = concatMap escapeChar + where + escapeChar '&' = "&" + escapeChar '<' = "<" + escapeChar '>' = ">" + escapeChar '"' = """ + escapeChar c = [c] diff --git a/copilot-theorem/src/Copilot/Theorem/Kind2/PrettyPrint.hs b/copilot-theorem/src/Copilot/Theorem/Kind2/PrettyPrint.hs index 9a74bbdd2..92d158a1c 100644 --- a/copilot-theorem/src/Copilot/Theorem/Kind2/PrettyPrint.hs +++ b/copilot-theorem/src/Copilot/Theorem/Kind2/PrettyPrint.hs @@ -1,8 +1,8 @@ --------------------------------------------------------------------------------- - {-# LANGUAGE Safe #-} --- | Pretty print a Kind2 file defining predicates and propositions. +-- | Pretty print a Kind2 file defining nodes and propositions, in the native +-- transition system input format supported by Kind2 1.0 and newer (see +-- "Copilot.Theorem.Kind2.AST" for pointers to references on the format). module Copilot.Theorem.Kind2.PrettyPrint ( prettyPrint ) where import Copilot.Theorem.Misc.SExpr @@ -11,15 +11,19 @@ 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" --------------------------------------------------------------------------------- +-- | Dummy position attached to the properties of the file. +-- +-- Kind2 requires a position (in the format @file:row-col@) for properties +-- declared with the @:user@ source annotation, and reports that position back +-- in its output. +propPosition :: String +propPosition = "copilot:1-1" -- | Pretty print a Kind2 file. prettyPrint :: File -> String @@ -34,33 +38,42 @@ shouldIndent (Atom _) = False shouldIndent (List [Atom a, Atom _]) = a `notElem` [kwPrime] shouldIndent _ = True --------------------------------------------------------------------------------- - -- | Convert a file into a sequence of expressions. +-- +-- The top node is printed last, since Kind2 analyzes the last node of the +-- file as the top system. The properties of the file are attached to it. ppFile :: File -> [SSExpr] -ppFile (File preds props) = map ppPredDef preds ++ ppProps props +ppFile (File nodes top props) = + map (`ppNode` []) nodes ++ [ppNode top (ppProps props)] --- | Convert a sequence of propositions into command to check each of them. +-- | Convert a sequence of propositions into a props field. ppProps :: [Prop] -> [SSExpr] -ppProps ps = [ node "check-prop" [ list $ map ppProp ps ] ] +ppProps [] = [] +ppProps ps = [ node "props" [ 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] ] +ppProp (Prop n t) = list [atom n, ppTerm t, atom ":user", atom propPosition] + +-- | Convert a node, together with optional extra fields, into an expression. +ppNode :: Node -> [SSExpr] -> SSExpr +ppNode n extraFields = + list $ [ atom "define-node" + , atom (nodeId n) + , list . map ppStateVarDef . nodeStateVars $ n + , node "init" [ppTerm $ nodeInit n] + , node "trans" [ppTerm $ nodeTrans n] ] + ++ extraFields -- | Convert a state variable definition into an expression. ppStateVarDef :: StateVarDef -> SSExpr ppStateVarDef svd = - list [atom (varId svd), ppType (varType svd)] + list $ [atom (varId svd), ppType (varType svd)] + ++ map ppStateVarFlag (varFlags svd) + +-- | Convert a state variable option into an expression. +ppStateVarFlag :: StateVarFlag -> SSExpr +ppStateVarFlag FConst = atom ":const" -- | Convert a type into an expression. ppType :: Type -> SSExpr @@ -75,8 +88,7 @@ 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" - --------------------------------------------------------------------------------- + where + ext = case t of + Init -> "init" + Trans -> "trans" diff --git a/copilot-theorem/src/Copilot/Theorem/Kind2/Prover.hs b/copilot-theorem/src/Copilot/Theorem/Kind2/Prover.hs index f94e01071..a79ede4f6 100644 --- a/copilot-theorem/src/Copilot/Theorem/Kind2/Prover.hs +++ b/copilot-theorem/src/Copilot/Theorem/Kind2/Prover.hs @@ -1,6 +1,3 @@ --------------------------------------------------------------------------------- - -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE Trustworthy #-} -- | A prover backend based on Kind2. @@ -21,17 +18,18 @@ import Copilot.Theorem.Misc.Utils (openTempFile) import System.Process -import System.Directory -import Data.Default - -import qualified Copilot.Theorem.TransSys as TS +import System.Directory +import Data.Default +import qualified Data.Map as Map --------------------------------------------------------------------------------- +import qualified Copilot.Theorem.Misc.Error as Err +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/. + -- step will perform (passed to Kind2 via its + -- @--unroll_max@ option). A value of 0 means /unlimited/. } -- | Default options with unlimited unrolling for base and step. @@ -44,7 +42,10 @@ data ProverST = ProverST -- | A prover backend based on Kind2. -- --- The executable @kind2@ must exist and its location be in the @PATH@. +-- The executable @kind2@ must exist and its location be in the @PATH@. Kind2 +-- version 1.0 or newer is required: the native input format and the +-- command-line options this prover uses were introduced in Kind2 1.0, and +-- remain supported as of Kind2 3.0. kind2Prover :: Options -> Prover kind2Prover opts = Prover { proverName = "Kind2" @@ -52,30 +53,30 @@ kind2Prover opts = Prover , askProver = askKind2 , closeProver = const $ return () } --------------------------------------------------------------------------------- - kind2Prog = "kind2" -kind2BaseOptions = ["--input-format", "native", "-xml"] - --------------------------------------------------------------------------------- +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 + let kind2Input = prettyPrint . toKind2 assumptions toCheck $ spec (tempName, tempHandle) <- openTempFile "." "out" "kind" hPutStr tempHandle kind2Input hClose tempHandle let kind2Options = - kind2BaseOptions ++ ["--bmc_max", show $ bmcMax opts, tempName] + kind2BaseOptions ++ ["--unroll_max", show $ bmcMax opts, tempName] (_, output, _) <- readProcessWithExitCode kind2Prog kind2Options "" - putStrLn kind2Input - removeFile tempName - return $ parseOutput (head toCheck) output -- TODO support multiple toCheck props --------------------------------------------------------------------------------- + let propId = head toCheck + propQuantifier = case Map.lookup propId (TS.specProps spec) of + Just (_, quantifier) -> + quantifier + Nothing -> + Err.impossible $ + "askKind2: " ++ propId ++ " not in specProps" + return $ parseOutput propId propQuantifier output diff --git a/copilot-theorem/src/Copilot/Theorem/Kind2/Translate.hs b/copilot-theorem/src/Copilot/Theorem/Kind2/Translate.hs index 26223eee5..d59aaae24 100644 --- a/copilot-theorem/src/Copilot/Theorem/Kind2/Translate.hs +++ b/copilot-theorem/src/Copilot/Theorem/Kind2/Translate.hs @@ -1,120 +1,82 @@ --------------------------------------------------------------------------------- - -{-# LANGUAGE RankNTypes, ViewPatterns, NamedFieldPuns, GADTs #-} -{-# LANGUAGE Safe #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE Safe #-} -- | 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 Data.List (partition, sort, sortBy) +import Data.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 +toKind2 :: [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) +toKind2 assumptions checkedProps spec = + addAssumptions spec' assumptions $ trSpec spec' checkedProps + where + spec' = inline spec + +trSpec :: TransSys -> [PropId] -> K.File +trSpec spec checkedProps = K.File otherNodes topNode props + where + (topNode, otherNodes) = + case partition ((== specTopNodeId spec) . K.nodeId) nodes of + ([top], others) -> (top, others) + _ -> error $ "Kind2.Translate: top node " + ++ specTopNodeId spec ++ " not found" + nodes = map (trNode spec) (specNodes spec) + props = map trProp $ + filter ((`elem` checkedProps) . fst) $ + Map.toList $ Map.map fst $ 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 } +trNode :: TransSys -> Node -> K.Node +trNode spec node = K.Node + { K.nodeId = nodeId node + , K.nodeStateVars = gatherPredStateVars spec node + , K.nodeInit = mkConj $ initLocals node + ++ map (trExpr False) (nodeConstrs node) + , K.nodeTrans = mkConj $ transLocals node + ++ map (trExpr True) (nodeConstrs node) + } + +-- | Add the assumptions to the top node of the file by conjoining the +-- corresponding property variables to its initial state and transition +-- relation predicates. +addAssumptions :: TransSys -> [PropId] -> K.File -> K.File +addAssumptions spec assumptions file = + file { K.fileTopNode = aux (K.fileTopNode file) } 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 + aux node = + let init' = mkConj ( K.nodeInit node : map K.StateVar vars ) + trans' = mkConj ( K.nodeTrans node : map K.PrimedStateVar vars ) + in node { K.nodeInit = init', K.nodeTrans = trans' } + toExtVar a = fst $ fromJust $ Map.lookup a $ specProps spec + vars = map (varName . extVarLocalPart . toExtVar) assumptions -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 --} +-- 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 @@ -136,8 +98,6 @@ gatherPredStateVars spec node = locals ++ 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 @@ -158,8 +118,6 @@ 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) @@ -170,7 +128,6 @@ initLocals node = 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) @@ -181,41 +138,6 @@ transLocals node = 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 @@ -225,5 +147,3 @@ trExpr primed = tr 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 - --------------------------------------------------------------------------------- diff --git a/copilot-theorem/src/Copilot/Theorem/Misc/Error.hs b/copilot-theorem/src/Copilot/Theorem/Misc/Error.hs index 4b1d5e9ca..b583400f2 100644 --- a/copilot-theorem/src/Copilot/Theorem/Misc/Error.hs +++ b/copilot-theorem/src/Copilot/Theorem/Misc/Error.hs @@ -1,5 +1,3 @@ --------------------------------------------------------------------------------- - {-# LANGUAGE Safe #-} -- | Custom functions to report error messages to users. @@ -10,8 +8,6 @@ module Copilot.Theorem.Misc.Error , fatal ) where --------------------------------------------------------------------------------- - -- | Tag used with error messages to help users locate the component that -- failed or reports the error. errorHeader :: String @@ -34,5 +30,3 @@ impossible_ = error $ errorHeader ++ "Unexpected internal error" -- | Report an unrecoverable error (e.g., incorrect format). fatal :: String -> a fatal = error - --------------------------------------------------------------------------------- diff --git a/copilot-theorem/src/Copilot/Theorem/Misc/SExpr.hs b/copilot-theorem/src/Copilot/Theorem/Misc/SExpr.hs index 389f4a011..cb7d35ff3 100644 --- a/copilot-theorem/src/Copilot/Theorem/Misc/SExpr.hs +++ b/copilot-theorem/src/Copilot/Theorem/Misc/SExpr.hs @@ -1,19 +1,14 @@ --------------------------------------------------------------------------------- - {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE Safe #-} +{-# LANGUAGE Safe #-} -- | A representation for structured expression trees, with support for pretty --- printing and for parsing. +-- printing. 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 @@ -35,11 +30,9 @@ singleton a = List [Atom a] -- (s) list = List -- (ss) -- | Sequence of expressions with a root or main note, and a series of --- additional expressions or arguments.. +-- 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 @@ -48,7 +41,6 @@ instance Show (SExpr String) 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. @@ -71,45 +63,9 @@ 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 - --------------------------------------------------------------------------------- + where + renderItem doc s + | shouldIndent s = + doc $$ indent (toDoc shouldIndent printAtom s) + | otherwise = + doc <+> toDoc shouldIndent printAtom s diff --git a/copilot-theorem/src/Copilot/Theorem/Misc/Utils.hs b/copilot-theorem/src/Copilot/Theorem/Misc/Utils.hs index c717c42a4..10b4666a4 100644 --- a/copilot-theorem/src/Copilot/Theorem/Misc/Utils.hs +++ b/copilot-theorem/src/Copilot/Theorem/Misc/Utils.hs @@ -1,6 +1,4 @@ --------------------------------------------------------------------------------- - -{-# LANGUAGE Safe #-} +{-# LANGUAGE Trustworthy #-} -- | Utility / auxiliary functions. module Copilot.Theorem.Misc.Utils @@ -8,8 +6,6 @@ module Copilot.Theorem.Misc.Utils , openTempFile ) where --------------------------------------------------------------------------------- - import Data.Function (on) import Data.List (groupBy, sortBy, group, sort) @@ -22,8 +18,6 @@ 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 @@ -46,8 +40,6 @@ nub' = map head . group . sort 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). @@ -72,5 +64,3 @@ openTempFile loc baseName extension = do pathFromSuff :: String -> FilePath pathFromSuff suf = loc ++ "/" ++ baseName ++ suf ++ "." ++ extension - --------------------------------------------------------------------------------- diff --git a/copilot-theorem/src/Copilot/Theorem/Prove.hs b/copilot-theorem/src/Copilot/Theorem/Prove.hs index 59213adb2..ed9a7d78d 100644 --- a/copilot-theorem/src/Copilot/Theorem/Prove.hs +++ b/copilot-theorem/src/Copilot/Theorem/Prove.hs @@ -1,7 +1,8 @@ --------------------------------------------------------------------------------- - -{-# LANGUAGE NamedFieldPuns, ViewPatterns, ExistentialQuantification, GADTs #-} -{-# LANGUAGE Safe #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE ViewPatterns #-} -- | Connection to theorem provers. module Copilot.Theorem.Prove @@ -21,10 +22,9 @@ 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] @@ -92,8 +92,6 @@ data Action where Assume :: PropId -> Action Admit :: Action --------------------------------------------------------------------------------- - -- | Record a requirement for satisfiability checking. check :: Prover -> Proof a check prover = Proof $ tell [Check prover] @@ -214,5 +212,3 @@ combineOutputs nameL nameR (Output stL msgL) (Output stR msgR) = ++ msgL ++ [decoName nameR] ++ msgR - --------------------------------------------------------------------------------- diff --git a/copilot-theorem/src/Copilot/Theorem/Prover/Backend.hs b/copilot-theorem/src/Copilot/Theorem/Prover/Backend.hs index 1fb9009c8..373486a7c 100644 --- a/copilot-theorem/src/Copilot/Theorem/Prover/Backend.hs +++ b/copilot-theorem/src/Copilot/Theorem/Prover/Backend.hs @@ -1,5 +1,5 @@ {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE Safe #-} +{-# LANGUAGE Safe #-} -- | Backend to SMT solvers and theorem provers. -- diff --git a/copilot-theorem/src/Copilot/Theorem/Prover/SMT.hs b/copilot-theorem/src/Copilot/Theorem/Prover/SMT.hs index 488e131df..e5661a748 100644 --- a/copilot-theorem/src/Copilot/Theorem/Prover/SMT.hs +++ b/copilot-theorem/src/Copilot/Theorem/Prover/SMT.hs @@ -1,7 +1,9 @@ --------------------------------------------------------------------------------- - -{-# LANGUAGE LambdaCase, NamedFieldPuns, FlexibleInstances, RankNTypes, GADTs #-} -{-# LANGUAGE Trustworthy #-} +{-# 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 @@ -50,8 +52,6 @@ import Copilot.Theorem.Misc.Utils import System.IO (hClose) --------------------------------------------------------------------------------- - -- * Tactics -- | Options to configure the provers. @@ -115,8 +115,6 @@ kInduction opts backend = check P.Prover , P.closeProver = const $ return () } -------------------------------------------------------------------------------- - -- * Backends -- | Backend to the Yices 2 SMT solver. @@ -238,8 +236,6 @@ metit installDir = Backend , interpret = TPTP.interpret } -------------------------------------------------------------------------------- - -- | Checks the Copilot specification with k-induction type ProofScript b = MaybeT (StateT (ProofState b) IO) @@ -331,18 +327,19 @@ entailment sid assumptions props = do 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 + 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 @@ -383,7 +380,6 @@ kInduction' startK maxK s as ps = (fromMaybe (Output P.Unknown ["proof by k-indu 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 @@ -419,6 +415,5 @@ onlyValidity' s as ps = (fromJust . fst) <$> runPS (script <* stopSolvers) s 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) - --------------------------------------------------------------------------------- + where + squash (a, b) = (concat a, b) diff --git a/copilot-theorem/src/Copilot/Theorem/Prover/SMTIO.hs b/copilot-theorem/src/Copilot/Theorem/Prover/SMTIO.hs index fa127e9c9..3035f718e 100644 --- a/copilot-theorem/src/Copilot/Theorem/Prover/SMTIO.hs +++ b/copilot-theorem/src/Copilot/Theorem/Prover/SMTIO.hs @@ -1,7 +1,7 @@ --------------------------------------------------------------------------------- - -{-# LANGUAGE LambdaCase, NamedFieldPuns, RankNTypes, ViewPatterns #-} -{-# LANGUAGE Safe #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE ViewPatterns #-} -- | Communication with SMT solvers or theorem provers. -- @@ -23,8 +23,6 @@ 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 @@ -37,8 +35,6 @@ data Solver a = Solver , 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) $ @@ -64,8 +60,6 @@ receive s = fromJust <$> runMaybeT (msum $ repeat line) 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, @@ -86,8 +80,6 @@ stop s = do 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 @@ -119,6 +111,3 @@ declVars s@(Solver { vars }) decls = do forM_ newVars $ \(VarDescr {varName, varType, args}) -> send s $ declFun varName varType args return s { vars = vars `union` fromList newVars } - --------------------------------------------------------------------------------- - diff --git a/copilot-theorem/src/Copilot/Theorem/Prover/SMTLib.hs b/copilot-theorem/src/Copilot/Theorem/Prover/SMTLib.hs index 9ceeb2ffc..0f2b1e0c6 100644 --- a/copilot-theorem/src/Copilot/Theorem/Prover/SMTLib.hs +++ b/copilot-theorem/src/Copilot/Theorem/Prover/SMTLib.hs @@ -1,7 +1,6 @@ --------------------------------------------------------------------------------- - -{-# LANGUAGE GADTs, FlexibleInstances #-} -{-# LANGUAGE Safe #-} +{-# 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. @@ -14,8 +13,6 @@ import Copilot.Theorem.Misc.SExpr import Text.Printf --------------------------------------------------------------------------------- - -- | Type used to represent SMT-lib commands. -- -- Use the interface in 'SmtFormat' to create such commands. @@ -29,8 +26,6 @@ smtTy Bool = "Bool" smtTy Real = "Real" smtTy _ = "Int" --------------------------------------------------------------------------------- - -- | Interface for SMT-Lib conforming backends. instance SmtFormat SmtLib where push = SmtLib $ node "push" [atom "1"] @@ -48,8 +43,6 @@ 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" @@ -104,5 +97,3 @@ expr (Op2 _ op e1 e2) = expr (SVal _ f ix) = atom $ case ix of Fixed i -> f ++ "_" ++ show i Var off -> f ++ "_n" ++ show off - --------------------------------------------------------------------------------- diff --git a/copilot-theorem/src/Copilot/Theorem/Prover/TPTP.hs b/copilot-theorem/src/Copilot/Theorem/Prover/TPTP.hs index 59b16a714..e179409e8 100644 --- a/copilot-theorem/src/Copilot/Theorem/Prover/TPTP.hs +++ b/copilot-theorem/src/Copilot/Theorem/Prover/TPTP.hs @@ -1,7 +1,6 @@ --------------------------------------------------------------------------------- - -{-# LANGUAGE GADTs, LambdaCase #-} -{-# LANGUAGE Safe #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE Safe #-} -- | A backend to , enabling to produce assertions -- and to parse the results from TPTP. @@ -12,8 +11,6 @@ import Copilot.Theorem.IL import Data.List --------------------------------------------------------------------------------- - -- | Type used to represent TPTP expressions. -- -- Although this type implements the 'SmtFormat' interface, only 'assert' is @@ -33,8 +30,6 @@ instance Show TptpExpr where show (Atom atom) = atom show (Fun name args) = name ++ "(" ++ intercalate ", " (map show args) ++ ")" --------------------------------------------------------------------------------- - instance SmtFormat Tptp where push = Null pop = Null @@ -50,8 +45,6 @@ interpret str | "SZS status" `isPrefixOf` str = Just Unknown | otherwise = Nothing --------------------------------------------------------------------------------- - expr :: Expr -> TptpExpr expr = \case ConstB v -> Atom $ if v then "$true" else "$false" @@ -109,5 +102,3 @@ showOp2 = \case Mod -> "mod" Fdiv -> "/" Pow -> "^" - --------------------------------------------------------------------------------- diff --git a/copilot-theorem/src/Copilot/Theorem/Prover/Z3.hs b/copilot-theorem/src/Copilot/Theorem/Prover/Z3.hs index df0e3e7cc..d5b005284 100644 --- a/copilot-theorem/src/Copilot/Theorem/Prover/Z3.hs +++ b/copilot-theorem/src/Copilot/Theorem/Prover/Z3.hs @@ -1,8 +1,11 @@ --------------------------------------------------------------------------------- - -{-# LANGUAGE LambdaCase, NamedFieldPuns, FlexibleInstances, RankNTypes, GADTs, - MultiParamTypeClasses, FlexibleContexts #-} -{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE Trustworthy #-} module Copilot.Theorem.Prover.Z3 ( module Data.Default @@ -42,8 +45,6 @@ import System.Console.ANSI import System.IO import Control.Monad.Trans --------------------------------------------------------------------------------- - -- | Tactics data Options = Options @@ -98,8 +99,6 @@ kInduction opts = check P.Prover , P.closeProver = const $ return () } -------------------------------------------------------------------------------- - -- | Checks the Copilot specification with k-induction type Solver = SMTConnection (DebugBackend SMTPipe) @@ -297,9 +296,8 @@ onlyValidity' s as ps = (fromJust . fst) <$> runPS (script <* stopSolvers) s 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) - --------------------------------------------------------------------------------- + where + squash (a, b) = (concat a, b) -- | This is all very ugly. It might make better sense to go straight from Core to SMTExpr, or maybe use SBV instead. @@ -434,7 +432,6 @@ transR = \case SVal _ s i -> getRatVar $ ncVar s i e -> error $ "Encountered unhandled expression (Rat): " ++ show e --- TODO(chathhorn): bleghh transBV8 :: Expr -> Trans (SMTExpr BV8) transBV8 = \case ConstI _ n -> return $ constant $ BitVector n @@ -483,9 +480,7 @@ transBV64 = \case SVal _ s i -> getBV64Var $ ncVar s i e -> error $ "Encountered unhandled expression (BV64): " ++ show e ------------------------------------------------------ -- Debug stuff from the the smtlib2 library github -- ------------------------------------------------------ namedDebugBackend :: String -> Bool -> b -> DebugBackend b namedDebugBackend name mute b = DebugBackend b stderr (Just 0) (Just name) True mute @@ -541,6 +536,4 @@ instance (SMTBackend b m,MonadIO m) => SMTBackend (DebugBackend b) m where when (debugUseColor b) $ liftIO $ hSetSGR (debugHandle b) [Reset,SetColor Foreground Dull Blue] liftIO $ unless (mute b) $ hPutStrLn (debugHandle b) str when (debugUseColor b) $ liftIO $ hSetSGR (debugHandle b) [Reset] - return (resp,b { debugBackend = b2 , debugLines = nline }) - - + return (resp,b { debugBackend = b2, debugLines = nline }) diff --git a/copilot-theorem/src/Copilot/Theorem/TransSys.hs b/copilot-theorem/src/Copilot/Theorem/TransSys.hs index c5d3fb760..1ad01e532 100644 --- a/copilot-theorem/src/Copilot/Theorem/TransSys.hs +++ b/copilot-theorem/src/Copilot/Theorem/TransSys.hs @@ -1,5 +1,3 @@ --------------------------------------------------------------------------------- - {-# LANGUAGE Safe #-} -- | Each prover first translates the Copilot specification into an @@ -17,5 +15,3 @@ 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 - --------------------------------------------------------------------------------- diff --git a/copilot-theorem/src/Copilot/Theorem/TransSys/Cast.hs b/copilot-theorem/src/Copilot/Theorem/TransSys/Cast.hs index ac37f333e..8d7cc7c52 100644 --- a/copilot-theorem/src/Copilot/Theorem/TransSys/Cast.hs +++ b/copilot-theorem/src/Copilot/Theorem/TransSys/Cast.hs @@ -1,7 +1,7 @@ --------------------------------------------------------------------------------- - -{-# LANGUAGE RankNTypes, ScopedTypeVariables, GADTs #-} -{-# LANGUAGE Safe #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE ScopedTypeVariables #-} -- | Casting of values with dynamic types and translating from Copilot core -- types to Copilot theorem types. @@ -14,20 +14,15 @@ module Copilot.Theorem.TransSys.Cast , casting ) where --------------------------------------------------------------------------------- - import Copilot.Core as C -import Copilot.Core.Type.Equality -import Copilot.Core.Type.Dynamic +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 Type +type Dyn = Dynamic -- | Translation of a Copilot type into Copilot theorem's internal -- representation. @@ -61,32 +56,28 @@ casting t f = case castedType t of 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 (Dynamic v tv) - | Just Refl <- tv =~= Int8 = Just $ toInteger v - | Just Refl <- tv =~= Int16 = Just $ toInteger v - | Just Refl <- tv =~= Int32 = Just $ toInteger v - | Just Refl <- tv =~= Int64 = Just $ toInteger v - | Just Refl <- tv =~= Word16 = Just $ toInteger v - | Just Refl <- tv =~= Word8 = Just $ toInteger v - | Just Refl <- tv =~= Word32 = Just $ toInteger v - | Just Refl <- tv =~= Word64 = Just $ toInteger v - | otherwise = Nothing + _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 (Dynamic v tv) - | Just Refl <- tv =~= Bool = Just v - | otherwise = Nothing + _cast d + | Just (v :: Bool) <- fromDynamic d = Just v + | otherwise = Nothing instance Casted Double where - _cast (Dynamic v tv) - | Just Refl <- tv =~= Float = Just $ float2Double v - | Just Refl <- tv =~= Double = Just v - | otherwise = Nothing - --------------------------------------------------------------------------------- + _cast d + | Just (v :: Float) <- fromDynamic d = Just $ float2Double v + | Just (v :: Double) <- fromDynamic d = Just v + | otherwise = Nothing diff --git a/copilot-theorem/src/Copilot/Theorem/TransSys/Operators.hs b/copilot-theorem/src/Copilot/Theorem/TransSys/Operators.hs index 20a66156e..dd95d45db 100644 --- a/copilot-theorem/src/Copilot/Theorem/TransSys/Operators.hs +++ b/copilot-theorem/src/Copilot/Theorem/TransSys/Operators.hs @@ -1,8 +1,9 @@ --------------------------------------------------------------------------------- - -{-# LANGUAGE GADTs, ExistentialQuantification, LambdaCase, ScopedTypeVariables, - RankNTypes #-} -{-# LANGUAGE Safe #-} +{-# 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 @@ -13,8 +14,6 @@ import Copilot.Theorem.TransSys.Type import Copilot.Theorem.Misc.Error as Err --------------------------------------------------------------------------------- - -- | Unary operators. data Op1 a where Not :: Op1 Bool @@ -55,8 +54,6 @@ data Op2 a b where Pow :: (Num a) => Op2 a a -------------------------------------------------------------------------------- - instance Show (Op1 a) where show op = case op of Neg -> "-" @@ -94,8 +91,6 @@ instance Show (Op2 a b) where Fdiv -> "/" Pow -> "^" -------------------------------------------------------------------------------- - -- | Unhandled unary operator. -- -- Unhandled operators are monomorphic, and their names are labeled so that @@ -195,8 +190,6 @@ handleOp1 resT (op, e) handleExpr notHandledF mkOp = case op of 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 @@ -228,7 +221,6 @@ handleOp2 :: -> m (expr resT) - handleOp2 resT (op, e1, e2) handleExpr notHandledF mkOp notOp = case op of C.And -> boolConnector And @@ -328,10 +320,6 @@ handleOp2 resT (op, e1, e2) handleExpr notHandledF mkOp notOp = case op of 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'" - --------------------------------------------------------------------------------- diff --git a/copilot-theorem/src/Copilot/Theorem/TransSys/PrettyPrint.hs b/copilot-theorem/src/Copilot/Theorem/TransSys/PrettyPrint.hs index a90c27621..3debe552c 100644 --- a/copilot-theorem/src/Copilot/Theorem/TransSys/PrettyPrint.hs +++ b/copilot-theorem/src/Copilot/Theorem/TransSys/PrettyPrint.hs @@ -1,7 +1,6 @@ --------------------------------------------------------------------------------- - -{-# LANGUAGE NamedFieldPuns, GADTs #-} -{-# LANGUAGE Safe #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE Safe #-} -- | Pretty print a TransSys specification as a Kind2/Lustre specification. module Copilot.Theorem.TransSys.PrettyPrint ( prettyPrint ) where @@ -15,8 +14,6 @@ import qualified Data.Bimap as Bimap import Prelude hiding ((<>)) --------------------------------------------------------------------------------- - indent = nest 4 emptyLine = text "" @@ -30,7 +27,8 @@ pSpec spec = items $$ props items = foldr (($$) . pNode) empty (specNodes spec) props = text "PROPS" $$ Map.foldrWithKey (\k -> ($$) . pProp k) - empty (specProps spec) + empty + (Map.map fst (specProps spec)) pProp pId extvar = quotes (text pId) <+> text "is" <+> pExtVar extvar @@ -82,24 +80,24 @@ pIVar v ev = 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 "}" - + 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 @@ -122,5 +120,3 @@ pOp1 = text . show pOp2 :: Op2 a b -> Doc pOp2 = text . show - --------------------------------------------------------------------------------- diff --git a/copilot-theorem/src/Copilot/Theorem/TransSys/Renaming.hs b/copilot-theorem/src/Copilot/Theorem/TransSys/Renaming.hs index d3cea4e26..76c7ba099 100644 --- a/copilot-theorem/src/Copilot/Theorem/TransSys/Renaming.hs +++ b/copilot-theorem/src/Copilot/Theorem/TransSys/Renaming.hs @@ -1,5 +1,3 @@ --------------------------------------------------------------------------------- - {-# LANGUAGE Safe #-} -- | A monad capable of keeping track of variable renames and of providing @@ -25,8 +23,6 @@ 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 @@ -36,8 +32,6 @@ data RenamingST = RenamingST { _reservedNames :: Set Var , _renaming :: Map ExtVar Var } --------------------------------------------------------------------------------- - -- | Register a name as reserved or used. addReservedName :: Var -> Renaming () addReservedName v = modify $ \st -> @@ -86,5 +80,3 @@ runRenaming m = r <- m f <- getRenamingF return (r, f) - --------------------------------------------------------------------------------- diff --git a/copilot-theorem/src/Copilot/Theorem/TransSys/Spec.hs b/copilot-theorem/src/Copilot/Theorem/TransSys/Spec.hs index a7f36c1a1..b68181ae0 100644 --- a/copilot-theorem/src/Copilot/Theorem/TransSys/Spec.hs +++ b/copilot-theorem/src/Copilot/Theorem/TransSys/Spec.hs @@ -1,7 +1,7 @@ --------------------------------------------------------------------------------- - -{-# LANGUAGE ExistentialQuantification, GADTs, RankNTypes #-} -{-# LANGUAGE Safe #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE Safe #-} -- | Specification of Copilot streams as modular transition systems. module Copilot.Theorem.TransSys.Spec @@ -24,6 +24,8 @@ module Copilot.Theorem.TransSys.Spec , specDependenciesGraph , specTopNode ) where +import qualified Copilot.Core as C + import Copilot.Theorem.TransSys.Type import Copilot.Theorem.TransSys.Operators import Copilot.Theorem.TransSys.Invariants @@ -44,8 +46,6 @@ 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 @@ -53,11 +53,12 @@ type NodeId = String type PropId = String -- | A modular transition system is defined by a graph of nodes and a series --- of properties, each mapped to a variable. +-- of properties, each mapped to a variable and a 'C.Prop' describing how the +-- property is quantified. data TransSys = TransSys { specNodes :: [Node] , specTopNodeId :: NodeId - , specProps :: Map PropId ExtVar } + , specProps :: Map PropId (ExtVar, C.Prop) } -- | A node is a set of variables living in a local namespace and corresponding -- to the 'Var' type. @@ -76,7 +77,6 @@ data Node = Node -- 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) @@ -103,8 +103,6 @@ data Expr t where 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) @@ -130,8 +128,6 @@ transformExpr f = tre 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 @@ -160,8 +156,6 @@ 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 = @@ -178,8 +172,6 @@ instance HasInvariants Node where in preVars `isSubsetOf` nodeLocalVarsSet n ] --------------------------------------------------------------------------------- - specNodesIds :: TransSys -> Set NodeId specNodesIds s = Set.fromList . map nodeId $ specNodes s @@ -195,8 +187,6 @@ specTopNode spec = fromJust $ List.find ((== specTopNodeId spec) . nodeId) (specNodes spec) --------------------------------------------------------------------------------- - instance HasInvariants TransSys where invariants s = @@ -218,14 +208,11 @@ instance HasInvariants TransSys where 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 - --------------------------------------------------------------------------------- + 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 ++ ")" - --------------------------------------------------------------------------------- diff --git a/copilot-theorem/src/Copilot/Theorem/TransSys/Transform.hs b/copilot-theorem/src/Copilot/Theorem/TransSys/Transform.hs index 51759ea13..e59058496 100644 --- a/copilot-theorem/src/Copilot/Theorem/TransSys/Transform.hs +++ b/copilot-theorem/src/Copilot/Theorem/TransSys/Transform.hs @@ -1,7 +1,5 @@ --------------------------------------------------------------------------------- - {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE Safe #-} +{-# LANGUAGE Safe #-} -- | Helper module to manipulate and simplify TransSys graphs. module Copilot.Theorem.TransSys.Transform @@ -31,15 +29,11 @@ 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. @@ -48,7 +42,8 @@ mergeNodes toMergeIds spec = spec { specNodes = newNode : map (updateOtherNode newNodeId toMergeIds renamingExtF) otherNodes - , specProps = Map.map renamingExtF (specProps spec) } + , specProps = + Map.map (\(ev, prop) -> (renamingExtF ev, prop)) (specProps spec) } where nodes = specNodes spec @@ -92,7 +87,6 @@ mergeNodes toMergeIds spec = constrs = mergeConstrs toMerge renamingF - updateOtherNode :: NodeId -> [NodeId] -> (ExtVar -> ExtVar) -> Node -> Node updateOtherNode newNodeId mergedNodesIds renamingF n = n { nodeDependencies = @@ -105,8 +99,6 @@ updateOtherNode newNodeId mergedNodesIds renamingF n = n | (lv, gv) <- Bimap.toList $ nodeImportedVars n ] } - - updateExpr :: NodeId -> (ExtVar -> Var) -> Expr t -> Expr t updateExpr nId renamingF = transformExpr aux where @@ -114,7 +106,6 @@ updateExpr nId renamingF = transformExpr aux 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 @@ -169,8 +160,6 @@ selectImportedVars toMerge otherNodes dependencies = then Bimap.insert v' (ExtVar nId v) acc else acc - - redirectLocalImports :: [Node] -> Renaming () redirectLocalImports toMerge = do renamingF <- getRenamingF @@ -186,8 +175,6 @@ redirectLocalImports toMerge = do 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 @@ -224,8 +211,6 @@ removeCycles spec = 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. -- @@ -289,5 +274,3 @@ complete spec = return $ Bimap.tryInsert alias ev acc foldM tryImport (nodeImportedVars n) toImportVars - --------------------------------------------------------------------------------- diff --git a/copilot-theorem/src/Copilot/Theorem/TransSys/Translate.hs b/copilot-theorem/src/Copilot/Theorem/TransSys/Translate.hs index 819bc38ac..2659fa6cb 100644 --- a/copilot-theorem/src/Copilot/Theorem/TransSys/Translate.hs +++ b/copilot-theorem/src/Copilot/Theorem/TransSys/Translate.hs @@ -1,8 +1,10 @@ --------------------------------------------------------------------------------- - -{-# LANGUAGE RankNTypes, NamedFieldPuns, ViewPatterns, - ScopedTypeVariables, GADTs, FlexibleContexts #-} -{-# LANGUAGE Safe #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} -- | Translate Copilot specifications into a modular transition system. -- @@ -45,6 +47,7 @@ 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) @@ -57,8 +60,6 @@ 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 @@ -80,8 +81,6 @@ 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 = @@ -97,10 +96,12 @@ translate cspec = cprops :: [C.Property] cprops = C.specProperties cspec - propBindings :: Map PropId ExtVar + propBindings :: Map PropId (ExtVar, C.Prop) propBindings = Map.fromList $ do - pid <- map C.propertyName cprops - return (pid, mkExtVar topNodeId pid) + cprop <- cprops + let pid = C.propertyName cprop + prop = C.propertyProp cprop + return (pid, (mkExtVar topNodeId pid, prop)) ((modelNodes, propNodes), extvarNodesNames) = runTrans $ liftM2 (,) (mapM stream (C.specStreams cspec)) (mkPropNodes cprops) @@ -108,9 +109,6 @@ translate cspec = topNode = mkTopNode topNodeId (map nodeId propNodes) cprops extVarNodes = map mkExtVarNode extvarNodesNames --------------------------------------------------------------------------------- - - mkTopNode :: String -> [NodeId] -> [C.Property] -> Node mkTopNode topNodeId dependencies cprops = Node { nodeId = topNodeId @@ -123,8 +121,6 @@ mkTopNode topNodeId dependencies cprops = [ (Var cp, mkExtVar (ncPropNode cp) ncMain) | cp <- C.propertyName <$> cprops ] - - mkExtVarNode (name, U t) = Node { nodeId = name , nodeDependencies = [] @@ -132,7 +128,6 @@ mkExtVarNode (name, U t) = , nodeImportedVars = Bimap.empty , nodeConstrs = []} - mkPropNodes :: [C.Property] -> Trans [Node] mkPropNodes = mapM propNode where @@ -146,11 +141,17 @@ streamOfProp :: C.Property -> C.Stream streamOfProp prop = C.Stream { C.streamId = 42 , C.streamBuffer = [] - , C.streamExpr = C.propertyExpr prop + -- TransSys encodes all properties using universal quantification. + -- Therefore, in order to encode an existentially quantified + -- property ∃x.P(x), we must first convert it to ¬(∀x.¬(P(x))). + -- The `Exists` case below handles the ∀x.¬(P(x)) part by adding + -- an `Op1 Not` around the property. The outermost negation is + -- handled elsewhere (e.g., in Copilot.Theorem.Kind2.Output.parse). + , C.streamExpr = case C.propertyProp prop of + C.Forall p -> p + C.Exists p -> C.Op1 C.Not p , C.streamExprType = C.Bool } --------------------------------------------------------------------------------- - stream :: C.Stream -> Trans Node stream (C.Stream { C.streamId , C.streamBuffer @@ -161,7 +162,7 @@ stream (C.Stream { C.streamId let nodeId = ncNode streamId outvar i = Var (ncMain `ncTimeAnnot` i) - buf = map (cast t . toDyn streamExprType) streamBuffer + buf = map (cast t . toDyn) streamBuffer (e, nodeAuxVars, nodeImportedVars, nodeDependencies) <- runExprTrans t nodeId streamExpr @@ -180,11 +181,9 @@ stream (C.Stream { C.streamId { nodeId, nodeDependencies, nodeLocalVars , nodeImportedVars, nodeConstrs = [] } --------------------------------------------------------------------------------- - expr :: Type t -> C.Expr t' -> Trans (Expr t) -expr t (C.Const t' v) = return $ Const t (cast t $ toDyn t' v) +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 @@ -219,12 +218,6 @@ expr t (C.ExternVar _ name _) = do newImportedVar localAlias (ExtVar nodeName (Var ncMain)) return $ VarE t localAlias --- TODO : Use uninterpreted functions to handle --- * Unhandled operators --- * Extern functions --- * Extern arrays --- For now, the result of these operations is a new unconstrained variable - expr t (C.Op1 op e) = handleOp1 t (op, e) expr notHandled Op1 where @@ -244,8 +237,6 @@ newUnconstrainedVar t = do newDep newNode return $ VarE t (Var newNode) --------------------------------------------------------------------------------- - runTrans :: Trans a -> (a, [(NodeId, U Type)]) runTrans mx = (x, nubBy' (compare `on` fst) $ _extVarsNodes st) @@ -293,7 +284,6 @@ popLocalInfos = do , _dependencies = [] } return (lvs, ivs, nub' dps) - getUid :: Trans Int getUid = do uid <- _nextUid <$> get @@ -312,5 +302,3 @@ curNode = _curNode <$> get newExtVarNode id t = modify $ \st -> st { _extVarsNodes = (id, t) : _extVarsNodes st } - --------------------------------------------------------------------------------- diff --git a/copilot-theorem/src/Copilot/Theorem/TransSys/Type.hs b/copilot-theorem/src/Copilot/Theorem/TransSys/Type.hs index f1b3007e7..e1408f044 100644 --- a/copilot-theorem/src/Copilot/Theorem/TransSys/Type.hs +++ b/copilot-theorem/src/Copilot/Theorem/TransSys/Type.hs @@ -1,7 +1,6 @@ --------------------------------------------------------------------------------- - -{-# LANGUAGE ExistentialQuantification, GADTs #-} -{-# LANGUAGE Safe #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE Safe #-} -- | Types suported by the modular transition systems. module Copilot.Theorem.TransSys.Type @@ -9,9 +8,7 @@ module Copilot.Theorem.TransSys.Type , U (..) ) where -import Copilot.Core.Type.Equality - --------------------------------------------------------------------------------- +import Data.Type.Equality -- | A type at both value and type level. -- @@ -22,24 +19,18 @@ data Type a where Real :: Type Double -- | Proofs of type equality. -instance EqualType Type where - Bool =~= Bool = Just Refl - Integer =~= Integer = Just Refl - Real =~= Real = Just Refl - _ =~= _ = Nothing - --------------------------------------------------------------------------------- +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" - --------------------------------------------------------------------------------- diff --git a/copilot-theorem/src/Copilot/Theorem/What4.hs b/copilot-theorem/src/Copilot/Theorem/What4.hs index 7607d2438..97e55a852 100644 --- a/copilot-theorem/src/Copilot/Theorem/What4.hs +++ b/copilot-theorem/src/Copilot/Theorem/What4.hs @@ -1,18 +1,13 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} -- | -- Module : Copilot.Theorem.What4 @@ -26,90 +21,75 @@ -- @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. Very simple specifications --- are unprovable by this technique, including: +-- not proved true, that does not mean it isn't true; the proof may fail because +-- the given property is not inductive. -- --- @ --- a = True : a --- @ --- --- The above specification will not be proved true. The reason is that this --- technique does not perform any sort of induction. When proving the inner @a@ --- expression, the technique merely allocates a fresh constant standing for --- "@a@, one timestep in the past." Nothing is asserted about the fresh --- constant. --- --- An example of a property that is provable by this approach is: --- --- @ --- a = True : b --- b = not a --- --- -- Property: a || b --- @ +-- 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. -- --- By allocating a fresh constant, @b_-1@, standing for "the value of @b@ one --- timestep in the past", the equation for @a || b@ at some arbitrary point in --- the future reduces to @b_-1 || not b_-1@, which is always true. --- --- In addition to proving that the stream expression is true at some arbitrary --- point in the future, we also prove it for the first @k@ timesteps, where @k@ --- is the maximum buffer length of all streams in the given spec. This amounts --- to simply interpreting the spec, although external variables are still --- represented as constants with unknown values. - +-- 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 - ( prove, Solver(..), SatResult(..) + ( -- * 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.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 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.BaseTypes as WT -import qualified What4.Solver as WS -import qualified What4.Solver.DReal as WS - -import qualified Control.Monad.Fail as Fail +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 (elemIndex) -import Data.Maybe (fromJust) +import Data.List (genericLength) import qualified Data.Map as Map -import Data.Parameterized.Classes -import Data.Parameterized.Context hiding (zipWithM) +import Data.Parameterized.Classes (ShowF) import Data.Parameterized.NatRepr import Data.Parameterized.Nonce import Data.Parameterized.Some -import Data.Parameterized.SymbolRepr import qualified Data.Parameterized.Vector as V -import Data.Word -import LibBF ( bfToDouble - , bfFromDouble - , bfPosZero - , pattern NearEven ) -import GHC.TypeNats (KnownNat) +import GHC.Float (castWord32ToFloat, castWord64ToDouble, double2Float) +import LibBF (BigFloat, bfToDouble, pattern NearEven) +import Numeric.Floating.IEEE.NaN (getPayload, isSignaling, setPayload, setPayloadSignaling) 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. --- | We assume round-near-even throughout, but this variable can be changed if --- needed. -fpRM :: WI.RoundingMode -fpRM = WI.RNE - -- | No builder state needed. data BuilderState a = EmptyState @@ -121,17 +101,256 @@ data Solver = CVC4 | DReal | Yices | Z3 data SatResult = Valid | Invalid | Unknown deriving Show -type CounterExample = [(String, Some CopilotValue)] +-- | 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 = do +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 @@ -143,151 +362,339 @@ prove solver spec = do Yices -> WC.extendConfig WS.yicesOptions (WI.getConfiguration sym) Z3 -> WC.extendConfig WS.z3Options (WI.getConfiguration sym) - -- Build up initial translation state - let streamMap = Map.fromList $ - (\stream -> (CS.streamId stream, stream)) <$> CS.specStreams spec - pow <- WI.freshTotalUninterpFn sym (WI.safeSymbol "pow") knownRepr knownRepr - logb <- WI.freshTotalUninterpFn sym (WI.safeSymbol "logb") knownRepr knownRepr - let st = TransState Map.empty Map.empty Map.empty streamMap pow logb + -- 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)) - -- Define TransM action for proving properties. Doing this in TransM rather - -- than IO allows us to reuse the state for each property. + -- 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 - let bufLen (CS.Stream _ buf _ _) = length buf - maxBufLen = maximum (0 : (bufLen <$> CS.specStreams spec)) - prefix <- forM [0 .. maxBufLen - 1] $ \k -> do - XBool p <- translateExprAt sym k (CS.propertyExpr pr) - return p - XBool p <- translateExpr sym 0 (CS.propertyExpr pr) - p_and_prefix <- liftIO $ foldrM (WI.andPred sym) p prefix - not_p_and_prefix <- liftIO $ WI.notPred sym p_and_prefix - - let clauses = [not_p_and_prefix] - case solver of - CVC4 -> liftIO $ WS.runCVC4InOverride sym WS.defaultLogData clauses $ \case - WS.Sat (_ge, _) -> return (CS.propertyName pr, Invalid) - WS.Unsat _ -> return (CS.propertyName pr, Valid) - WS.Unknown -> return (CS.propertyName pr, Unknown) - DReal -> liftIO $ WS.runDRealInOverride sym WS.defaultLogData clauses $ \case - WS.Sat (_ge, _) -> return (CS.propertyName pr, Invalid) - WS.Unsat _ -> return (CS.propertyName pr, Valid) - WS.Unknown -> return (CS.propertyName pr, Unknown) - Yices -> liftIO $ WS.runYicesInOverride sym WS.defaultLogData clauses $ \case - WS.Sat _ge -> return (CS.propertyName pr, Invalid) - WS.Unsat _ -> return (CS.propertyName pr, Valid) - WS.Unknown -> return (CS.propertyName pr, Unknown) - Z3 -> liftIO $ WS.runZ3InOverride sym WS.defaultLogData clauses $ \case - WS.Sat (_ge, _) -> return (CS.propertyName pr, Invalid) - WS.Unsat _ -> return (CS.propertyName pr, Valid) - WS.Unknown -> return (CS.propertyName pr, Unknown) + -- 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 - (res, _) <- runStateT (unTransM proveProperties) st - return res - --------------------------------------------------------------------------------- --- What4 translation - --- | 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. + 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'. -- --- We also store three immutable fields in this state, rather than wrap them up --- in another monad transformer layer. These are initialized prior to --- translation and are never modified. They are the map from stream ids to the --- core stream definitions, a symbolic uninterpreted function for "pow", and a --- symbolic uninterpreted function for "logb". -data TransState t = TransState { - -- | Map of all external variables we encounter during translation. These are - -- just fresh constants. The offset indicates how many timesteps in the past - -- this constant represents for that stream. - externVars :: Map.Map (CE.Name, Int) (XExpr t), - -- | Map of external variables at specific indices (positive), rather than - -- offset into the past. This is for interpreting streams at specific offsets. - externVarsAt :: Map.Map (CE.Name, Int) (XExpr t), - -- | Map from (stream id, negative offset) to fresh constant. These are all - -- constants representing the values of a stream at some point in the past. - -- The offset (ALWAYS NEGATIVE) indicates how many timesteps in the past - -- this constant represents for that stream. - streamConstants :: Map.Map (CE.Id, Int) (XExpr t), - -- | 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, - -- | Binary power operator, represented as an uninterpreted function. - pow :: WB.ExprSymFn t - (EmptyCtx ::> WT.BaseRealType ::> WT.BaseRealType) - WT.BaseRealType, - -- | Binary logarithm operator, represented as an uninterpreted function. - logb :: WB.ExprSymFn t - (EmptyCtx ::> WT.BaseRealType ::> WT.BaseRealType) - WT.BaseRealType - } - -newtype TransM t a = TransM { unTransM :: StateT (TransState t) IO a } - deriving ( Functor - , Applicative - , Monad - , MonadIO - , MonadState (TransState t) - ) - -instance Fail.MonadFail (TransM t) where - fail = error - -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 --- copilot-core's "reify" function did something incorrectly. -panic :: MonadIO m => m a -panic = Panic.panic CopilotWhat4 "Copilot.Theorem.What4" - [ "Ill-typed core expression" ] - --- | 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 t' 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 t where - XBool :: WB.Expr t WT.BaseBoolType -> XExpr t - XInt8 :: WB.Expr t (WT.BaseBVType 8) -> XExpr t - XInt16 :: WB.Expr t (WT.BaseBVType 16) -> XExpr t - XInt32 :: WB.Expr t (WT.BaseBVType 32) -> XExpr t - XInt64 :: WB.Expr t (WT.BaseBVType 64) -> XExpr t - XWord8 :: WB.Expr t (WT.BaseBVType 8) -> XExpr t - XWord16 :: WB.Expr t (WT.BaseBVType 16) -> XExpr t - XWord32 :: WB.Expr t (WT.BaseBVType 32) -> XExpr t - XWord64 :: WB.Expr t (WT.BaseBVType 64) -> XExpr t - XFloat :: WB.Expr t (WT.BaseFloatType WT.Prec32) -> XExpr t - XDouble :: WB.Expr t (WT.BaseFloatType WT.Prec64) -> XExpr t - XEmptyArray :: XExpr t - XArray :: 1 <= n => V.Vector n (XExpr t) -> XExpr t - XStruct :: [XExpr t] -> XExpr t - -- XArray :: NatRepr n - -- -> BaseTypeRepr tp - -- -> Some (WB.Expr t) - -- XStruct :: Assignment BaseTypeRepr tps - -- -> WB.Expr t (BaseStructType tps) - -- -> XExpr t - -deriving instance Show (XExpr t) - -data CopilotValue a = CopilotValue { cvType :: CT.Type a - , cvVal :: a - } - -valFromExpr :: WG.GroundEvalFn t -> XExpr t -> IO (Some 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 @@ -299,648 +706,69 @@ valFromExpr ge xe = case xe of 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 . realToFrac . fst . bfToDouble NearEven <$> WG.groundEval ge e + Some . CopilotValue CT.Float <$> + iFloatGroundEval WFP.SingleFloatRepr e + (nanSafeDoubleToFloat . fst . bfToDouble NearEven) + fromRational + (castWord32ToFloat . fromInteger . BV.asUnsigned) XDouble e -> - Some . CopilotValue CT.Double . fst . bfToDouble NearEven <$> WG.groundEval ge e - _ -> error "valFromExpr unhandled case" - where fromBV :: forall a w . Num a => BV.BV w -> a - fromBV = fromInteger . BV.asUnsigned - --- | 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 t where - SomeBVExpr :: 1 <= w - => WB.BVExpr t w - -> NatRepr w - -> BVSign - -> (WB.BVExpr t w -> XExpr t) - -> SomeBVExpr t - --- | 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 - --- | If the inner expression can be viewed as a bitvector, we project out a view --- of it as such. -asBVExpr :: XExpr t -> Maybe (SomeBVExpr t) -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 - --- | Translate a constant expression by creating a what4 literal and packaging --- it up into an 'XExpr'. -translateConstExpr :: forall a t st fs . - WB.ExprBuilder t st fs - -> CT.Type a - -> a - -> IO (XExpr t) -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 <$> WI.floatLit sym knownRepr (bfFromDouble (realToFrac a)) - CT.Double -> XDouble <$> WI.floatLit sym knownRepr (bfFromDouble a) - CT.Array tp -> do - elts <- traverse (translateConstExpr sym tp) (CT.arrayelems a) - Just (Some n) <- return $ someNat (length elts) - case isZeroOrGT1 n of - Left Refl -> return XEmptyArray - Right LeqProof -> do - let Just v = V.fromList n elts - return $ 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 t st fs a . - WB.ExprBuilder t st fs - -> String - -> CT.Type a - -> IO (XExpr t) -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 <$> WI.freshConstant sym (WI.safeSymbol nm) knownRepr - CT.Double -> XDouble <$> WI.freshConstant sym (WI.safeSymbol nm) knownRepr - atp@(CT.Array itp) -> do - n <- return $ arrayLen atp - case isZeroOrGT1 n of - Left Refl -> return XEmptyArray - 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 - --- | Get the constant for a given stream id and some offset into the past. This --- should only be called with a strictly negative offset. When this function --- gets called for the first time for a given (streamId, offset) pair, it --- generates a fresh constant and stores it in an internal map. Thereafter, this --- function will just return that constant when called with the same pair. -getStreamConstant :: WB.ExprBuilder t st fs -> CE.Id -> Int -> TransM t (XExpr t) -getStreamConstant sym streamId offset = do - scs <- gets streamConstants - case Map.lookup (streamId, offset) scs of - Just xe -> return xe - Nothing -> do - CS.Stream _ _ _ tp <- getStreamDef streamId - let nm = show streamId ++ "_" ++ show offset - xe <- liftIO $ freshCPConstant sym nm tp - modify (\st -> st { streamConstants = Map.insert (streamId, offset) xe scs }) - return xe - --- | Get the constant for a given external variable and some offset into the --- past. This should only be called with a strictly negative offset. When this --- function gets called for the first time for a given (var, offset) pair, it --- generates a fresh constant and stores it in an internal map. Thereafter, this --- function will just return that constant when called with the same pair. -getExternConstant :: WB.ExprBuilder t st fs - -> CT.Type a - -> CE.Name - -> Int - -> TransM t (XExpr t) -getExternConstant sym tp var offset = do - es <- gets externVars - case Map.lookup (var, offset) es of - Just xe -> return xe - Nothing -> do - xe <- liftIO $ freshCPConstant sym var tp - modify (\st -> st { externVars = Map.insert (var, offset) xe es} ) - return xe - --- | Get the constant for a given external variable at some specific timestep. -getExternConstantAt :: WB.ExprBuilder t st fs - -> CT.Type a - -> CE.Name - -> Int - -> TransM t (XExpr t) -getExternConstantAt sym tp var ix = do - es <- gets externVarsAt - case Map.lookup (var, ix) es of - Just xe -> return xe - Nothing -> do - xe <- liftIO $ freshCPConstant sym var tp - modify (\st -> st { externVarsAt = Map.insert (var, ix) xe es} ) - return xe - --- | Retrieve a stream definition given its id. -getStreamDef :: CE.Id -> TransM t CS.Stream -getStreamDef streamId = fromJust <$> gets (Map.lookup streamId . streams) - --- | Translate an expression into a what4 representation. The int offset keeps --- track of how many timesteps into the past each variable is referring to. --- Initially the value should be zero, but when we translate a stream, the --- offset is recomputed based on the length of that stream's prefix (subtracted) --- and the drop index (added). -translateExpr :: WB.ExprBuilder t st fs - -> Int - -- ^ number of timesteps in the past we are currently looking - -- (must always be <= 0) - -> CE.Expr a - -> TransM t (XExpr t) -translateExpr sym offset e = case e of - CE.Const tp a -> liftIO $ translateConstExpr sym tp a - CE.Drop _tp ix streamId - -- If we are referencing a past value of this stream, just return an - -- unconstrained constant. - | offset + fromIntegral ix < 0 -> - getStreamConstant sym streamId (offset + fromIntegral ix) - -- If we are referencing a current or future value of this stream, we need - -- to translate the stream's expression, using an offset computed based on - -- the current offset (negative or 0), the drop index (positive or 0), and - -- the length of the stream's buffer (subtracted). - | otherwise -> do - CS.Stream _ buf e _ <- getStreamDef streamId - translateExpr sym (offset + fromIntegral ix - length buf) e - CE.Local _ _ _ _ _ -> error "translateExpr: Local unimplemented" - CE.Var _ _ -> error "translateExpr: Var unimplemented" - CE.ExternVar tp nm _prefix -> getExternConstant sym tp nm offset - CE.Op1 op e -> liftIO . translateOp1 sym op =<< translateExpr sym offset e - CE.Op2 op e1 e2 -> do - xe1 <- translateExpr sym offset e1 - xe2 <- translateExpr sym offset e2 - powFn <- gets pow - logbFn <- gets logb - liftIO $ translateOp2 sym powFn logbFn op xe1 xe2 - CE.Op3 op e1 e2 e3 -> do - xe1 <- translateExpr sym offset e1 - xe2 <- translateExpr sym offset e2 - xe3 <- translateExpr sym offset e3 - liftIO $ translateOp3 sym op xe1 xe2 xe3 - CE.Label _ _ _ -> error "translateExpr: Label unimplemented" - --- | Translate an expression into a what4 representation at a /specific/ --- timestep, rather than "at some indeterminate point in the future." -translateExprAt :: WB.ExprBuilder t st fs - -> Int - -- ^ Index of timestep - -> CE.Expr a - -- ^ stream expression - -> TransM t (XExpr t) -translateExprAt sym k e = do - case e of - CE.Const tp a -> liftIO $ translateConstExpr sym tp a - CE.Drop _tp ix streamId -> do - CS.Stream _ buf e tp <- getStreamDef streamId - if k' < length buf - then liftIO $ translateConstExpr sym tp (buf !! k') - else translateExprAt sym (k' - length buf) e - where k' = k + fromIntegral ix - CE.Local _ _ _ _ _ -> error "translateExpr: Local unimplemented" - CE.Var _ _ -> error "translateExpr: Var unimplemented" - CE.ExternVar tp nm _prefix -> getExternConstantAt sym tp nm k - CE.Op1 op e -> liftIO . translateOp1 sym op =<< translateExprAt sym k e - CE.Op2 op e1 e2 -> do - xe1 <- translateExprAt sym k e1 - xe2 <- translateExprAt sym k e2 - powFn <- gets pow - logbFn <- gets logb - liftIO $ translateOp2 sym powFn logbFn op xe1 xe2 - CE.Op3 op e1 e2 e3 -> do - xe1 <- translateExprAt sym k e1 - xe2 <- translateExprAt sym k e2 - xe3 <- translateExprAt sym k e3 - liftIO $ translateOp3 sym op xe1 xe2 xe3 - CE.Label _ _ _ -> error "translateExpr: Label unimplemented" - -type BVOp1 w t = (KnownNat w, 1 <= w) => WB.BVExpr t w -> IO (WB.BVExpr t w) - -type FPOp1 fpp t = KnownRepr WT.FloatPrecisionRepr fpp => WB.Expr t (WT.BaseFloatType fpp) -> IO (WB.Expr t (WT.BaseFloatType fpp)) - -type RealOp1 t = WB.Expr t WT.BaseRealType -> IO (WB.Expr t WT.BaseRealType) - -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 t st fs a b . - WB.ExprBuilder t st fs - -> CE.Op1 a b - -> XExpr t - -> IO (XExpr t) -translateOp1 sym op xe = case (op, xe) of - (CE.Not, XBool e) -> XBool <$> WI.notPred sym e - (CE.Not, _) -> panic - (CE.Abs _, xe) -> numOp bvAbs fpAbs xe - where bvAbs :: BVOp1 w t - 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 :: FPOp1 fpp t - fpAbs e = do zero <- WI.floatLit sym knownRepr bfPosZero - e_neg <- WI.floatLt sym e zero - neg_e <- WI.floatSub sym fpRM zero e - WI.floatIte sym e_neg neg_e e - (CE.Sign _, xe) -> numOp bvSign fpSign xe - where bvSign :: BVOp1 w t - 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_zero <- WI.bvEq sym e zero - e_neg <- WI.bvSlt sym e zero - t <- WI.bvIte sym e_neg neg_one pos_one - WI.bvIte sym e_zero zero t - fpSign :: FPOp1 fpp t - fpSign e = do zero <- WI.floatLit sym knownRepr bfPosZero - neg_one <- WI.floatLit sym knownRepr (bfFromDouble (-1.0)) - pos_one <- WI.floatLit sym knownRepr (bfFromDouble 1.0) - e_zero <- WI.floatEq sym e zero - e_neg <- WI.floatLt sym e zero - t <- WI.floatIte sym e_neg neg_one pos_one - WI.floatIte sym e_zero zero t - (CE.Recip _, xe) -> fpOp recip xe - where recip :: FPOp1 fpp t - recip e = do one <- WI.floatLit sym knownRepr (bfFromDouble 1.0) - WI.floatDiv sym fpRM one e - (CE.Exp _, xe) -> realOp (WI.realExp sym) xe - (CE.Sqrt _, xe) -> fpOp (WI.floatSqrt sym fpRM) xe - (CE.Log _, xe) -> realOp (WI.realLog sym) xe - (CE.Sin _, xe) -> realOp (WI.realSin sym) xe - (CE.Cos _, xe) -> realOp (WI.realCos sym) xe - (CE.Tan _, xe) -> realOp (WI.realTan sym) xe - (CE.Asin _, xe) -> realOp (realRecip <=< WI.realSin sym) xe - (CE.Acos _, xe) -> realOp (realRecip <=< WI.realCos sym) xe - (CE.Atan _, xe) -> realOp (realRecip <=< WI.realTan sym) xe - (CE.Sinh _, xe) -> realOp (WI.realSinh sym) xe - (CE.Cosh _, xe) -> realOp (WI.realCosh sym) xe - (CE.Tanh _, xe) -> realOp (WI.realTanh sym) xe - (CE.Asinh _, xe) -> realOp (realRecip <=< WI.realSinh sym) xe - (CE.Acosh _, xe) -> realOp (realRecip <=< WI.realCosh sym) xe - (CE.Atanh _, xe) -> realOp (realRecip <=< WI.realTanh sym) xe - (CE.BwNot _, xe) -> case xe of - XBool e -> XBool <$> WI.notPred sym e - _ -> bvOp (WI.bvNotBits sym) xe - (CE.Cast _ tp, xe) -> case (xe, tp) of - (XBool e, CT.Bool) -> return $ XBool e - (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 e, CT.Int8) -> return $ XInt8 e - (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 e, CT.Int16) -> return $ XInt16 e - (XInt16 e, CT.Int32) -> XInt32 <$> WI.bvSext sym knownNat e - (XInt16 e, CT.Int64) -> XInt64 <$> WI.bvSext sym knownNat e - (XInt32 e, CT.Int32) -> return $ XInt32 e - (XInt32 e, CT.Int64) -> XInt64 <$> WI.bvSext sym knownNat e - (XInt64 e, CT.Int64) -> return $ XInt64 e - (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 e, CT.Word8) -> return $ XWord8 e - (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 e, CT.Word16) -> return $ XWord16 e - (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 e, CT.Word32) -> return $ XWord32 e - (XWord32 e, CT.Word64) -> XWord64 <$> WI.bvZext sym knownNat e - (XWord64 e, CT.Word64) -> return $ XWord64 e - _ -> panic - (CE.GetField (CT.Struct s) _ftp extractor, XStruct xes) -> do - let fieldNameRepr = fieldName (extractor undefined) - let structFieldNameReprs = valueName <$> CT.toValues s - let mIx = elemIndex (Some fieldNameRepr) structFieldNameReprs - case mIx of - Just ix -> return $ xes !! ix - Nothing -> panic - _ -> panic - where numOp :: (forall w . BVOp1 w t) - -> (forall fpp . FPOp1 fpp t) - -> XExpr t - -> IO (XExpr t) - 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 e - XDouble e -> XDouble <$> fpOp e - _ -> panic - - bvOp :: (forall w . BVOp1 w t) -> XExpr t -> IO (XExpr t) - 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 - _ -> panic - - fpOp :: (forall fpp . FPOp1 fpp t) -> XExpr t -> IO (XExpr t) - fpOp g xe = case xe of - XFloat e -> XFloat <$> g e - XDouble e -> XDouble <$> g e - _ -> panic - - realOp :: RealOp1 t -> XExpr t -> IO (XExpr t) - realOp h xe = fpOp hf xe - where hf :: (forall fpp . FPOp1 fpp t) - hf e = do re <- WI.floatToReal sym e - hre <- h re - WI.realToFloat sym knownRepr fpRM hre - - realRecip :: RealOp1 t - realRecip e = do one <- WI.realLit sym 1 - WI.realDiv sym one e - -type BVOp2 w t = (KnownNat w, 1 <= w) => WB.BVExpr t w -> WB.BVExpr t w -> IO (WB.BVExpr t w) - -type FPOp2 fpp t = KnownRepr WT.FloatPrecisionRepr fpp => WB.Expr t (WT.BaseFloatType fpp) -> WB.Expr t (WT.BaseFloatType fpp) -> IO (WB.Expr t (WT.BaseFloatType fpp)) - -type RealOp2 t = WB.Expr t WT.BaseRealType -> WB.Expr t WT.BaseRealType -> IO (WB.Expr t WT.BaseRealType) - -type BoolCmp2 t = WB.BoolExpr t -> WB.BoolExpr t -> IO (WB.BoolExpr t) - -type BVCmp2 w t = (KnownNat w, 1 <= w) => WB.BVExpr t w -> WB.BVExpr t w -> IO (WB.BoolExpr t) - -type FPCmp2 fpp t = KnownRepr WT.FloatPrecisionRepr fpp => WB.Expr t (WT.BaseFloatType fpp) -> WB.Expr t (WT.BaseFloatType fpp) -> IO (WB.BoolExpr t) - -translateOp2 :: forall t st fs a b c . - WB.ExprBuilder t st fs - -> (WB.ExprSymFn t - (EmptyCtx ::> WT.BaseRealType ::> WT.BaseRealType) - WT.BaseRealType) - -- ^ Pow function - -> (WB.ExprSymFn t - (EmptyCtx ::> WT.BaseRealType ::> WT.BaseRealType) - WT.BaseRealType) - -- ^ Logb function - -> CE.Op2 a b c - -> XExpr t - -> XExpr t - -> IO (XExpr t) -translateOp2 sym powFn logbFn op xe1 xe2 = case (op, xe1, xe2) of - (CE.And, XBool e1, XBool e2) -> XBool <$> WI.andPred sym e1 e2 - (CE.Or, XBool e1, XBool e2) -> XBool <$> WI.orPred sym e1 e2 - (CE.Add _, xe1, xe2) -> numOp (WI.bvAdd sym) (WI.floatAdd sym fpRM) xe1 xe2 - (CE.Sub _, xe1, xe2) -> numOp (WI.bvSub sym) (WI.floatSub sym fpRM) xe1 xe2 - (CE.Mul _, xe1, xe2) -> numOp (WI.bvMul sym) (WI.floatMul sym fpRM) xe1 xe2 - (CE.Mod _, xe1, xe2) -> bvOp (WI.bvSrem sym) (WI.bvUrem sym) xe1 xe2 - (CE.Div _, xe1, xe2) -> bvOp (WI.bvSdiv sym) (WI.bvUdiv sym) xe1 xe2 - (CE.Fdiv _, xe1, xe2) -> fpOp (WI.floatDiv sym fpRM) xe1 xe2 - (CE.Pow _, xe1, xe2) -> fpOp powFn' xe1 xe2 - where powFn' :: FPOp2 fpp t - powFn' e1 e2 = do re1 <- WI.floatToReal sym e1 - re2 <- WI.floatToReal sym e2 - let args = (Empty :> re1 :> re2) - rpow <- WI.applySymFn sym powFn args - WI.realToFloat sym knownRepr fpRM rpow - (CE.Logb _, xe1, xe2) -> fpOp logbFn' xe1 xe2 - where logbFn' :: FPOp2 fpp t - logbFn' e1 e2 = do re1 <- WI.floatToReal sym e1 - re2 <- WI.floatToReal sym e2 - let args = (Empty :> re1 :> re2) - rpow <- WI.applySymFn sym logbFn args - WI.realToFloat sym knownRepr fpRM rpow - (CE.Eq _, xe1, xe2) -> cmp (WI.eqPred sym) (WI.bvEq sym) (WI.floatEq sym) xe1 xe2 - (CE.Ne _, xe1, xe2) -> cmp neqPred bvNeq fpNeq xe1 xe2 - where neqPred :: BoolCmp2 t - neqPred e1 e2 = do e <- WI.eqPred sym e1 e2 - WI.notPred sym e - bvNeq :: forall w . BVCmp2 w t - bvNeq e1 e2 = do e <- WI.bvEq sym e1 e2 - WI.notPred sym e - fpNeq :: forall fpp . FPCmp2 fpp t - fpNeq e1 e2 = do e <- WI.floatEq sym e1 e2 - WI.notPred sym e - (CE.Le _, xe1, xe2) -> numCmp (WI.bvSle sym) (WI.bvUle sym) (WI.floatLe sym) xe1 xe2 - (CE.Ge _, xe1, xe2) -> numCmp (WI.bvSge sym) (WI.bvUge sym) (WI.floatGe sym) xe1 xe2 - (CE.Lt _, xe1, xe2) -> numCmp (WI.bvSlt sym) (WI.bvUlt sym) (WI.floatLt sym) xe1 xe2 - (CE.Gt _, xe1, xe2) -> numCmp (WI.bvSgt sym) (WI.bvUgt sym) (WI.floatGt sym) xe1 xe2 - (CE.BwAnd _, xe1, xe2) -> bvOp (WI.bvAndBits sym) (WI.bvAndBits sym) xe1 xe2 - (CE.BwOr _, xe1, xe2) -> bvOp (WI.bvOrBits sym) (WI.bvOrBits sym) xe1 xe2 - (CE.BwXor _, xe1, xe2) -> bvOp (WI.bvXorBits sym) (WI.bvXorBits sym) xe1 xe2 - -- Note: For both shift operators, we are interpreting the shifter as an - -- unsigned bitvector regardless of whether it is a word or an int. - (CE.BwShiftL _ _, xe1, xe2) -> do - Just (SomeBVExpr e1 w1 _ ctor1) <- return $ asBVExpr xe1 - Just (SomeBVExpr e2 w2 _ _ ) <- return $ asBVExpr xe2 - e2' <- case testNatCases w1 w2 of - NatCaseLT LeqProof -> WI.bvTrunc sym w1 e2 - NatCaseEQ -> return e2 - NatCaseGT LeqProof -> WI.bvZext sym w1 e2 - ctor1 <$> WI.bvShl sym e1 e2' - (CE.BwShiftR _ _, xe1, xe2) -> do - Just (SomeBVExpr e1 w1 sgn1 ctor1) <- return $ asBVExpr xe1 - Just (SomeBVExpr e2 w2 _ _ ) <- return $ asBVExpr xe2 - e2' <- case testNatCases w1 w2 of - NatCaseLT LeqProof -> WI.bvTrunc sym w1 e2 - NatCaseEQ -> return e2 - NatCaseGT LeqProof -> WI.bvZext sym w1 e2 - ctor1 <$> case sgn1 of - Signed -> WI.bvAshr sym e1 e2' - Unsigned -> WI.bvLshr sym e1 e2' - -- Note: Currently, copilot does not check if array indices are out of bounds, - -- even for constant expressions. 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. - (CE.Index _, xe1, xe2) -> do - case (xe1, xe2) of - (XArray xes, XWord32 ix) -> buildIndexExpr sym 0 ix xes - _ -> panic - _ -> panic - where numOp :: (forall w . BVOp2 w t) - -> (forall fpp . FPOp2 fpp t) - -> XExpr t - -> XExpr t - -> IO (XExpr t) - 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 e1 e2 - (XDouble e1, XDouble e2)-> XDouble <$> fpOp e1 e2 - _ -> panic - - bvOp :: (forall w . BVOp2 w t) - -> (forall w . BVOp2 w t) - -> XExpr t - -> XExpr t - -> IO (XExpr t) - 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 - _ -> panic - - fpOp :: (forall fpp . FPOp2 fpp t) - -> XExpr t - -> XExpr t - -> IO (XExpr t) - fpOp op xe1 xe2 = case (xe1, xe2) of - (XFloat e1, XFloat e2) -> XFloat <$> op e1 e2 - (XDouble e1, XDouble e2) -> XDouble <$> op e1 e2 - _ -> panic - - cmp :: BoolCmp2 t - -> (forall w . BVCmp2 w t) - -> (forall fpp . FPCmp2 fpp t) - -> XExpr t - -> XExpr t - -> IO (XExpr t) - 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 e1 e2 - (XDouble e1, XDouble e2)-> XBool <$> fpOp e1 e2 - _ -> panic - - numCmp :: (forall w . BVCmp2 w t) - -> (forall w . BVCmp2 w t) - -> (forall fpp . FPCmp2 fpp t) - -> XExpr t - -> XExpr t - -> IO (XExpr t) - 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 e1 e2 - (XDouble e1, XDouble e2)-> XBool <$> fpOp e1 e2 - _ -> panic - - buildIndexExpr :: 1 <= n - => WB.ExprBuilder t st fs - -> Word32 - -- ^ Index - -> WB.Expr t (WT.BaseBVType 32) - -- ^ Index - -> V.Vector n (XExpr t) - -- ^ Elements - -> IO (XExpr t) - buildIndexExpr sym curIx ix xelts = case V.uncons xelts of - (xe, Left Refl) -> return xe - (xe, Right xelts') -> do - LeqProof <- return $ V.nonEmpty xelts' - rstExpr <- buildIndexExpr sym (curIx+1) ix xelts' - curIxExpr <- WI.bvLit sym knownNat (BV.word32 curIx) - ixEq <- WI.bvEq sym curIxExpr ix - mkIte sym ixEq xe rstExpr - - mkIte :: WB.ExprBuilder t st fs - -> WB.Expr t WT.BaseBoolType - -> XExpr t - -> XExpr t - -> IO (XExpr t) - 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 <$> WI.floatIte sym pred e1 e2 - (XDouble e1, XDouble e2) -> XDouble <$> WI.floatIte sym pred e1 e2 - (XStruct xes1, XStruct xes2) -> - XStruct <$> zipWithM (mkIte sym pred) xes1 xes2 - (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 - _ -> panic - - -translateOp3 :: forall t st fs a b c d . - WB.ExprBuilder t st fs - -> CE.Op3 a b c d - -> XExpr t - -> XExpr t - -> XExpr t - -> IO (XExpr t) -translateOp3 sym (CE.Mux _) (XBool te) xe1 xe2 = case (xe1, xe2) of - (XBool e1, XBool e2) -> XBool <$> WI.itePred sym te e1 e2 - (XInt8 e1, XInt8 e2) -> XInt8 <$> WI.bvIte sym te e1 e2 - (XInt16 e1, XInt16 e2) -> XInt16 <$> WI.bvIte sym te e1 e2 - (XInt32 e1, XInt32 e2) -> XInt32 <$> WI.bvIte sym te e1 e2 - (XInt64 e1, XInt64 e2) -> XInt64 <$> WI.bvIte sym te e1 e2 - (XWord8 e1, XWord8 e2) -> XWord8 <$> WI.bvIte sym te e1 e2 - (XWord16 e1, XWord16 e2) -> XWord16 <$> WI.bvIte sym te e1 e2 - (XWord32 e1, XWord32 e2) -> XWord32 <$> WI.bvIte sym te e1 e2 - (XWord64 e1, XWord64 e2) -> XWord64 <$> WI.bvIte sym te e1 e2 - (XFloat e1, XFloat e2) -> XFloat <$> WI.floatIte sym te e1 e2 - (XDouble e1, XDouble e2) -> XDouble <$> WI.floatIte sym te e1 e2 - _ -> panic -translateOp3 _ _ _ _ _ = panic + 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 + + -- Convert a Double to a Float. This function takes care to preserve + -- special floating-point values, such as negative zero, infinity, and NaN + -- values. + nanSafeDoubleToFloat :: Double -> Float + nanSafeDoubleToFloat x + -- double2Float does not preserve the payloads of NaN values, so we + -- include a special case for translating NaNs. + | isNaN x && isSignaling x = setPayloadSignaling payload + | isNaN x = setPayload payload + | otherwise = double2Float x + where + payload :: Float + payload = double2Float $ getPayload x diff --git a/copilot-theorem/src/Copilot/Theorem/What4/Translate.hs b/copilot-theorem/src/Copilot/Theorem/What4/Translate.hs new file mode 100644 index 000000000..00edf8744 --- /dev/null +++ b/copilot-theorem/src/Copilot/Theorem/What4/Translate.hs @@ -0,0 +1,1518 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# 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 diff --git a/copilot-theorem/tests/Main.hs b/copilot-theorem/tests/Main.hs new file mode 100644 index 000000000..780a4e1ec --- /dev/null +++ b/copilot-theorem/tests/Main.hs @@ -0,0 +1,18 @@ +-- | 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 + ] diff --git a/copilot-theorem/tests/Test/Copilot/Theorem/What4.hs b/copilot-theorem/tests/Test/Copilot/Theorem/What4.hs new file mode 100644 index 000000000..edd137700 --- /dev/null +++ b/copilot-theorem/tests/Test/Copilot/Theorem/What4.hs @@ -0,0 +1,315 @@ +{-# 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 diff --git a/copilot-verifier/CHANGELOG b/copilot-verifier/CHANGELOG new file mode 100644 index 000000000..c69ccd708 --- /dev/null +++ b/copilot-verifier/CHANGELOG @@ -0,0 +1,75 @@ +2026-11-07 + * Version bump (4.8.2). (#792) + +2026-09-07 + * Version bump (4.8.1). (#760) + +2026-07-07 + * Version bump (4.8). (#745) + +2026-05-07 + * Version bump (4.7.1). (#730) + +2026-03-07 + * Version bump (4.7). (#714) + * Relax version constraints on what4. (#716) + +2026-01-07 + * Version bump (4.6.1). (#705) + +2025-11-07 + * Version bump (4.6). (#679) + +2025-09-07 + * Version bump (4.5.1). (#666) + +2025-07-07 + * Version bump (4.5). (#642) + * Include `copilot-verifier` in mainline `copilot` repo. (#622) + +2025-05-08 + * Version bump (4.4). (copilot-verifier#85) + +2025-03-10 + * Version bump (4.3). (copilot-verifier#82) + * Add `smtSolver` option to `VerifierOptions`. (copilot-verifier#78) + * Add `smtFloatMode` option to `VerifierOptions`. (copilot-verifier#79) + +2025-01-20 + * Version bump (4.2). (copilot-verifier#76) + * Reject specs that use multiple triggers with the same name. + (copilot-verifier#74) + +2024-11-08 + * Version bump (4.1). (copilot-verifier#72) + +2024-09-09 + * Version bump (4.0). (copilot-verifier#69) + * Support verifying programs that use array updates. + (copilot-verifier#63) + * Support verifying programs that use struct updates. + (copilot-verifier#57) + +2024-08-03 + * Support building with `crucible-llvm-0.7` and `crux-llvm-0.9`. + (copilot-verifier#64) + * Support GHC 9.4 through 9.8. (copilot-verifier#65) + +2024-07-30 + * When using `Noisy` verbosity, always log proof goals related to the + core correspondence proof, even if the goals are trivial. + (copilot-verifier#51) + * When using `Noisy` verbosity, log more information about which proof + goals arise before or after calling the `step()` function. + (copilot-verifier#52) + +2024-07-11 + * Version bump (3.20). (copilot-verifier#58) + +2024-03-08 + * Version bump (3.19). (copilot-verifier#53) + * Provide more detailed feedback upon a successful run of the verifier. + * Make the examples build with Copilot 3.19. (copilot-verifier#53) + +2024-02-06 + * Initial release of `copilot-verifier`. diff --git a/copilot-verifier/LICENSE b/copilot-verifier/LICENSE new file mode 100644 index 000000000..7192c3586 --- /dev/null +++ b/copilot-verifier/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2021-2024 Galois Inc. +All rights reserved. + +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 Galois, Inc. 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. diff --git a/copilot-verifier/README.md b/copilot-verifier/README.md new file mode 100644 index 000000000..85e28d9f5 --- /dev/null +++ b/copilot-verifier/README.md @@ -0,0 +1,351 @@ +[![Build Status](https://github.com/Copilot-Language/copilot-verifier/workflows/copilot-verifier/badge.svg)](https://github.com/Copilot-Language/copilot-verifier/actions?query=workflow%3Acopilot-verifier) +[![Version on Hackage](https://img.shields.io/hackage/v/copilot-verifier.svg)](https://hackage.haskell.org/package/copilot-verifier) + +# Copilot Verifier + +Copilot Verifier is an add-on to the [Copilot Stream +DSL](https://copilot-language.github.io) for verifying the correctness of C +code generated by the `copilot-c99` package. + +The main idea of the verifier is to use the +[Crucible symbolic simulator](https://github.com/galoisinc/crucible) +to interpret the semantics of the generated C program and +and to produce verification conditions sufficient to guarantee +that the meaning of the generated program corresponds in a precise +way to the meaning of the original stream specification. The generated +verification conditions are then dispatched to SMT solvers to +be automatically solved. We will have more to say about exactly +what is meant by this correspondence below. + +Copilot Verifier is described in the ICFP 2023 paper [_Trustworthy Runtime +Verification via Bisimulation (Experience +Report)_](https://dl.acm.org/doi/abs/10.1145/3607841). + +## Building + +To build the verifier from source, first make sure you have met the following +prerequisites: + +* Ensure that you have the `cabal` and `ghc` executables in your `PATH`. If you + don't already have them, we recommend using `ghcup` to install them: + https://www.haskell.org/ghcup/. We recommend `Cabal` 3.10 or newer, and one of + GHC 9.4, 9.6, or 9.8. + +* Ensure that you have the `clang` and `llvm-link` utilities from LLVM in your + `PATH`. Currently, LLVM versions up to 16 are supported. LLVM binaries are + available at https://github.com/llvm/llvm-project/releases. + +* Ensure that you have the `z3` SMT solver in your `PATH`. `z3` binaries are + available at https://github.com/Z3Prover/z3/releases. + + Alternatively, the verifier can be configured to use one of the following + SMT solvers instead: + + * `cvc4`: https://cvc4.github.io/downloads.html + * `cvc5`: https://github.com/cvc5/cvc5/releases/ + * `yices`: https://yices.csl.sri.com + +Then, clone the repo and run: + +``` +$ git submodule update --init +$ cabal test copilot-verifier +``` + +This will clone the repository, build the verifier, and run the associated test +suite. If you have performed all of the steps above correctly, the test suite +should pass. + +We also provide a [Dockerfile](Dockerfile) which automates the process of +installing Copilot and the verifier. The Dockerfile can be built and run using +the following commands: + +``` +$ docker build -t . +$ docker run -it +``` + +Where `` is a unique name for the Docker image. + +## Using the Copilot Verifier + +The main interface to the verifier is the `Copilot.Verifier.verify` +function, which takes some options to drive the code generation +process and a Copilot `Spec` object. It will invoke the Copilot +code generator to obtain C sources, compile the C sources into +LLVM bitcode using the `clang` compiler front-end, then +parse and interpret the bitcode using `crucible`. After generating +verification conditions, it will dispatch them to an SMT solver, +and the result of those queries will be presented to the user. + +There are a number of examples (based on similar examples +from the main Copilot repository) demonstrating how to +incorporate the verifier into a Copilot program. +See the `copilot-verifier/examples` subdirectory of this repository. + +## Details of the Verification + +### Synopsis of Copilot semantics + +The Copilot DSL represents a certain nicely-behaved +class of discrete-time stream programs. Each `Stream` +in Copilot denotes an infinite stream of values; one may +just as well think that `Stream a` represents a pure mathematical +function `ℕ → a` from natural numbers to values of type `a`. +See the +[Copilot manual](https://ntrs.nasa.gov/api/citations/20200003164/downloads/20200003164.pdf) +for more details of the Copilot language itself and its semantics. + +One of the central design considerations for Copilot is that is should +be possible to implement stream programs using a fixed, finite amount +of storage. As a result, Copilot will only accept stream programs +that access a bounded amount of their input streams (including any +recursive stream references). This allows an +implementation strategy where the generated C code can use fixed-size +ring buffers to store a limited number of previous stream values. + +The execution model for the generated programs is that the program +starts in a state corresponding to stream values at time `t = 0`; +"external" stream input values are placed in distinguished global +variables by the calling environment, which then executes a `step()` +function to move to the next time step. The `step()` function captures +the values of these external inputs and does whatever computation is +necessary to update its internal state from time `t=n` to time +`t=n+1`. In addition, it will call any defined "trigger" functions +if the stream state at that time step satisfies the defined guard condition. +In short, the generated C program steps one moment at a time through +the stream program, consuming a sequence of input values provided by +a cooperating environment and calling handler functions whenever +states of interest occur. + +### The Desired Correspondence + +What does it mean, then, for a generated C program in this style +to correctly implement a given stream program? The intuition +is basically that after `n` calls to the `step` function, +the state of the ring-buffers of the C program should correctly +compute the value of the corresponding stream expression +evaluated at index `n`, assuming the C program has been fed +inputs corresponding to the first `n` values of the external stream +inputs. Moreover, the trigger functions should be called from +the `step` function exactly at the time values when the stream expressions +evaluate to true. + +The notion of correspondence for the values flowing in streams is +relatively straightforward: these values consist of fixed-width +machine integers, floating-point values, structs and fixed-length +arrays. For each, the appropriate notion of equality is fairly clear. + +Both the original `Stream` program and the generated C program +can be viewed straightforwardly as a transition system, and under +this view, the correspondence we want to establish is a bisimulation +between the states of the high-level stream program and the low-level +C program. The proof method for bisimulation requires us to provide +a "correspondence" relation between the program states, and then prove +three things about this relation: + +1. that the initial states of the programs are in the relation; +2. if we assume two arbitrary program states begin in the relation +and each takes a single transition (consuming corresponding inputs), +the resulting states are back in the relation; +3. that any observable +actions taken by one program are exactly mirrored by the other. + +On the high-level side of the bisimulation, the program +state is essentially just the value of the current time step `n`, +whereas on the C side it consists of the regions of global memory that +contain the ring-buffers and their current indices. The transition +relation for the high-level program just increments the time value by +one, and the transition for the C program is defined by the action +of the generated `step()` function. + +Suppose `s` is one of the stream definitions in the original Copilot +program which is required to retain `k` previous values; +let `buf` be the global variable name of the ring-buffer in the C +program, and `idx` be the global variable name maintaining the +current index into the ring buffer. Then the correspondence +relation is basically that `0 <= idx < k` and +`s[n+i] = buf[(idx+i) mod k]` as `i` ranges from `0 .. k-1`. +By abuse of notation, here we mean that `s[j]` is +the value of the stream expression `s` evaluated at index `j`, +whereas `buf[j]` means the value obtained by reading the `j`th value +of the buffer `buf` from memory. The overall correspondence relation +is a conjunction of statements like this, one for each stream +expression that is realized via a buffer. + +### Implementing the Bisimulation proof steps + +The kind of program correspondence property we desire is a largely +mechanical affair. As the code under consideration is automatically +generated, it has a very regular structure and is specifically +intended to implement the semantics we wich to verify it against. As +such, we expect these proofs to be highly automatable. + +The proof principle of bisimulation itself is not amenable +to reduction to SMT, as if falls outside the first-order theories +those solvers understand. Likewise, the semantics of Copilot +and C might possibly be reducible directly to SMT, but it would be +impractical to do so. However, we can reduce the individual +proof obligations mentioned above into a series of lower-level +logical statements that are amenable to SMT proof by +defining the logical semantics of stream programs, and using +symbolic simulation techniques to interpret the semantics of the +C program. Performing this reduction is the key contribution +of `copilot-verifier`. + +#### Initial state correspondence + +The proof first obligation we must discharge is to show that +the initial states of the two programs correspond. For each +stream `s` there is a corresponding `k`, which is the length of +the ring-buffer implementing it. We must simply verify that +the C program initializes its buffer with the first `k` values +of the stream `s`, and that the `idx` value starts at 0. +Because of the restrictions Copilot places on programs, these +first `k` values must be specified concretely and will not be +able to depend on any external inputs. As such, this step +is quite easily performed, as it requires only direct evaluation +of concrete inputs. + +#### Transition correspondence + +The bulk of the proof effort consists of demonstrating that +the bisimulation relation is preserved by transitions. +In order to do this step, we must begin with totally symbolic +initial states: we know nothing except that we are at some +arbitrary time value `n`, and that the C program buffers +correspond to their stream values as required by the relation. +Thus, we create fresh symbolic variables for the streams +from `n` to `n + k-1`, and for the values of all the involved +external streams at time `n`. Then, we run forward the Copilot +program by evaluating the stream recurrence expression to +compute the value of each stream at time `n+k`. + +Next we set up an initial state of the C program by choosing, +for each ring buffer, an arbitrary value for its current index +within its allowed range, and then writing the variables +corresponding to each stream value into the buffers at +their appropriate offsets. The symbolic simulator is then +invoked to compute the state update effects of the `step()` +function. Afterward, we read the poststate values from the +ring-buffers and verify that they correspond to the stream +values from `n+1` up to `n+k`. + +As part of symbolic simulation, Crucible may also generate +side-conditions that relate to memory safety of the program, or to +error conditions that must be avoided. All of the bisimulation +equivalence conditions and the safety side-conditions will be +submitted to an SMT solver. + +#### Observable effects + +For our purposes, the only observable effects of a Copilot program +relate to any "trigger" functions defined in the spec. Our task is to +show that the generated C code calls the external trigger functions if +and only if the corresponding guard condition is true, and that the +arguments passed to those functions are as expected. +This proof obligation is proved in the same phase along with +the transition relation proof above because the `step()` function +is responsible for both invoking triggers and for performing state +updates. + +The technique we use to perform this aspect of the proof is to +install "override" functions to the external symbols corresponding +to the C trigger functions before we begin symbolic simulation. +In a real system, the external environment would be responsible +for implementing these functions and taking whatever appropriate +action is necessary when the triggers fire. However, we are verifying +the generated code in isolation from its environment, so we have no +implementation in hand. Instead, the override will +essentially implement a stub function that simply captures its +arguments and the path condition under which it was called. +After simulation completes, the captured arguments and path condition +are required to be equivalent to the corresponding trigger guard +and arguments from the Copilot spec. These conditions are +discharged to the SMT solver at the same time as the transition +relation obligations. + +Because of the way we model the trigger functions, we make a number of +implicit assumptions about how the actual implementations of those +functions must behave. The most important of those assumptions is that +the trigger functions must not modify any memory under the control of +the Copilot program, including its ring buffers and stack. We also +assume that the trigger functions are well defined, i.e. they are +memory safe and do not perform any undefined behavior. + +#### Partial operations + +A generated C program may make use of partial operations. These range from +division, which can fail if the second argument is zero, to signed integer +arithmetic, which can overflow and result in undefined behavior. The verifier +has two modes for dealing with partial operations: + +1. Any invocation of a partial operation on undefined inputs in the generated + C program will result in an error, provided that the user did not add an + assertion that assumes this behavior will not occur. + +2. If the generated C program invokes a partial operation on undefined inputs, + the verifier will check if this coincides with a corresponding invocation + of a partial operation in the Copilot spec. If so, the verification will + succeed. In other words, the verifier will check that the spec and the + C program are "crash-equivalent". + +The verifier uses mode (1) by default, but mode (2) can be enabled by using +`Copilot.Verifier.verifyWithOptions sideCondVerifierOptions`. In this mode, +the verifier will analyze any invocation of a operation which could be partial +and generate a side condition that this operation will only be invoked on +well defined inputs. During the transition step of the bisimulation proof, +the verifier will add these side conditions as assumptions. Therefore, if +simulating the C program generates any side conditions due to invoking partial +operations, these side conditions from the C program should be dischargeable +using the corresponding side conditions from the Copilot spec. + +Mode (2) has the caveat that `clang` may compile C code to LLVM bitcode in +which a partial function is no longer applied to undefined inputs. For +instance, `clang` will sometimes promote 16-bit integer values to 32 bits +before performing arithmetic on them. This can turn an operation that would +result in signed 16-bit integer overflow into a 32-bit integer operation +that does _not_ overflow, for instance. + +### Caveats About the Verifier + +We rely on the `clang` compiler front-end to consume C source files +and produce LLVM intermediate language, which then becomes the input +to the later verification steps. To the extent that the input program +is not fully-portable C, `clang` may make implementation-specific +decisions about how to compile the program which might be made +different if compiled by a different compiler (e.g. `gcc`). We expect +this aspect to be mitigated by the fact that Copilot programs are +automatically generated into a rather simple subset of the C language, +and is designed to be as simple as possible. +Any code-generation bugs in `clang` itself may affect the soundness +of our verifier. Again, however, Copilot generates a well-understood +subset of the language, and we expect `clang` to be well-tested on +the code patterns produced. + +The semantics of LLVM bitcode, as encoded in the `crucible-llvm` +package, may have errors that affect soundness. We mitigate this risk +by testing our semantics against a corpus of verification problems +produced for the SV-COMP verification competition, paying special +attention to any soundness issues that arise. `Crux`, a standalone +verification system based on `crucible-llvm`, was a participant in the +2022 edition of SV-COMP. + +The semantics of Copilot programs, as encoded in the +`Copilot.Theorem.What4` module may have errors that affect soundness. +For the moment we do not have an effective mitigation strategy for +this risk other than manual examination and comparison against the +intended semantics of Copilot, as encoded in the interpreter. + +There is limited SMT solver support for floating-point values, +especially for transcendental functions like the trig primitives. As a +result, we reason about floating point expressions via uninterpreted +functions. In other words, we leave the semantics of the +floating-point operations totally abstract, and simply verify that the +Copilot program and the corresponding C program apply the same +operations in the same order. This is sound, but leaves the possibility +that the compiler will apply some correct transformation to +floating-point expressions that we are nonetheless unable to verify. +However, on low optimizations and without the `--fast-math` flag, +compilers generally (and `clang` in particular) are very reluctant to +rearrange floating-point code, and the verifications generally succeed. diff --git a/copilot-verifier/copilot-verifier.cabal b/copilot-verifier/copilot-verifier.cabal new file mode 100644 index 000000000..bcf1061bf --- /dev/null +++ b/copilot-verifier/copilot-verifier.cabal @@ -0,0 +1,152 @@ +Cabal-version: 2.2 +Name: copilot-verifier +Version: 4.8.2 +Author: Galois Inc. +Maintainer: rscott@galois.com +Copyright: (c) Galois, Inc 2021-2024 +License: BSD-3-Clause +License-file: LICENSE +Build-type: Simple +Category: Language +Synopsis: System for verifying the correctness of generated Copilot programs +Description: + @copilot-verifier@ is an add-on to the [Copilot Stream + DSL](https://copilot-language.github.io) for verifying the correctness of C + code generated by the @copilot-c99@ package. + . + @copilot-verifier@ uses the [Crucible symbolic + simulator](https://github.com/galoisinc/crucible) to interpret the semantics + of the generated C program and and to produce verification conditions + sufficient to guarantee that the meaning of the generated program corresponds + in a precise way to the meaning of the original stream specification. The + generated verification conditions are then dispatched to SMT solvers to be + automatically solved. +extra-doc-files: CHANGELOG, README.md + +source-repository head + type: git + location: https://github.com/GaloisInc/copilot-verifier + subdir: copilot-verifier + +common bldflags + ghc-options: -Wall + -Werror=incomplete-patterns + -Werror=missing-methods + -Werror=overlapping-patterns + -Wpartial-fields + -Wincomplete-uni-patterns + ghc-prof-options: -O2 -fprof-auto-exported + default-language: Haskell2010 + default-extensions: + NondecreasingIndentation + build-depends: + aeson >= 1.5 && < 2.3, + base >= 4.8 && < 4.20, + bv-sized >= 1.0.0 && < 1.1, + bytestring, + containers >= 0.5.9.0, + copilot-c99 >= 4.8.2 && < 4.9, + copilot-core >= 4.8.2 && < 4.9, + copilot-theorem >= 4.8.2 && < 4.9, + crucible >= 0.7.1 && < 0.8, + crucible-llvm >= 0.7 && < 0.8, + crux >= 0.7.1 && < 0.8, + crux-llvm >= 0.9 && < 0.10, + filepath, + lens, + llvm-pretty >= 0.12.1.0 && < 0.13, + mtl, + panic >= 0.3, + parameterized-utils >= 2.1.4 && < 2.2, + prettyprinter >= 1.7.0, + text, + transformers, + vector, + what4 >= 1.6.1 && < 1.8 + +library + import: bldflags + + hs-source-dirs: src + exposed-modules: + Copilot.Verifier + Copilot.Verifier.FloatMode + Copilot.Verifier.Log + Copilot.Verifier.Solver + +library copilot-verifier-examples + import: bldflags + + hs-source-dirs: examples + build-depends: + case-insensitive, + copilot >= 4.8.2 && < 4.9, + copilot-language >= 4.8.2 && < 4.9, + copilot-libraries >= 4.8.2 && < 4.9, + copilot-prettyprinter >= 4.8.2 && < 4.9, + copilot-verifier + exposed-modules: + Copilot.Verifier.Examples + + Copilot.Verifier.Examples.ShouldFail.Partial.AbsIntMin + Copilot.Verifier.Examples.ShouldFail.Partial.AddSignedWrap + Copilot.Verifier.Examples.ShouldFail.Partial.DivByZero + Copilot.Verifier.Examples.ShouldFail.Partial.IndexOutOfBounds + Copilot.Verifier.Examples.ShouldFail.Partial.ModByZero + Copilot.Verifier.Examples.ShouldFail.Partial.MulSignedWrap + Copilot.Verifier.Examples.ShouldFail.Partial.ShiftLTooLarge + Copilot.Verifier.Examples.ShouldFail.Partial.ShiftRTooLarge + Copilot.Verifier.Examples.ShouldFail.Partial.SubSignedWrap + + Copilot.Verifier.Examples.ShouldPass.Array + Copilot.Verifier.Examples.ShouldPass.ArrayGen + Copilot.Verifier.Examples.ShouldPass.ArrayOfStructs + Copilot.Verifier.Examples.ShouldPass.ArrayTriggerArgument + Copilot.Verifier.Examples.ShouldPass.Arith + Copilot.Verifier.Examples.ShouldPass.Clock + Copilot.Verifier.Examples.ShouldPass.Counter + Copilot.Verifier.Examples.ShouldPass.Engine + Copilot.Verifier.Examples.ShouldPass.FPNegation + Copilot.Verifier.Examples.ShouldPass.FPOps + Copilot.Verifier.Examples.ShouldPass.Heater + Copilot.Verifier.Examples.ShouldPass.IntOps + Copilot.Verifier.Examples.ShouldPass.Partial.AbsIntMin + Copilot.Verifier.Examples.ShouldPass.Partial.AddSignedWrap + Copilot.Verifier.Examples.ShouldPass.Partial.DivByZero + Copilot.Verifier.Examples.ShouldPass.Partial.IndexOutOfBounds + Copilot.Verifier.Examples.ShouldPass.Partial.ModByZero + Copilot.Verifier.Examples.ShouldPass.Partial.MulSignedWrap + Copilot.Verifier.Examples.ShouldPass.Partial.ShiftLTooLarge + Copilot.Verifier.Examples.ShouldPass.Partial.ShiftRTooLarge + Copilot.Verifier.Examples.ShouldPass.Partial.SubSignedWrap + Copilot.Verifier.Examples.ShouldPass.Structs + Copilot.Verifier.Examples.ShouldPass.UpdateArray + Copilot.Verifier.Examples.ShouldPass.UpdateStruct + Copilot.Verifier.Examples.ShouldPass.Voting + Copilot.Verifier.Examples.ShouldPass.WCV + +executable verify-examples + import: bldflags + + hs-source-dirs: exe + main-is: VerifyExamples.hs + build-depends: + case-insensitive, + copilot-verifier, + copilot-verifier-examples, + optparse-applicative + +test-suite copilot-verifier-test + import: bldflags + + type: exitcode-stdio-1.0 + hs-source-dirs: test + build-depends: + case-insensitive, + copilot-verifier, + copilot-verifier-examples, + silently >= 1.2, + tasty >= 0.10, + tasty-expected-failure >= 0.12, + tasty-hunit >= 0.10 + main-is: Test.hs diff --git a/copilot-verifier/examples/Copilot/Verifier/Examples.hs b/copilot-verifier/examples/Copilot/Verifier/Examples.hs new file mode 100644 index 000000000..7e593a7e9 --- /dev/null +++ b/copilot-verifier/examples/Copilot/Verifier/Examples.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE OverloadedStrings #-} +module Copilot.Verifier.Examples + ( shouldFailExamples + , shouldPassExamples + ) where + +import qualified Data.CaseInsensitive as CI +import Data.CaseInsensitive (CI) +import qualified Data.Map as Map +import Data.Map (Map) +import Data.Text (Text) + +import Copilot.Verifier (Verbosity) +import qualified Copilot.Verifier.Examples.ShouldFail.Partial.AbsIntMin as Fail.AbsIntMin +import qualified Copilot.Verifier.Examples.ShouldFail.Partial.AddSignedWrap as Fail.AddSignedWrap +import qualified Copilot.Verifier.Examples.ShouldFail.Partial.DivByZero as Fail.DivByZero +import qualified Copilot.Verifier.Examples.ShouldFail.Partial.IndexOutOfBounds as Fail.IndexOutOfBounds +import qualified Copilot.Verifier.Examples.ShouldFail.Partial.ModByZero as Fail.ModByZero +import qualified Copilot.Verifier.Examples.ShouldFail.Partial.MulSignedWrap as Fail.MulSignedWrap +import qualified Copilot.Verifier.Examples.ShouldFail.Partial.ShiftLTooLarge as Fail.ShiftLTooLarge +import qualified Copilot.Verifier.Examples.ShouldFail.Partial.ShiftRTooLarge as Fail.ShiftRTooLarge +import qualified Copilot.Verifier.Examples.ShouldFail.Partial.SubSignedWrap as Fail.SubSignedWrap +import qualified Copilot.Verifier.Examples.ShouldPass.Array as Array +import qualified Copilot.Verifier.Examples.ShouldPass.ArrayGen as ArrayGen +import qualified Copilot.Verifier.Examples.ShouldPass.ArrayOfStructs as ArrayOfStructs +import qualified Copilot.Verifier.Examples.ShouldPass.ArrayTriggerArgument as ArrayTriggerArgument +import qualified Copilot.Verifier.Examples.ShouldPass.Arith as Arith +import qualified Copilot.Verifier.Examples.ShouldPass.Clock as Clock +import qualified Copilot.Verifier.Examples.ShouldPass.Counter as Counter +import qualified Copilot.Verifier.Examples.ShouldPass.Engine as Engine +import qualified Copilot.Verifier.Examples.ShouldPass.FPNegation as FPNegation +import qualified Copilot.Verifier.Examples.ShouldPass.FPOps as FPOps +import qualified Copilot.Verifier.Examples.ShouldPass.Heater as Heater +import qualified Copilot.Verifier.Examples.ShouldPass.IntOps as IntOps +import qualified Copilot.Verifier.Examples.ShouldPass.Partial.AbsIntMin as Pass.AbsIntMin +import qualified Copilot.Verifier.Examples.ShouldPass.Partial.AddSignedWrap as Pass.AddSignedWrap +import qualified Copilot.Verifier.Examples.ShouldPass.Partial.IndexOutOfBounds as Pass.IndexOutOfBounds +import qualified Copilot.Verifier.Examples.ShouldPass.Partial.DivByZero as Pass.DivByZero +import qualified Copilot.Verifier.Examples.ShouldPass.Partial.ModByZero as Pass.ModByZero +import qualified Copilot.Verifier.Examples.ShouldPass.Partial.MulSignedWrap as Pass.MulSignedWrap +import qualified Copilot.Verifier.Examples.ShouldPass.Partial.ShiftLTooLarge as Pass.ShiftLTooLarge +import qualified Copilot.Verifier.Examples.ShouldPass.Partial.ShiftRTooLarge as Pass.ShiftRTooLarge +import qualified Copilot.Verifier.Examples.ShouldPass.Partial.SubSignedWrap as Pass.SubSignedWrap +import qualified Copilot.Verifier.Examples.ShouldPass.Structs as Structs +import qualified Copilot.Verifier.Examples.ShouldPass.UpdateArray as UpdateArray +import qualified Copilot.Verifier.Examples.ShouldPass.UpdateStruct as UpdateStruct +import qualified Copilot.Verifier.Examples.ShouldPass.Voting as Voting +import qualified Copilot.Verifier.Examples.ShouldPass.WCV as WCV + +shouldFailExamples :: Verbosity -> Map (CI Text) (IO ()) +shouldFailExamples verb = Map.fromList + [ -- Partial operation tests + example "AbsIntMin-fail" (Fail.AbsIntMin.verifySpec verb) + , example "AddSignedWrap-fail" (Fail.AddSignedWrap.verifySpec verb) + , example "DivByZero-fail" (Fail.DivByZero.verifySpec verb) + , example "IndexOutOfBounds-fail" (Fail.IndexOutOfBounds.verifySpec verb) + , example "ModByZero-fail" (Fail.ModByZero.verifySpec verb) + , example "MulSignedWrap-fail" (Fail.MulSignedWrap.verifySpec verb) + , example "ShiftLTooLarge-fail" (Fail.ShiftLTooLarge.verifySpec verb) + , example "ShiftRTooLarge-fail" (Fail.ShiftRTooLarge.verifySpec verb) + , example "SubSignedWrap-fail" (Fail.SubSignedWrap.verifySpec verb) + ] + +shouldPassExamples :: Verbosity -> Map (CI Text) (IO ()) +shouldPassExamples verb = Map.fromList + [ example "Array" (Array.verifySpec verb) + , example "ArrayGen" (ArrayGen.verifySpec verb) + , example "ArrayOfStructs" (ArrayOfStructs.verifySpec verb) + , example "ArrayTriggerArgument" (ArrayTriggerArgument.verifySpec verb) + , example "Arith" (Arith.verifySpec verb) + , example "Clock" (Clock.verifySpec verb) + , example "Counter" (Counter.verifySpec verb) + , example "Engine" (Engine.verifySpec verb) + , example "FPNegation" (FPNegation.verifySpec verb) + , example "FPOps" (FPOps.verifySpec verb) + , example "Heater" (Heater.verifySpec verb) + , example "IntOps" (IntOps.verifySpec verb) + , example "Structs" (Structs.verifySpec verb) + , example "UpdateArray" (UpdateArray.verifySpec verb) + , example "UpdateStruct" (UpdateStruct.verifySpec verb) + , example "Voting" (Voting.verifySpec verb) + , example "WCV" (WCV.verifySpec verb) + + -- Partial operation tests + , example "AbsIntMin-pass" (Pass.AbsIntMin.verifySpec verb) + , example "AddSignedWrap-pass" (Pass.AddSignedWrap.verifySpec verb) + , example "DivByZero-pass" (Pass.DivByZero.verifySpec verb) + , example "IndexOutOfBounds-pass" (Pass.IndexOutOfBounds.verifySpec verb) + , example "ModByZero-pass" (Pass.ModByZero.verifySpec verb) + , example "MulSignedWrap-pass" (Pass.MulSignedWrap.verifySpec verb) + , example "ShiftLTooLarge-pass" (Pass.ShiftLTooLarge.verifySpec verb) + , example "ShiftRTooLarge-pass" (Pass.ShiftRTooLarge.verifySpec verb) + , example "SubSignedWrap-pass" (Pass.SubSignedWrap.verifySpec verb) + ] + +example :: Text -> IO () -> (CI Text, IO ()) +example name action = (CI.mk name, action) diff --git a/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldFail/Partial/AbsIntMin.hs b/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldFail/Partial/AbsIntMin.hs new file mode 100644 index 000000000..70147e5a4 --- /dev/null +++ b/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldFail/Partial/AbsIntMin.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +-- | This will fail to verify since the verification does not assume the +-- @notIntMin@ property, which is needed to prevent undefined behavior when +-- invoking the 'abs' function. +module Copilot.Verifier.Examples.ShouldFail.Partial.AbsIntMin where + +import Language.Copilot +import Copilot.Compile.C99 +import Copilot.Verifier ( Verbosity, VerifierOptions(..) + , defaultVerifierOptions, verifyWithOptions ) + +spec :: Spec +spec = do + let stream :: Stream Int32 + stream = extern "stream" Nothing + + _ <- prop "notIntMin" (forAll (stream > constI32 minBound)) + trigger "streamAbs" (abs stream == 1) [arg stream] + +verifySpec :: Verbosity -> IO () +verifySpec verb = do + spec' <- reify spec + verifyWithOptions defaultVerifierOptions{verbosity = verb} + mkDefaultCSettings + -- ["notIntMin"] + [] + "absIntMinFail" spec' diff --git a/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldFail/Partial/AddSignedWrap.hs b/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldFail/Partial/AddSignedWrap.hs new file mode 100644 index 000000000..5ae869641 --- /dev/null +++ b/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldFail/Partial/AddSignedWrap.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +-- | This will fail to verify since the verification does not assume the +-- @notIntMax@ property, which is needed to prevent signed integer overflow. +module Copilot.Verifier.Examples.ShouldFail.Partial.AddSignedWrap where + +import Language.Copilot +import Copilot.Compile.C99 +import Copilot.Verifier ( Verbosity, VerifierOptions(..) + , defaultVerifierOptions, verifyWithOptions ) + +spec :: Spec +spec = do + let stream :: Stream Int32 + stream = extern "stream" Nothing + + _ <- prop "notIntMax" (forAll (stream < constI32 maxBound)) + trigger "streamAddSigned" ((stream + 1) == 1) [arg stream] + +verifySpec :: Verbosity -> IO () +verifySpec verb = do + spec' <- reify spec + verifyWithOptions defaultVerifierOptions{verbosity = verb} + mkDefaultCSettings + -- ["notIntMax"] + [] + "addSignedWrapFail" spec' diff --git a/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldFail/Partial/DivByZero.hs b/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldFail/Partial/DivByZero.hs new file mode 100644 index 000000000..53786931a --- /dev/null +++ b/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldFail/Partial/DivByZero.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +-- | This will fail to verify since the verification does not assume the +-- @nonzero@ property, which is needed to prevent a division-by-zero error. +module Copilot.Verifier.Examples.ShouldFail.Partial.DivByZero where + +import Language.Copilot +import Copilot.Compile.C99 +import Copilot.Verifier ( Verbosity, VerifierOptions(..) + , defaultVerifierOptions, verifyWithOptions ) + +spec :: Spec +spec = do + let stream :: Stream Int16 + stream = extern "stream" Nothing + + _ <- prop "nonzero" (forAll (stream /= 0)) + trigger "streamDiv" ((stream `div` stream) == 1) [arg stream] + +verifySpec :: Verbosity -> IO () +verifySpec verb = do + spec' <- reify spec + verifyWithOptions defaultVerifierOptions{verbosity = verb} + mkDefaultCSettings + -- ["nonzero"] + [] + "divByZeroFail" spec' diff --git a/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldFail/Partial/IndexOutOfBounds.hs b/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldFail/Partial/IndexOutOfBounds.hs new file mode 100644 index 000000000..93f3812af --- /dev/null +++ b/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldFail/Partial/IndexOutOfBounds.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | This will fail to verify since the verification does not assume the +-- @withinBounds@ property, which is needed to prevent an out-of-bounds array index. +module Copilot.Verifier.Examples.ShouldFail.Partial.IndexOutOfBounds where + +import Language.Copilot +import Copilot.Compile.C99 +import Copilot.Verifier ( Verbosity, VerifierOptions(..) + , defaultVerifierOptions, verifyWithOptions ) + +spec :: Spec +spec = do + let stream1 :: Stream (Array 2 Int16) + stream1 = constant (array [27, 42]) + + stream2 :: Stream Word32 + stream2 = extern "stream2" Nothing + + _ <- prop "withinBounds" (forAll (stream2 < constW32 2)) + trigger "streamIndex" ((stream1 ! stream2) == 1) [arg stream1, arg stream2] + +verifySpec :: Verbosity -> IO () +verifySpec verb = do + spec' <- reify spec + verifyWithOptions defaultVerifierOptions{verbosity = verb} + mkDefaultCSettings + -- ["withinBounds"] + [] + "indexFail" spec' diff --git a/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldFail/Partial/ModByZero.hs b/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldFail/Partial/ModByZero.hs new file mode 100644 index 000000000..c42f16c4e --- /dev/null +++ b/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldFail/Partial/ModByZero.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +-- | This will fail to verify since the verification does not assume the +-- @nonzero@ property, which is needed to prevent a division-by-zero error. +module Copilot.Verifier.Examples.ShouldFail.Partial.ModByZero where + +import Language.Copilot +import Copilot.Compile.C99 +import Copilot.Verifier ( Verbosity, VerifierOptions(..) + , defaultVerifierOptions, verifyWithOptions ) + +spec :: Spec +spec = do + let stream :: Stream Int16 + stream = extern "stream" Nothing + + _ <- prop "nonzero" (forAll (stream /= 0)) + trigger "streamMod" ((stream `mod` stream) == 1) [arg stream] + +verifySpec :: Verbosity -> IO () +verifySpec verb = do + spec' <- reify spec + verifyWithOptions defaultVerifierOptions{verbosity = verb} + mkDefaultCSettings + -- ["nonzero"] + [] + "modByZeroFail" spec' diff --git a/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldFail/Partial/MulSignedWrap.hs b/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldFail/Partial/MulSignedWrap.hs new file mode 100644 index 000000000..41f746b34 --- /dev/null +++ b/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldFail/Partial/MulSignedWrap.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +-- | This will fail to verify since the verification does not assume the +-- @withinRange@ property, which is needed to prevent signed integer underflow or overflow. +module Copilot.Verifier.Examples.ShouldFail.Partial.MulSignedWrap where + +import qualified Prelude as P + +import Language.Copilot +import Copilot.Compile.C99 +import Copilot.Verifier ( Verbosity, VerifierOptions(..) + , defaultVerifierOptions, verifyWithOptions ) + +spec :: Spec +spec = do + let stream :: Stream Int32 + stream = extern "stream" Nothing + + _ <- prop "withinRange" (forAll + (constI32 ((minBound P.+ 1) P.* 2) < stream + && stream < constI32 ((maxBound P.- 1) `P.div` 2))) + trigger "streamMulSigned" ((stream * 2) == 2) [arg stream] + +verifySpec :: Verbosity -> IO () +verifySpec verb = do + spec' <- reify spec + verifyWithOptions defaultVerifierOptions{verbosity = verb} + mkDefaultCSettings + -- ["withinRange"] + [] + "mulSignedWrapFail" spec' diff --git a/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldFail/Partial/ShiftLTooLarge.hs b/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldFail/Partial/ShiftLTooLarge.hs new file mode 100644 index 000000000..dbdcd8b0f --- /dev/null +++ b/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldFail/Partial/ShiftLTooLarge.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +-- | This will fail to verify since the verification does not assume the +-- @lessThanBitWidth@ property, which is needed to prevent shifting by too +-- large of a value. +module Copilot.Verifier.Examples.ShouldFail.Partial.ShiftLTooLarge where + +import Language.Copilot +import Copilot.Compile.C99 +import Copilot.Verifier ( Verbosity, VerifierOptions(..) + , defaultVerifierOptions, verifyWithOptions ) + +spec :: Spec +spec = do + let stream1 :: Stream Int32 + stream1 = extern "stream1" Nothing + + stream2 :: Stream Int64 + stream2 = extern "stream2" Nothing + + _ <- prop "lessThanBitWidth" (forAll + (constI64 0 <= stream2 && stream2 < constI64 32)) + trigger "streamShiftL" ((stream1 .<<. stream2) == 1) [arg stream1, arg stream2] + +verifySpec :: Verbosity -> IO () +verifySpec verb = do + spec' <- reify spec + verifyWithOptions defaultVerifierOptions{verbosity = verb} + mkDefaultCSettings + -- ["lessThanBitWidth"] + [] + "shiftLTooLargeFail" spec' diff --git a/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldFail/Partial/ShiftRTooLarge.hs b/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldFail/Partial/ShiftRTooLarge.hs new file mode 100644 index 000000000..12fe7c1f1 --- /dev/null +++ b/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldFail/Partial/ShiftRTooLarge.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +-- | This will fail to verify since the verification does not assume the +-- @lessThanBitWidth@ property, which is needed to prevent shifting by too +-- large of a value. +module Copilot.Verifier.Examples.ShouldFail.Partial.ShiftRTooLarge where + +import Language.Copilot +import Copilot.Compile.C99 +import Copilot.Verifier ( Verbosity, VerifierOptions(..) + , defaultVerifierOptions, verifyWithOptions ) + +spec :: Spec +spec = do + let stream1 :: Stream Int32 + stream1 = extern "stream1" Nothing + + stream2 :: Stream Int64 + stream2 = extern "stream2" Nothing + + _ <- prop "lessThanBitWidth" (forAll + (constI64 0 <= stream2 && stream2 < constI64 32)) + trigger "streamShiftR" ((stream1 .<<. stream2) == 1) [arg stream1, arg stream2] + +verifySpec :: Verbosity -> IO () +verifySpec verb = do + spec' <- reify spec + verifyWithOptions defaultVerifierOptions{verbosity = verb} + mkDefaultCSettings + -- ["lessThanBitWidth"] + [] + "shiftRTooLargeFail" spec' diff --git a/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldFail/Partial/SubSignedWrap.hs b/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldFail/Partial/SubSignedWrap.hs new file mode 100644 index 000000000..5503b1743 --- /dev/null +++ b/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldFail/Partial/SubSignedWrap.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +-- | This will fail to verify since the verification does not assume the +-- @notIntMin@ property, which is needed to prevent signed integer underflow. +module Copilot.Verifier.Examples.ShouldFail.Partial.SubSignedWrap where + +import Language.Copilot +import Copilot.Compile.C99 +import Copilot.Verifier ( Verbosity, VerifierOptions(..) + , defaultVerifierOptions, verifyWithOptions ) + +spec :: Spec +spec = do + let stream :: Stream Int32 + stream = extern "stream" Nothing + + _ <- prop "notIntMin" (forAll (stream > constI32 minBound)) + trigger "streamSubSigned" ((stream - 1) == 1) [arg stream] + +verifySpec :: Verbosity -> IO () +verifySpec verb = do + spec' <- reify spec + verifyWithOptions defaultVerifierOptions{verbosity = verb} + mkDefaultCSettings + -- ["notIntMin"] + [] + "subSignedWrapFail" spec' diff --git a/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/Arith.hs b/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/Arith.hs new file mode 100644 index 000000000..58b75fb92 --- /dev/null +++ b/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/Arith.hs @@ -0,0 +1,52 @@ + +{-# LANGUAGE RebindableSyntax #-} + +module Copilot.Verifier.Examples.ShouldPass.Arith where + +import Control.Monad (when) +import qualified Prelude as P + +import Language.Copilot +import Copilot.Compile.C99 +import Copilot.Verifier ( Verbosity(..), VerifierOptions(..) + , defaultVerifierOptions, verifyWithOptions ) +import Copilot.Theorem.What4 (prove, Solver(..)) + +-- The largest unsigned 32-bit prime +lastPrime :: Stream Word32 +lastPrime = 31 +--lastPrime = 4294967291 -- Whelp, this prime seems too big for the solvers to handle well + +multRingSpec :: Spec +multRingSpec = do + _ <- prop "clamp nonzero" (forAll ((clamp > 0) && (clamp < lastPrime))) + _ <- prop "reduced" (forAll (acc < lastPrime)) + _ <- prop "nonzero" (forAll (acc > 0 && (acc < lastPrime))) + + trigger "outofrange" (not (acc > 0 && acc < lastPrime)) [arg acc] + + return () + + where + -- a stream of external values + vals = externW32 "values" Nothing + + -- Generate a value in [1, lastPrime), which + -- is the multiplictive group of Z_p + clamp :: Stream Word32 + clamp = (vals `mod` (lastPrime - 1)) + 1 + + -- Successively multiply new values + acc :: Stream Word32 + acc = [1] ++ unsafeCast ((cast acc * cast clamp) `mod` (cast lastPrime :: Stream Word64)) + +verifySpec :: Verbosity -> IO () +verifySpec verb = + do s <- reify multRingSpec + r <- prove Z3 s + when (verb P.>= Default) $ + print r + verifyWithOptions defaultVerifierOptions{verbosity = verb} + mkDefaultCSettings ["reduced"] "multRingSpec" s + +--verifySpec _ = interpret 10 engineMonitor diff --git a/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/Array.hs b/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/Array.hs new file mode 100644 index 000000000..365d54c4b --- /dev/null +++ b/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/Array.hs @@ -0,0 +1,40 @@ +-------------------------------------------------------------------------------- +-- Copyright © 2019 National Institute of Aerospace / Galois, Inc. +-------------------------------------------------------------------------------- + +-- | This is a simple example for arrays. As a program, it does not make much +-- sense, however it shows of the features of arrays nicely. + +-- | Enable compiler extension for type-level data, necesary for the array +-- length. + +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE DataKinds #-} + +module Copilot.Verifier.Examples.ShouldPass.Array where + +import Language.Copilot +import Copilot.Compile.C99 +import Copilot.Verifier ( Verbosity, VerifierOptions(..) + , defaultVerifierOptions, verifyWithOptions ) + +-- Lets define an array of length 2. +-- Make the buffer of the streams 3 elements long. +arr :: Stream (Array 2 Bool) +arr = [ array [True, False] + , array [True, True] + , array [False, False]] ++ arr + +spec :: Spec +spec = do + -- A trigger that fires 'func' when the first element of 'arr' is True. + -- It passes the current value of arr as an argument. + -- The prototype of 'func' would be: + -- void func (int8_t arg[3]); + trigger "func" (arr ! 0) [arg arr] + +-- Compile the spec +verifySpec :: Verbosity -> IO () +verifySpec verb = reify spec >>= verifyWithOptions defaultVerifierOptions{verbosity = verb} + mkDefaultCSettings [] "array" +-- verifySpec _ = interpret 30 spec diff --git a/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/ArrayGen.hs b/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/ArrayGen.hs new file mode 100644 index 000000000..115c753cb --- /dev/null +++ b/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/ArrayGen.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE DataKinds #-} +module Copilot.Verifier.Examples.ShouldPass.ArrayGen where + +import Copilot.Compile.C99 +import Copilot.Verifier ( Verbosity, VerifierOptions(..) + , defaultVerifierOptions, verifyWithOptions ) +import Language.Copilot +import qualified Prelude hiding ((++), (>)) + +spec :: Spec +spec = trigger "f" (stream ! 0 > 0) [arg stream] + where + stream :: Stream (Array 2 Int16) + stream = [array [3,4]] ++ rest + + rest :: Stream (Array 2 Int16) + rest = constant $ array [5,6] + +verifySpec :: Verbosity -> IO () +verifySpec verb = reify spec >>= verifyWithOptions defaultVerifierOptions{verbosity = verb} + mkDefaultCSettings [] "arrayGen" diff --git a/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/ArrayOfStructs.hs b/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/ArrayOfStructs.hs new file mode 100644 index 000000000..b983531f0 --- /dev/null +++ b/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/ArrayOfStructs.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NoImplicitPrelude #-} +module Copilot.Verifier.Examples.ShouldPass.ArrayOfStructs where + +import Copilot.Compile.C99 +import Copilot.Verifier ( Verbosity, VerifierOptions(..) + , defaultVerifierOptions, verifyWithOptions ) +import Language.Copilot + +data S = S { field :: Field "field" Int16 } + +instance Struct S where + typeName _ = "s" + toValues s = [Value Int16 (field s)] + +instance Typed S where + typeOf = Struct (S (Field 0)) + +spec :: Spec +spec = trigger "f" ((stream ! 0)#field == 27) [arg stream] + where + stream :: Stream (Array 2 S) + stream = [array [S (Field 27), S (Field 42)]] ++ stream + +verifySpec :: Verbosity -> IO () +verifySpec verb = do + spec' <- reify spec + verifyWithOptions defaultVerifierOptions{verbosity = verb} + mkDefaultCSettings [] "arrayOfStructs" spec' diff --git a/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/ArrayTriggerArgument.hs b/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/ArrayTriggerArgument.hs new file mode 100644 index 000000000..5c06b626a --- /dev/null +++ b/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/ArrayTriggerArgument.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE DataKinds #-} + +-- | A regression test for +-- . +module Copilot.Verifier.Examples.ShouldPass.ArrayTriggerArgument where + +import Language.Copilot +import Copilot.Compile.C99 +import Copilot.Verifier ( Verbosity, VerifierOptions(..) + , defaultVerifierOptions, verifyWithOptions ) + +spec :: Spec +spec = trigger "f" true [arg stream] + where + stream :: Stream (Array 2 Int16) + stream = constant (array [3,4]) + +verifySpec :: Verbosity -> IO () +verifySpec verb = do + spec' <- reify spec + verifyWithOptions + defaultVerifierOptions{verbosity = verb} + mkDefaultCSettings [] "arrayTriggerArgument" spec' diff --git a/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/Clock.hs b/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/Clock.hs new file mode 100644 index 000000000..7f9d8d303 --- /dev/null +++ b/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/Clock.hs @@ -0,0 +1,46 @@ +-------------------------------------------------------------------------------- +-- Copyright © 2019 National Institute of Aerospace / Galois, Inc. +-------------------------------------------------------------------------------- + +-- | Example showing usage of clocks to generate periodically recurring truth +-- values. + +module Copilot.Verifier.Examples.ShouldPass.Clock where + +import Control.Monad (when) +import qualified Prelude as P + +import Language.Copilot +import Copilot.Compile.C99 +import Copilot.Verifier ( Verbosity(..), VerifierOptions(..) + , defaultVerifierOptions, verifyWithOptions ) +import Copilot.Theorem.What4 (prove, Solver(..)) + +-- | We need to force a type for the argument of `period`. +p :: Word8 +p = 5 + +-- | Both have the same period, but a different phase. +clkStream :: Stream Bool +clkStream = clk (period p) (phase 0) + +clkStream' :: Stream Bool +clkStream' = clk (period p) (phase 2) + +spec :: Spec +spec = do + observer "clk" clkStream + observer "clk'" clkStream' + _ <- prop "clksPhase" (forAll (clkStream == drop 2 clkStream')) + _ <- prop "clksDistinct" (forAll (not (clkStream && clkStream'))) + trigger "clksHigh" (clkStream && clkStream') [] + + +verifySpec :: Verbosity -> IO () +verifySpec verb = + do s <- reify spec + r <- prove Z3 s + when (verb P.>= Default) $ + print r + verifyWithOptions defaultVerifierOptions{verbosity = verb} + mkDefaultCSettings [] "clock" s diff --git a/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/Counter.hs b/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/Counter.hs new file mode 100644 index 000000000..708ea662f --- /dev/null +++ b/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/Counter.hs @@ -0,0 +1,56 @@ +------------------------------------------------------------------------------- +-- Copyright © 2019 National Institute of Aerospace / Galois, Inc. +-------------------------------------------------------------------------------- + +-- | Example showing an implementation of a resettable counter. + +{-# LANGUAGE RebindableSyntax #-} + +module Copilot.Verifier.Examples.ShouldPass.Counter where + +import Control.Monad (when) +import qualified Prelude as P + +import Language.Copilot +import Copilot.Compile.C99 +import Copilot.Verifier ( Verbosity(..), VerifierOptions(..) + , defaultVerifierOptions, verifyWithOptions ) +import Copilot.Theorem.What4 (prove, Solver(..)) + +-- A resettable counter +counter :: (Typed a, Integral a) => Stream Bool -> Stream Bool -> Stream a +counter inc reset = cnt + where + cnt = if reset then 0 + else if inc then z + 1 + else z + z = [0] ++ cnt + +-- Counter that resets when it reaches 256 +bytecounter :: Stream Int32 +bytecounter = counter true (resetcounter `mod` 256 == 0) + +resetcounter :: Stream Word32 +resetcounter = counter true false + +bytecounter2 :: Stream Int32 +bytecounter2 = counter true ([False] ++ bytecounter2 == 255) + +spec :: Spec +spec = + do _ <- prop "range" (forAll (bytecounter == unsafeCast (resetcounter `mod` 256))) + _ <- prop "range2" (forAll (0 <= bytecounter2 && bytecounter2 <= 255)) + _ <- prop "same" (forAll ((0 <= bytecounter2 && bytecounter2 <= 255) && + (bytecounter == unsafeCast (resetcounter `mod` 256)) && + (bytecounter == bytecounter2))) + trigger "counter" true [arg $ bytecounter, arg $ bytecounter2] + +verifySpec :: Verbosity -> IO () +-- verifSpec _ = interpret 1280 spec +verifySpec verb = + do s <- reify spec + r <- prove Z3 s + when (verb P.>= Default) $ + print r + verifyWithOptions defaultVerifierOptions{verbosity = verb} + mkDefaultCSettings ["range", "range2"] "counter" s diff --git a/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/Engine.hs b/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/Engine.hs new file mode 100644 index 000000000..74e7509ee --- /dev/null +++ b/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/Engine.hs @@ -0,0 +1,44 @@ +-------------------------------------------------------------------------------- +-- Copyright © 2011 National Institute of Aerospace / Galois, Inc. +-------------------------------------------------------------------------------- + +-- | Example implementing an engine cooling control system. + +{-# LANGUAGE RebindableSyntax #-} + +module Copilot.Verifier.Examples.ShouldPass.Engine where + +import Language.Copilot +import Copilot.Compile.C99 +import Copilot.Verifier ( Verbosity, VerifierOptions(..) + , defaultVerifierOptions, verifyWithOptions ) + +import qualified Prelude as P + +{- If the majority of the engine temperature probes exeeds 250 degrees, then + - the cooler is engaged and remains engaged until the majority of the engine + - temperature probes drop to 250 or below. Otherwise, trigger an immediate + - shutdown of the engine. +-} + +engineMonitor :: Spec +engineMonitor = do + trigger "shutoff" (not ok) [arg maj] + + where + vals = [ externW8 "tmp_probe_0" two51 + , externW8 "tmp_probe_1" two51 + , externW8 "tmp_probe_2" zero] + exceed = map (> 250) vals + maj = majority exceed + checkMaj = aMajority exceed maj + ok = alwaysBeen ((maj && checkMaj) ==> extern "cooler" cooler) + + two51 = Just $ [251, 251] P.++ repeat (250 :: Word8) + zero = Just $ repeat (0 :: Word8) + cooler = Just $ [True, True] P.++ repeat False + +verifySpec :: Verbosity -> IO () +verifySpec verb = reify engineMonitor >>= verifyWithOptions defaultVerifierOptions{verbosity = verb} + mkDefaultCSettings [] "engine" +--verifySpec _ = interpret 10 engineMonitor diff --git a/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/FPNegation.hs b/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/FPNegation.hs new file mode 100644 index 000000000..5078d0775 --- /dev/null +++ b/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/FPNegation.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +-- | This will not succeed when 'smtFloatMode' is 'FloatUninterpreted', as Clang +-- will turn @input /= 30.0@ below into a more complicated expression that also +-- checks if @30.0@ is NaN or not. This is logically equivalent to the original +-- specification, but an SMT solver cannot conclude this when all of the +-- floating-point operations involved are treated as uninterpreted functions. +-- +-- To make this work, we set 'smtFloatMode' to 'FloatIEEE' instead. This works +-- because all of the floating-point operations in the specification below are +-- native to SMT-LIB. +module Copilot.Verifier.Examples.ShouldPass.FPNegation where + +import Copilot.Compile.C99 (mkDefaultCSettings) +import Copilot.Verifier ( Verbosity, VerifierOptions(..) + , defaultVerifierOptions, verifyWithOptions ) +import Copilot.Verifier.FloatMode (FloatMode(..)) +import qualified Copilot.Library.PTLTL as PTLTL +import Language.Copilot + +input :: Stream Float +input = extern "input" Nothing + +-- | MyProperty +-- @ +-- Input is never 30.0 +-- @ +propMyProperty :: Stream Bool +propMyProperty = PTLTL.alwaysBeen (input /= 30.0) + +-- | Clock that increases in one-unit steps. +clock :: Stream Int64 +clock = [0] ++ (clock + 1) + +-- | First Time Point +ftp :: Stream Bool +ftp = [True] ++ false + +pre :: Stream Bool -> Stream Bool +pre = ([False] ++) + +tpre :: Stream Bool -> Stream Bool +tpre = ([True] ++) + +notPreviousNot :: Stream Bool -> Stream Bool +notPreviousNot = not . PTLTL.previous . not + +-- | Complete specification. Calls C handler functions when properties are +-- violated. +spec :: Spec +spec = do + trigger "handlerMyProperty" (not propMyProperty) [] + +verifySpec :: Verbosity -> IO () +verifySpec verb = do + spec' <- reify spec + verifyWithOptions + (defaultVerifierOptions + { verbosity = verb + , smtFloatMode = FloatIEEE + }) + mkDefaultCSettings [] "fpNegation" spec' diff --git a/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/FPOps.hs b/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/FPOps.hs new file mode 100644 index 000000000..02bd0130a --- /dev/null +++ b/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/FPOps.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +module Copilot.Verifier.Examples.ShouldPass.FPOps where + +import Copilot.Compile.C99 (mkDefaultCSettings) +import qualified Copilot.Language.Stream as Copilot +import Copilot.Verifier ( Verbosity, VerifierOptions(..) + , defaultVerifierOptions, verifyWithOptions ) +import Data.Proxy (Proxy(..)) +import Language.Copilot +import qualified Prelude as P + +mkSpecFor :: forall a proxy. (RealFloat a, Typed a) => proxy a -> String -> Spec +mkSpecFor _ nameSuffix = do + let mkName :: String -> String + mkName namePrefix = namePrefix P.++ nameSuffix + + stream :: Stream a + stream = extern (mkName "stream") Nothing + + triggerOp1 (mkName "abs") abs stream + triggerOp1 (mkName "signum") signum stream + triggerOp1 (mkName "recip") recip stream + triggerOp1 (mkName "exp") exp stream + triggerOp1 (mkName "sqrt") sqrt stream + triggerOp1 (mkName "log") log stream + triggerOp1 (mkName "sin") sin stream + triggerOp1 (mkName "tan") tan stream + triggerOp1 (mkName "cos") cos stream + triggerOp1 (mkName "asin") asin stream + triggerOp1 (mkName "atan") atan stream + triggerOp1 (mkName "acos") acos stream + triggerOp1 (mkName "sinh") sinh stream + triggerOp1 (mkName "tanh") tanh stream + triggerOp1 (mkName "cosh") cosh stream + triggerOp1 (mkName "asinh") asinh stream + triggerOp1 (mkName "atanh") atanh stream + triggerOp1 (mkName "acosh") acosh stream + triggerOp1 (mkName "ceiling") Copilot.ceiling stream + triggerOp1 (mkName "floor") Copilot.floor stream + + triggerOp2 (mkName "add") (+) stream + triggerOp2 (mkName "sub") (-) stream + triggerOp2 (mkName "mul") (*) stream + triggerOp2 (mkName "div") (/) stream + triggerOp2 (mkName "pow") (**) stream + triggerOp2 (mkName "logBase") logBase stream + triggerOp2 (mkName "atan2") Copilot.atan2 stream + +spec :: Spec +spec = do + mkSpecFor (Proxy @Float) "F" + mkSpecFor (Proxy @Double) "D" + +triggerOp1 :: (RealFloat a, Typed a) => + String -> + (Stream a -> Stream a) -> + Stream a -> + Spec +triggerOp1 name op stream = + trigger (name P.++ "Trigger") (testOp1 op stream) [arg stream] + +triggerOp2 :: (RealFloat a, Typed a) => + String -> + (Stream a -> Stream a -> Stream a) -> + Stream a -> + Spec +triggerOp2 name op stream = + trigger (name P.++ "Trigger") (testOp2 op stream) [arg stream] + +testOp1 :: (RealFloat a, Typed a) => + (Stream a -> Stream a) -> Stream a -> Stream Bool +testOp1 op stream = + -- NB: Use (>=) rather than (==) here, as floating-point equality gets weird + -- due to NaNs. + op stream >= op stream + +testOp2 :: (RealFloat a, Typed a) => + (Stream a -> Stream a -> Stream a) -> Stream a -> Stream Bool +testOp2 op stream = + op stream stream >= op stream stream + +verifySpec :: Verbosity -> IO () +verifySpec verb = do + spec' <- reify spec + verifyWithOptions defaultVerifierOptions{verbosity = verb} + mkDefaultCSettings [] "fpOps" spec' diff --git a/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/Heater.hs b/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/Heater.hs new file mode 100644 index 000000000..b2c9101ff --- /dev/null +++ b/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/Heater.hs @@ -0,0 +1,60 @@ +-------------------------------------------------------------------------------- +-- Copyright 2019 National Institute of Aerospace / Galois, Inc. +-------------------------------------------------------------------------------- + +-- This is a simple example with basic usage. It implements a simple home +-- heating system: It heats when temp gets too low, and stops when it is high +-- enough. It read temperature as a byte (range -50C to 100C) and translates +-- this to Celcius. + +module Copilot.Verifier.Examples.ShouldPass.Heater where + +import Language.Copilot +import Copilot.Compile.C99 +import Copilot.PrettyPrint as PP +--import Copilot.Language.Prelude + +import Copilot.Verifier ( Verbosity(..), VerifierOptions(..) + , defaultVerifierOptions, verifyWithOptions ) + +import qualified Prelude as P +import Control.Monad (when) + +-- External temperature as a byte, range of -50C to 100C +temp :: Stream Word8 +temp = extern "temperature" Nothing + +-- Calculate temperature in Celcius. +-- We need to cast the Word8 to a Float. Note that it is an unsafeCast, as there +-- is no direct relation between Word8 and Float. +ctemp :: Stream Float +ctemp = (unsafeCast temp * constant (150.0/255.0)) - constant 50.0 + +-- width of the sliding window +window :: Int +window = 5 + +-- Compute the sliding average of the last 5 temps +-- (Here, 19.5 is the average of 18.0 and 21.0, the two temperature extremes +-- that we check for in the spec.) +avgTemp :: Stream Float +avgTemp = (sum window (replicate window 19.5 ++ ctemp)) / fromIntegral window + +spec :: Spec +spec = do + trigger "heaton" (avgTemp < 18.0) [arg avgTemp] + trigger "heatoff" (avgTemp > 21.0) [arg avgTemp] + +-- Compile the spec +verifySpec :: Verbosity -> IO () +verifySpec verb = + do rspec <- reify spec + when (verb P.>= Default) $ putStrLn (PP.prettyPrint rspec) + verifyWithOptions defaultVerifierOptions{verbosity = verb} + mkDefaultCSettings [] "heater" + rspec + +{- + do spec' <- reify spec + putStrLn $ prettyPrintDot spec' +-} diff --git a/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/IntOps.hs b/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/IntOps.hs new file mode 100644 index 000000000..f4c4a1db4 --- /dev/null +++ b/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/IntOps.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE NoImplicitPrelude #-} +module Copilot.Verifier.Examples.ShouldPass.IntOps where + +import Copilot.Compile.C99 (mkDefaultCSettings) +import Copilot.Verifier ( Verbosity, VerifierOptions(..) + , defaultVerifierOptions, verifyWithOptions ) +import Language.Copilot +import qualified Prelude as P + +spec :: Spec +spec = do + let stream :: Stream Int16 + stream = extern "stream" Nothing + + shiftBy :: Stream Int16 + shiftBy = extern "shiftBy" Nothing + + _ <- prop "nonzero" (forAll (stream /= 0)) + _ <- prop "shiftByBits" (forAll (0 <= shiftBy && shiftBy < 16)) + + triggerOp1 "abs" abs stream + triggerOp1 "signum" signum stream + triggerOp1 "bwNot" complement stream + + triggerOp2 "add" (+) stream stream + triggerOp2 "sub" (-) stream stream + triggerOp2 "mul" (*) stream stream + triggerOp2 "mod" mod stream stream + triggerOp2 "div" div stream stream + triggerOp2 "bwAnd" (.&.) stream stream + triggerOp2 "bwOr" (.|.) stream stream + triggerOp2 "bwXor" (.^.) stream stream + triggerOp2 "bwShiftL" (.<<.) stream shiftBy + triggerOp2 "bwShiftR" (.>>.) stream shiftBy + +triggerOp1 :: String -> + (Stream Int16 -> Stream Int16) -> + Stream Int16 -> + Spec +triggerOp1 name op stream = + trigger (name P.++ "Trigger") (testOp1 op stream) [arg stream] + +triggerOp2 :: String -> + (Stream Int16 -> Stream Int16 -> Stream Int16) -> + Stream Int16 -> Stream Int16 -> + Spec +triggerOp2 name op stream1 stream2 = + trigger (name P.++ "Trigger") (testOp2 op stream1 stream2) [arg stream1, arg stream2] + +testOp1 :: (Stream Int16 -> Stream Int16) -> Stream Int16 -> Stream Bool +testOp1 op stream = + op stream == op stream + +testOp2 :: (Stream Int16 -> Stream Int16 -> Stream Int16) -> + Stream Int16 -> Stream Int16 -> + Stream Bool +testOp2 op stream1 stream2 = + op stream1 stream2 == op stream1 stream2 + +verifySpec :: Verbosity -> IO () +verifySpec verb = do + spec' <- reify spec + verifyWithOptions defaultVerifierOptions{verbosity = verb} + mkDefaultCSettings ["nonzero", "shiftByBits"] "intOps" spec' diff --git a/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/Partial/AbsIntMin.hs b/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/Partial/AbsIntMin.hs new file mode 100644 index 000000000..1b27fdeed --- /dev/null +++ b/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/Partial/AbsIntMin.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +-- | This will succeed with 'sideCondVerifierOptions', as Copilot's @Abs@ +-- operation is well defined precisely when C's @abs@ function is well defined. +module Copilot.Verifier.Examples.ShouldPass.Partial.AbsIntMin where + +import Language.Copilot +import Copilot.Compile.C99 +import Copilot.Verifier ( Verbosity, VerifierOptions(..) + , sideCondVerifierOptions, verifyWithOptions ) +import Copilot.Verifier.Examples.ShouldFail.Partial.AbsIntMin (spec) + +verifySpec :: Verbosity -> IO () +verifySpec verb = do + spec' <- reify spec + verifyWithOptions sideCondVerifierOptions{verbosity = verb} + mkDefaultCSettings + [] + "absIntMinPass" spec' diff --git a/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/Partial/AddSignedWrap.hs b/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/Partial/AddSignedWrap.hs new file mode 100644 index 000000000..bcf092f65 --- /dev/null +++ b/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/Partial/AddSignedWrap.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +-- | This will succeed with 'sideCondVerifierOptions', as Copilot's @Add@ +-- operation should overflow on signed integers precisely when C addition does. +module Copilot.Verifier.Examples.ShouldPass.Partial.AddSignedWrap where + +import Language.Copilot +import Copilot.Compile.C99 +import Copilot.Verifier ( Verbosity, VerifierOptions(..) + , sideCondVerifierOptions, verifyWithOptions ) +import Copilot.Verifier.Examples.ShouldFail.Partial.AddSignedWrap (spec) + +verifySpec :: Verbosity -> IO () +verifySpec verb = do + spec' <- reify spec + verifyWithOptions sideCondVerifierOptions{verbosity = verb} + mkDefaultCSettings + [] + "addSignedWrapPass" spec' diff --git a/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/Partial/DivByZero.hs b/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/Partial/DivByZero.hs new file mode 100644 index 000000000..6e5c7a65e --- /dev/null +++ b/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/Partial/DivByZero.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +-- | This will succeed with 'sideCondVerifierOptions', as Copilot's @Div@ +-- operation is well defined precisely when C division is well defined. +module Copilot.Verifier.Examples.ShouldPass.Partial.DivByZero where + +import Language.Copilot +import Copilot.Compile.C99 +import Copilot.Verifier ( Verbosity, VerifierOptions(..) + , sideCondVerifierOptions, verifyWithOptions ) +import Copilot.Verifier.Examples.ShouldFail.Partial.DivByZero (spec) + +verifySpec :: Verbosity -> IO () +verifySpec verb = do + spec' <- reify spec + verifyWithOptions sideCondVerifierOptions{verbosity = verb} + mkDefaultCSettings + [] + "divByZeroPass" spec' diff --git a/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/Partial/IndexOutOfBounds.hs b/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/Partial/IndexOutOfBounds.hs new file mode 100644 index 000000000..eb10f24b9 --- /dev/null +++ b/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/Partial/IndexOutOfBounds.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +-- | This will succeed with 'sideCondVerifierOptions', as Copilot's indexing +-- operation should be out of bounds precisely when C array indexes are out of bounds. +module Copilot.Verifier.Examples.ShouldPass.Partial.IndexOutOfBounds where + +import Language.Copilot +import Copilot.Compile.C99 +import Copilot.Verifier ( Verbosity, VerifierOptions(..) + , sideCondVerifierOptions, verifyWithOptions ) +import Copilot.Verifier.Examples.ShouldFail.Partial.IndexOutOfBounds (spec) + +verifySpec :: Verbosity -> IO () +verifySpec verb = do + spec' <- reify spec + verifyWithOptions sideCondVerifierOptions{verbosity = verb} + mkDefaultCSettings + [] + "indexPass" spec' diff --git a/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/Partial/ModByZero.hs b/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/Partial/ModByZero.hs new file mode 100644 index 000000000..1f9f6bf97 --- /dev/null +++ b/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/Partial/ModByZero.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +-- | This will succeed with 'sideCondVerifierOptions', as Copilot's @Mod@ +-- operation is well defined precisely when C's @%@ operator is well defined. +module Copilot.Verifier.Examples.ShouldPass.Partial.ModByZero where + +import Language.Copilot +import Copilot.Compile.C99 +import Copilot.Verifier ( Verbosity, VerifierOptions(..) + , sideCondVerifierOptions, verifyWithOptions ) +import Copilot.Verifier.Examples.ShouldFail.Partial.ModByZero (spec) + +verifySpec :: Verbosity -> IO () +verifySpec verb = do + spec' <- reify spec + verifyWithOptions sideCondVerifierOptions{verbosity = verb} + mkDefaultCSettings + [] + "modByZeroPass" spec' diff --git a/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/Partial/MulSignedWrap.hs b/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/Partial/MulSignedWrap.hs new file mode 100644 index 000000000..fe70f9451 --- /dev/null +++ b/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/Partial/MulSignedWrap.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +-- | This will succeed with 'sideCondVerifierOptions', as Copilot's @Mul@ +-- operation should wrap on signed integers precisely when C multiplication does. +module Copilot.Verifier.Examples.ShouldPass.Partial.MulSignedWrap where + +import Language.Copilot +import Copilot.Compile.C99 +import Copilot.Verifier ( Verbosity, VerifierOptions(..) + , sideCondVerifierOptions, verifyWithOptions ) +import Copilot.Verifier.Examples.ShouldFail.Partial.MulSignedWrap (spec) + +verifySpec :: Verbosity -> IO () +verifySpec verb = do + spec' <- reify spec + verifyWithOptions sideCondVerifierOptions{verbosity = verb} + mkDefaultCSettings + [] + "mulSignedWrapPass" spec' diff --git a/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/Partial/ShiftLTooLarge.hs b/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/Partial/ShiftLTooLarge.hs new file mode 100644 index 000000000..314070096 --- /dev/null +++ b/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/Partial/ShiftLTooLarge.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +-- | This will succeed with 'sideCondVerifierOptions', as Copilot's @BwShiftL@ +-- operation should only accept second arguments as large as C's @<<@ operation does. +module Copilot.Verifier.Examples.ShouldPass.Partial.ShiftLTooLarge where + +import Language.Copilot +import Copilot.Compile.C99 +import Copilot.Verifier ( Verbosity, VerifierOptions(..) + , sideCondVerifierOptions, verifyWithOptions ) +import Copilot.Verifier.Examples.ShouldFail.Partial.ShiftLTooLarge (spec) + +verifySpec :: Verbosity -> IO () +verifySpec verb = do + spec' <- reify spec + verifyWithOptions sideCondVerifierOptions{verbosity = verb} + mkDefaultCSettings + [] + "shiftLTooLargePass" spec' diff --git a/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/Partial/ShiftRTooLarge.hs b/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/Partial/ShiftRTooLarge.hs new file mode 100644 index 000000000..afab4ba46 --- /dev/null +++ b/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/Partial/ShiftRTooLarge.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +-- | This will succeed with 'sideCondVerifierOptions', as Copilot's @BwShiftR@ +-- operation should only accept second arguments as large as C's @>>@ operation does. +module Copilot.Verifier.Examples.ShouldPass.Partial.ShiftRTooLarge where + +import Language.Copilot +import Copilot.Compile.C99 +import Copilot.Verifier ( Verbosity, VerifierOptions(..) + , sideCondVerifierOptions, verifyWithOptions ) +import Copilot.Verifier.Examples.ShouldFail.Partial.ShiftRTooLarge (spec) + +verifySpec :: Verbosity -> IO () +verifySpec verb = do + spec' <- reify spec + verifyWithOptions sideCondVerifierOptions{verbosity = verb} + mkDefaultCSettings + [] + "shiftRTooLargePass" spec' diff --git a/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/Partial/SubSignedWrap.hs b/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/Partial/SubSignedWrap.hs new file mode 100644 index 000000000..9d180bd44 --- /dev/null +++ b/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/Partial/SubSignedWrap.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +-- | This will succeed with 'sideCondVerifierOptions', as Copilot's @Sub@ +-- operation should underflow on signed integers precisely when C subtraction does. +module Copilot.Verifier.Examples.ShouldPass.Partial.SubSignedWrap where + +import Language.Copilot +import Copilot.Compile.C99 +import Copilot.Verifier ( Verbosity, VerifierOptions(..) + , sideCondVerifierOptions, verifyWithOptions ) +import Copilot.Verifier.Examples.ShouldFail.Partial.SubSignedWrap (spec) + +verifySpec :: Verbosity -> IO () +verifySpec verb = do + spec' <- reify spec + verifyWithOptions sideCondVerifierOptions{verbosity = verb} + mkDefaultCSettings + [] + "subSignedWrapPass" spec' diff --git a/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/Structs.hs b/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/Structs.hs new file mode 100644 index 000000000..7f68e4b20 --- /dev/null +++ b/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/Structs.hs @@ -0,0 +1,92 @@ +-- | An example showing the usage of the What4 backend in copilot-theorem for +-- structs and arrays. Particular focus is on nested structs. +-- For general usage of structs, refer to the general structs example. + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NoImplicitPrelude #-} +module Copilot.Verifier.Examples.ShouldPass.Structs where + +import Control.Monad (void, forM_, when) +import qualified Prelude as P + +import Language.Copilot +import Copilot.Compile.C99 +import Copilot.Theorem.What4 +import Copilot.Verifier ( Verbosity(..), VerifierOptions(..) + , defaultVerifierOptions, verifyWithOptions ) + + +-- | Definition for `Volts`. +data Volts = Volts + { numVolts :: Field "numVolts" Word16 + , flag :: Field "flag" Bool + } + +-- | `Struct` instance for `Volts`. +instance Struct Volts where + typeName _ = "volts" + toValues vlts = [ Value Word16 (numVolts vlts) + , Value Bool (flag vlts) + ] + +-- | `Volts` instance for `Typed`. +instance Typed Volts where + typeOf = Struct (Volts (Field 0) (Field False)) + +data Battery = Battery + { temp :: Field "temp" Word16 + , volts :: Field "volts" (Array 10 Volts) + , other :: Field "other" (Array 10 (Array 5 Word32)) + } + +-- | `Battery` instance for `Struct`. +instance Struct Battery where + typeName _ = "battery" + toValues battery = [ Value typeOf (temp battery) + , Value typeOf (volts battery) + , Value typeOf (other battery) + ] + +-- | `Battery` instance for `Typed`. Note that `undefined` is used as an +-- argument to `Field`. This argument is never used, so `undefined` will never +-- throw an error. +instance Typed Battery where + typeOf = Struct (Battery (Field 0) (Field undefined) (Field undefined)) + +spec :: Spec +spec = do + let battery :: Stream Battery + battery = extern "battery" Nothing + + -- Check equality, indexing into nested structs and arrays. Note that this is + -- trivial by equality. + void $ prop "Example 1" $ forAll $ + (((battery#volts) ! 0)#numVolts) == (((battery#volts) ! 0)#numVolts) + + -- Same as previous example, but get a different array index (so should be + -- false). + void $ prop "Example 2" $ forAll $ + (((battery#other) ! 2) ! 3) == (((battery#other) ! 2) ! 4) + + -- Same as previous example, but in trigger form + trigger "otherTrig" ((((battery#other) ! 2) ! 3) == (((battery#other) ! 2) ! 4)) + [arg battery] + +verifySpec :: Verbosity -> IO () +verifySpec verb = do + spec' <- reify spec + + -- Use Z3 to prove the properties. + results <- prove Z3 spec' + + -- Print the results. + when (verb P.>= Default) $ + forM_ results $ \(nm, res) -> do + putStr $ nm <> ": " + case res of + Valid -> putStrLn "valid" + Invalid -> putStrLn "invalid" + Unknown -> putStrLn "unknown" + + verifyWithOptions defaultVerifierOptions{verbosity = verb} + mkDefaultCSettings [] "structs" spec' diff --git a/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/UpdateArray.hs b/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/UpdateArray.hs new file mode 100644 index 000000000..55a43b1ab --- /dev/null +++ b/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/UpdateArray.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE DataKinds #-} + +-- | An example showing of using @copilot-verifier@ to verify a specification +-- involving arrays where individual elements are updated. +module Copilot.Verifier.Examples.ShouldPass.UpdateArray where + +import Language.Copilot +import Copilot.Compile.C99 +import Copilot.Verifier ( Verbosity, VerifierOptions(..) + , defaultVerifierOptions, verifyWithOptions ) + +spec :: Spec +spec = do + let pair :: Stream (Array 2 Word32) + pair = extern "pair" Nothing + + -- Check equality, indexing into array and modifying the value. Note that + -- this is trivial by equality. + trigger "trig_1" + (((pair !! 0 =$ (+1)) ! 0) == ((pair ! 0) + 1)) + [arg pair] + + -- Same as previous example, but get a different array index (so should be + -- false). + trigger "trig_2" + (((pair !! 0 =$ (+1)) ! 1) == ((pair ! 0) + 1)) + [arg pair] + +verifySpec :: Verbosity -> IO () +verifySpec verb = reify spec >>= verifyWithOptions defaultVerifierOptions{verbosity = verb} + mkDefaultCSettings [] "updateArray" diff --git a/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/UpdateStruct.hs b/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/UpdateStruct.hs new file mode 100644 index 000000000..ecf3f4bdd --- /dev/null +++ b/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/UpdateStruct.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE DataKinds #-} + +-- | An example showing of using @copilot-verifier@ to verify a specification +-- involving structs where individual fields are updated. +module Copilot.Verifier.Examples.ShouldPass.UpdateStruct where + +import Language.Copilot +import Copilot.Compile.C99 +import Copilot.Verifier ( Verbosity, VerifierOptions(..) + , defaultVerifierOptions, verifyWithOptions ) + +-- | Definition for `Volts`. +data Volts = Volts + { numVolts :: Field "numVolts" Word32 + , flag :: Field "flag" Bool + } + +-- | `Struct` instance for `Volts`. +instance Struct Volts where + typeName _ = "volts" + toValues vlts = [ Value Word32 (numVolts vlts) + , Value Bool (flag vlts) + ] + +-- | `Volts` instance for `Typed`. +instance Typed Volts where + typeOf = Struct (Volts (Field 0) (Field False)) + +data Battery = Battery + { temp :: Field "temp" Word32 + , volts :: Field "volts" (Array 10 Volts) + , other :: Field "other" (Array 10 (Array 5 Word32)) + } + +-- | `Battery` instance for `Struct`. +instance Struct Battery where + typeName _ = "battery" + toValues battery = [ Value typeOf (temp battery) + , Value typeOf (volts battery) + , Value typeOf (other battery) + ] + +-- | `Battery` instance for `Typed`. Note that `undefined` is used as an +-- argument to `Field`. This argument is never used, so `undefined` will never +-- throw an error. +instance Typed Battery where + typeOf = Struct (Battery (Field 0) (Field undefined) (Field undefined)) + +spec :: Spec +spec = do + let battery :: Stream Battery + battery = extern "battery" Nothing + + -- Update a struct field, then check it for equality. + trigger "updateTrig" + ((battery ## temp =$ (+1))#temp == (battery#temp + 1)) + [arg battery] + +verifySpec :: Verbosity -> IO () +verifySpec verb = reify spec >>= verifyWithOptions defaultVerifierOptions{verbosity = verb} + mkDefaultCSettings [] "updateStruct" diff --git a/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/Voting.hs b/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/Voting.hs new file mode 100644 index 000000000..46562bdb1 --- /dev/null +++ b/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/Voting.hs @@ -0,0 +1,64 @@ +-------------------------------------------------------------------------------- +-- Copyright © 2019 National Institute of Aerospace / Galois, Inc. +-------------------------------------------------------------------------------- + +-- | Fault-tolerant voting examples. + +{-# LANGUAGE RebindableSyntax #-} + +module Copilot.Verifier.Examples.ShouldPass.Voting where + +import Language.Copilot +import Copilot.Compile.C99 +import Copilot.Verifier ( Verbosity, VerifierOptions(..) + , defaultVerifierOptions, verifyWithOptions ) + +vote :: Spec +vote = do + -- majority selects element with the biggest occurance. + trigger "maj" true [arg maj] + + -- aMajority checks if the selected element has a majority. + trigger "aMaj" true [arg $ aMajority inputs maj] + + where + maj = majority inputs + + -- 26 input streams to vote on + inputs :: [Stream Word32] + inputs = [ a, b, c, d, e, f, g, h, i, j, k, l, m + -- , n, o, p, q, r, s, t, u, v, w, x, y, z + ] + a = [0] ++ a + 1 + b = [0] ++ b + 1 + c = [0] ++ c + 1 + d = [0] ++ d + 1 + e = [1] ++ e + 1 + f = [1] ++ f + 1 + g = [1] ++ g + 1 + h = [1] ++ h + 1 + i = [1] ++ i + 1 + j = [1] ++ j + 1 + k = [1] ++ k + 1 + l = [1] ++ l + 1 + m = [1] ++ m + 1 +{- + n = [1] ++ n + 1 + o = [1] ++ o + 1 + p = [1] ++ p + 1 + q = [1] ++ q + 1 + r = [1] ++ r + 1 + s = [1] ++ s + 1 + t = [1] ++ t + 1 + u = [1] ++ u + 1 + v = [1] ++ v + 1 + w = [1] ++ w + 1 + x = [1] ++ x + 1 + y = [1] ++ y + 1 + z = [1] ++ z + 1 +-} + +verifySpec :: Verbosity -> IO () +--verifySpec _ = interpret 30 vote +verifySpec verb = reify vote >>= verifyWithOptions defaultVerifierOptions{verbosity = verb} + mkDefaultCSettings [] "voting" diff --git a/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/WCV.hs b/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/WCV.hs new file mode 100644 index 000000000..118e7a386 --- /dev/null +++ b/copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/WCV.hs @@ -0,0 +1,189 @@ +-- | This example shows an implementation of the Well-Clear Violation +-- algorithm, it follows the implementation described in 'Analysis of +-- Well-Clear Bounday Models for the Integration of UAS in the NAS', +-- https://ntrs.nasa.gov/citations/20140010078. + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE RebindableSyntax #-} + +module Copilot.Verifier.Examples.ShouldPass.WCV where + +import Language.Copilot +-- import qualified Copilot.Theorem.What4 as CT +import Copilot.Compile.C99 +import Copilot.Verifier ( Verbosity, VerifierOptions(..) + , defaultVerifierOptions, verifyWithOptions ) + +-- import Data.Foldable (forM_) +import qualified Control.Monad as Monad + + +-- | `dthr` is the horizontal distance threshold. +dthr :: Stream Double +dthr = extern "dthr" Nothing + +-- | `tthr` is the horizontal time threshold. +tthr :: Stream Double +tthr = extern "tthr" Nothing + +-- | `zthr` is the vertical distance / altitude threshold. +zthr :: Stream Double +zthr = extern "zthr" Nothing + +-- | `tcoathr` is the vertical time threshold. +tcoathr :: Stream Double +tcoathr = extern "tcoathr" Nothing + +type Vect2 = (Stream Double, Stream Double) + + +------------------ +-- The following section contains basic libraries for working with vectors. +------------------ + +-- | Multiply two Vectors. +(|*|) :: Vect2 -> Vect2 -> Stream Double +(|*|) (x1, y1) (x2, y2) = (x1 * x2) + (y1 * y2) + +-- | Calculate the square of a vector. +sq :: Vect2 -> Stream Double +sq x = x |*| x + +-- | Calculate the length of a vector. +norm :: Vect2 -> Stream Double +norm = sqrt . sq + +-- | Calculate the determinant of two vectors. +det :: Vect2 -> Vect2 -> Stream Double +det (x1, y1) (x2, y2) = (x1 * y2) - (x2 * y1) + +-- | Compare two vectors, taking into account the small error that is +-- introduced by the usage of `Double`s. +(~=) :: Stream Double -> Stream Double -> Stream Bool +a ~= b = (abs (a - b)) < 0.001 + +-- | Negate a vector. +neg :: Vect2 -> Vect2 +neg (x, y) = (negate x, negate y) + + +-------------------- +-- From here on the algorithm, as described by the paper mentioned on the top +-- of this file, is implemented. Please refer to the paper for details. +-------------------- + +tau :: Vect2 -> Vect2 -> Stream Double +tau s v = if s |*| v < 0 + then (-(sq s)) / (s |*| v) + else -1 + +tcpa :: Vect2 -> Vect2 -> Stream Double +tcpa s v@(vx, vy) = if vx ~= 0 && vy ~= 0 + then 0 + else -(s |*| v)/(sq v) + +taumod :: Vect2 -> Vect2 -> Stream Double +taumod s v = if s |*| v < 0 + then (dthr * dthr - (sq s))/(s |*| v) + else -1 + +tep :: Vect2 -> Vect2 -> Stream Double +tep s v = if (s |*| v < 0) && ((delta s v dthr) >= 0) + then theta s v dthr (-1) + else -1 + +delta :: Vect2 -> Vect2 -> Stream Double -> Stream Double +delta s v d = (d*d) * (sq v) - ((det s v)*(det s v)) +-- Here the formula says : (s . orth v)^2 which is the same as det(s,v)^2 + +theta :: Vect2 -> Vect2 -> Stream Double -> Stream Double -> Stream Double +theta s v d e = (-(s |*| v) + e * (sqrt $ delta s v d)) / (sq v) + + +tcoa :: Stream Double -> Stream Double -> Stream Double +tcoa sz vz = if (sz * vz) < 0 + then (-sz) / vz + else -1 + +dcpa :: Vect2 -> Vect2 -> Stream Double +dcpa s@(sx, sy) v@(vx, vy) = norm (sx + (tcpa s v) * vx, sy + (tcpa s v) * vy) + + +-------------------------- +-- Well clear Violation -- +-------------------------- + +-- | Determines if the well clear property is violated or not. +wcv :: (Vect2 -> Vect2 -> Stream Double) -> + Vect2 -> Stream Double -> + Vect2 -> Stream Double -> + Stream Bool +wcv tvar s sz v vz = (horizontalWCV tvar s v) && (verticalWCV sz vz) + +verticalWCV :: Stream Double -> Stream Double -> Stream Bool +verticalWCV sz vz = + ((abs $ sz) <= zthr) || + (0 <= (tcoa sz vz) && (tcoa sz vz) <= tcoathr) + +horizontalWCV :: (Vect2 -> Vect2 -> Stream Double) -> Vect2 -> Vect2 -> Stream Bool +horizontalWCV tvar s v = + (norm s <= dthr) || + (((dcpa s v) <= dthr) && (0 <= (tvar s v)) && ((tvar s v) <= tthr)) + +spec :: Spec +spec = do + -- External streams for relative position and velocity. + let -- The relative x velocity between ownship and the intruder. + vx :: Stream Double + vx = extern "relative_velocity_x" Nothing + + -- The relative y velocity between ownship and the intruder. + vy :: Stream Double + vy = extern "relative_velocity_y" Nothing + + -- The relative z velocity between ownship and the intruder. + vz :: Stream Double + vz = extern "relative_velocity_z" Nothing + + -- The relative velocity as a 2D vector. + v :: (Stream Double, Stream Double) + v = (vx, vy) + + + -- The relative x position between ownship and the intruder. + sx :: Stream Double + sx = extern "relative_position_x" Nothing + + -- The relative y position between ownship and the intruder. + sy :: Stream Double + sy = extern "relative_position_y" Nothing + + -- The relative z position between ownship and the intruder. + sz :: Stream Double + sz = extern "relative_position_z" Nothing + + -- The relative position as a 2D vector. + s :: (Stream Double, Stream Double) + s = (sx, sy) + Monad.void $ prop "1a" (forAll $ (tau s v) ~= (tau (neg s) (neg v))) + -- Monad.void $ prop "3d" (forAll $ (wcv tep s sz v vz) == (wcv tep (neg s) (-sz) (neg v) (-vz))) + trigger "well_clear_violation" (wcv tep s sz v vz) [] + +verifySpec :: Verbosity -> IO () +verifySpec verb = do + spec' <- reify spec + verifyWithOptions defaultVerifierOptions{verbosity = verb} + mkDefaultCSettings [] "wcv" spec' + +{- + -- Use Z3 to prove the properties. + results <- CT.prove CT.Z3 spec' + + -- Print the results. + forM_ results $ \(nm, res) -> do + putStr $ nm <> ": " + case res of + CT.Valid -> putStrLn "valid" + CT.Invalid -> putStrLn "invalid" + CT.Unknown -> putStrLn "unknown" +-} diff --git a/copilot-verifier/exe/VerifyExamples.hs b/copilot-verifier/exe/VerifyExamples.hs new file mode 100644 index 000000000..9fad16b53 --- /dev/null +++ b/copilot-verifier/exe/VerifyExamples.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where + +import qualified Data.CaseInsensitive as CI +import Data.CaseInsensitive (CI) +import Data.Foldable (for_) +import qualified Data.Map as Map +import qualified Data.Text as Text +import qualified Data.Text.IO as Text +import Data.Text (Text) +import Data.Traversable (for) +import Options.Applicative + +import Copilot.Verifier (Verbosity(..)) +import Copilot.Verifier.Examples (shouldFailExamples, shouldPassExamples) + +newtype Options = Options + { examples :: [CI Text] + } deriving Show + +optsParser :: Parser Options +optsParser = Options + <$> (some . strArgument) + ( metavar "EXAMPLE1 [EXAMPLE2 ...]" + <> help "The names of the examples to run" ) + +main :: IO () +main = execParser opts >>= verifyExamples + where + opts = info (optsParser <**> helper) + ( fullDesc + <> header "Run one or more copilot-verifier examples" + <> progDesc (unlines [ "Run one or more examples from the copilot-verifier/examples directory." + , "Each EXAMPLE must correspond to an example name." + ])) + +verifyExamples :: Options -> IO () +verifyExamples Options{examples} = do + -- Check that all requested examples exist + examplesWithMain <- for examples $ \example -> + case Map.lookup example (shouldFailExamples Default `Map.union` shouldPassExamples Default) of + Just m -> pure (example, m) + Nothing -> fail $ "No example named " ++ Text.unpack (CI.original example) + + -- Run the examples + for_ examplesWithMain $ \(example, exampleMain) -> do + Text.putStrLn "=====" + Text.putStrLn $ "== Running the " <> CI.original example <> " example..." + Text.putStrLn "=====" + Text.putStrLn "" + exampleMain + Text.putStrLn "" diff --git a/copilot-verifier/src/Copilot/Verifier.hs b/copilot-verifier/src/Copilot/Verifier.hs new file mode 100644 index 000000000..cd0f3d877 --- /dev/null +++ b/copilot-verifier/src/Copilot/Verifier.hs @@ -0,0 +1,1607 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Copilot.Verifier + ( verify + , verifyWithOptions + , VerifierOptions(..) + , defaultVerifierOptions + , sideCondVerifierOptions + , Verbosity(..) + ) where + +import Control.Lens (view, (^.), to) +import Control.Monad (foldM, forM_, unless, when) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.State (execStateT, lift, StateT(..)) +import Data.Aeson (ToJSON) +import Data.Foldable (traverse_) +import Data.Functor (void) +import qualified Data.Text as Text +import qualified Data.Map.Strict as Map +import Data.IORef (newIORef, modifyIORef', readIORef, IORef) +import qualified Text.LLVM.AST as L +import Data.List (genericLength, sort) +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NE +import qualified Data.Vector as V +import qualified Data.BitVector.Sized as BV +import GHC.Generics (Generic) +import qualified Prettyprinter as PP +import System.Exit (exitFailure) +import System.FilePath ((), (<.>)) + +import Copilot.Compile.C99 (CSettings(..), compileWith) +import Copilot.Core +import qualified Copilot.Core.Type as CT + +import qualified Copilot.Theorem.What4 as CW4 + +import qualified Copilot.Verifier.FloatMode as FloatMode +import qualified Copilot.Verifier.Log as Log +import qualified Copilot.Verifier.Solver as Solver + +import Data.Parameterized.Ctx (EmptyCtx) +import Data.Parameterized.Context (pattern Empty) +import qualified Data.Parameterized.Context as Ctx +import Data.Parameterized.NatRepr (intValue, natValue, testEquality, knownNat, type (<=) ) +import Data.Parameterized.Nonce (globalNonceGenerator) +import Data.Parameterized.Some (Some(..)) +import Data.Parameterized.TraversableFC (toListFC) +import Data.Parameterized.TraversableFC.WithIndex (ifoldlMFC) +import qualified Data.Parameterized.Vector as PVec + +import Lang.Crucible.Backend + ( IsSymInterface, Goals(..), Assumptions, Assertion + , pushAssumptionFrame, popUntilAssumptionFrame + , getProofObligations, clearProofObligations + , LabeledPred(..), abortExecBecause, AbortExecReason(..), addAssumption + , addDurableAssertion, addDurableProofObligation + , CrucibleAssumption(..), ppAbortExecReason + , IsSymBackend(..), HasSymInterface(..) + , labeledPred, labeledPredMsg + -- , ProofObligations, proofGoal, goalsToList, labeledPredMsg + ) +import Lang.Crucible.Backend.Simple (SimpleBackend, newSimpleBackend) +import Lang.Crucible.CFG.Core (AnyCFG(..), cfgArgTypes, cfgReturnType) +import Lang.Crucible.CFG.Common ( freshGlobalVar ) +import Lang.Crucible.FunctionHandle (HandleAllocator, newHandleAllocator) +import Lang.Crucible.Simulator + ( SimContext(..), ctxSymInterface, ExecResult(..), ExecState(..) + , defaultAbortHandler, runOverrideSim, partialValue, gpValue + , GlobalVar, executeCrucible, OverrideSim, ovrWithBackend, regValue + , readGlobal, modifyGlobal, callCFG, emptyRegMap, RegEntry(..) + , AbortedResult(..) + ) +import Lang.Crucible.Simulator.ExecutionTree ( withBackend ) +import Lang.Crucible.Simulator.GlobalState ( insertGlobal ) +import Lang.Crucible.Simulator.RegValue (RegValue, RegValue'(..)) +import Lang.Crucible.Simulator.SimError (SimError(..), SimErrorReason(..)) -- ppSimError +import Lang.Crucible.Types + ( TypeRepr(..), (:~:)(..), KnownRepr(..), NatType ) + +import Lang.Crucible.LLVM (llvmGlobals, registerLazyModule, register_llvm_overrides) +import Lang.Crucible.LLVM.Bytes (bitsToBytes) +import Lang.Crucible.LLVM.DataLayout (Alignment, DataLayout) +import Lang.Crucible.LLVM.Errors (BadBehavior) +import Lang.Crucible.LLVM.Extension (LLVM, ArchWidth) +import Lang.Crucible.LLVM.Globals (initializeAllMemory, populateAllGlobals) +import Lang.Crucible.LLVM.Intrinsics + ( IntrinsicsOptions, OverrideTemplate, basic_llvm_override, LLVMOverride(..) ) + +import Lang.Crucible.LLVM.MemType + ( MemType(..), SymType(..) + , i1, i8, i16, i32, i64 + , memTypeSize, memTypeAlign + , mkStructInfo + ) +import Lang.Crucible.LLVM.MemModel + ( mkMemVar, withPtrWidth, HasLLVMAnn, LLVMAnnMap, MemImpl + , HasPtrWidth, doResolveGlobal, doStore + , LLVMPtr, LLVMVal, MemOptions, PartLLVMVal(..), StorageType, bitvectorType + , ptrAdd, toStorableType, projectLLVM_bv + , pattern LLVMPointerRepr, pattern PtrRepr, loadRaw, llvmPointer_bv + , memRepr, Mem, unpackMemValue + ) +import Lang.Crucible.LLVM.MemModel.CallStack (CallStack) +import Lang.Crucible.LLVM.MemModel.Partial (BoolAnn(..)) +import Lang.Crucible.LLVM.PrettyPrint (ppSymbol) +import Lang.Crucible.LLVM.Translation + ( LLVMTranslationWarning(..), ModuleTranslation + , getTranslatedCFG, translateModule, globalInitMap + , transContext, llvmPtrWidth, llvmTypeCtx, llvmTypeAsRepr + ) +import Lang.Crucible.LLVM.TypeContext (TypeContext, llvmDataLayout) + +import Crux (defaultOutputConfig) +import Crux.Config (cfgJoin, Config(..)) +import Crux.Config.Load (fromFile, fromEnv) +import Crux.Config.Common + ( cruxOptions, CruxOptions(..), postprocessOptions, outputOptions + , OutputOptions(..) + ) +import Crux.Goal (proveGoalsOffline, provedGoalsTree) +import qualified Crux.Log as Log +import Crux.Types (SimCtxt, Crux, ProcessedGoals(..), ProofResult(..)) + +import Crux.LLVM.Config (llvmCruxConfig, LLVMOptions(..)) +import Crux.LLVM.Compile (genBitCode) +import qualified Crux.LLVM.Log as Log +import Crux.LLVM.Simulate (setupSimCtxt, parseLLVM, explainFailure) +import CruxLLVMMain (processLLVMOptions) + +import What4.Config + (extendConfig) +import What4.Interface + ( Pred, bvLit, bvAdd, bvUrem, bvMul, bvIsNonzero, bvEq, isEq + , getConfiguration, freshBoundedBV, predToBV + , getCurrentProgramLoc, printSymExpr + , truePred, falsePred, andPred, annotateTerm, backendPred + , getAnnotation, natAdd, natEq, natIte, natLit + ) +import What4.Expr.Builder + ( Flags, ExprBuilder, BoolExpr, startCaching + , newExprBuilder + ) +import What4.FunctionName (functionName) +import What4.InterpretedFloatingPoint + ( FloatInfoRepr(..), IsInterpretedFloatExprBuilder(..) + , SingleFloat, DoubleFloat + ) +import What4.ProgramLoc (ProgramLoc, mkProgramLoc, plFunction, Position(..)) +import What4.Solver.Adapter (SolverAdapter(..)) +import What4.Symbol (safeSymbol) + +-- | @'verify' csettings props prefix spec@ verifies the Copilot specification +-- @spec@ under the assumptions @props@ matches the behavior of the C program +-- compiled with @csettings@ within a directory prefixed by @prefix@. +verify :: CSettings -> [String] -> String -> Spec -> IO () +verify = verifyWithOptions defaultVerifierOptions + +-- | Options for configuring the behavior of the verifier. +data VerifierOptions = VerifierOptions + { verbosity :: Verbosity + -- ^ How much output the verifier should produce. + , assumePartialSideConds :: Bool + -- ^ If 'True', the verifier will determine the conditions under which + -- a Copilot specification's partial operations are well defined and + -- add these side conditions as assumptions. As a result, even if the + -- generated C code performs a partial operation, the verification will + -- succeed if this partial operation coincides with a corresponding + -- operation on the Copilot side. + -- + -- If 'False', the verifier will not assume any side conditions related + -- to partial operations in the Copilot specification. As a result, any + -- use of a partial operation in the generated C code will cause + -- verification to fail unless the user adds their own assumptions. + , logSmtInteractions :: Bool + -- ^ If 'True', create log files corresponding to the SMT solver + -- interactions used to discharge each proof goal. The file will be named + -- @--.smt2@, where: + -- + -- * @@ will be either @initial-step@ or @transition-step@, depending + -- on which step of the proof the goal corresponds to. + -- + -- * @@ will be the number of the goal, starting at 0 and + -- counting up. Note that each step of the proof has its own goal + -- numbers. This means that there can be both an + -- @initial-step-0-.smt2@ and a @transition-step-0-.smt2@, + -- and similarly for other numbers. + -- + -- * @@ is the name of the SMT solver used to discharge the proof + -- goal. Currently, this will always be @z3@, although we might make this + -- configurable in the future. + , smtSolver :: Solver.Solver + -- ^ Which SMT solver to use when solving proof goals. + , smtFloatMode :: FloatMode.FloatMode + -- ^ How the verifier should interpret floating-point operations when + -- translating them to SMT. + -- + -- By default, the verifier will treat all floating-point operations as + -- uninterpreted functions ('FloatMode.FloatUninterpreted'). This allows the + -- verifier to perform some limited reasoning about floating-point + -- operations that SMT solvers do not have built-in operations for (@sin@, + -- @cos@, @tan@, etc.), but at the expense of not being able to verify C + -- code in which the compiler optimizes floating-point expressions. One can + -- also opt into an alternative mode where floating-point values are treated + -- as IEEE-754 floats ('FloatMode.FloatIEEE'), but this comes with the + -- drawback that the verifier will not be able to perform /any/ reasoning + -- about @sin@, @cos@, @tan@, etc. + } deriving stock Show + +-- | The default 'VerifierOptions': +-- +-- * Produce a reasonable amount of diagnostics as verification proceeds +-- ('Default'). +-- +-- * Do not assume any side conditions related to partial operations. +-- +-- * Do not log any SMT solver interactions. +-- +-- * Use the Z3 SMT solver. +-- +-- * Treat all floating-point operations as uninterpreted functions when +-- translating to SMT. +defaultVerifierOptions :: VerifierOptions +defaultVerifierOptions = VerifierOptions + { verbosity = Default + , assumePartialSideConds = False + , logSmtInteractions = False + , smtSolver = Solver.Z3 + , smtFloatMode = FloatMode.FloatUninterpreted + } + +-- | Like 'defaultVerifierOptions', except that the verifier will assume side +-- conditions related to partial operations used in the Copilot spec. +sideCondVerifierOptions :: VerifierOptions +sideCondVerifierOptions = defaultVerifierOptions + { assumePartialSideConds = True + } + +-- | How much output should verification produce? +-- +-- The data constructors are listed in increasing order of how many diagnostics +-- they produce. +data Verbosity + = Quiet -- ^ Don't produce any diagnostics. + | Default -- ^ Produce a reasonable amount of diagnostics as verification proceeds. + | Noisy -- ^ Produce as many diagnostics as possible. + deriving stock (Eq, Ord, Show) + +-- | Like 'verify', but with 'VerifierOptions' to more finely control the +-- verifier's behavior. +verifyWithOptions :: VerifierOptions -> CSettings -> [String] -> String -> Spec -> IO () +verifyWithOptions opts csettings0 properties prefix spec = + withCopilotLogging $ + do -- munge options structures into the necessary forms + (ocfg, cruxOpts, llvmOpts, csettings, csrc) <- computeConfiguration opts csettings0 prefix + let ?outputConfig = ocfg + + -- Compile the Copilot spec into C source code, using + -- preexisting Copilot library calls. + compileWith csettings prefix spec + Log.sayCopilot $ Log.GeneratedCFile csrc + + -- Compile the C source into LLVM bitcode, using preexisting + -- Crux library calls. + bcFile <- genBitCode cruxOpts llvmOpts + Log.sayCopilot $ Log.CompiledBitcodeFile prefix bcFile + + -- Run the main verification procedure + verifyBitcode opts csettings properties spec cruxOpts llvmOpts csrc bcFile + + +-- | Do the (surprisingly large amount) of options munging necessary to set up +-- the crucible/crux environment. +computeConfiguration :: + Log.SupportsCruxLogMessage CopilotLogging => + VerifierOptions -> CSettings -> FilePath -> + IO (Log.OutputConfig CopilotLogging, CruxOptions, LLVMOptions, CSettings, FilePath) +computeConfiguration opts csettings0 prefix = + do ocfg1 <- defaultOutputConfig copilotLoggingToSayWhat + let quiet = verbosity opts == Quiet + let ocfg2 mbOutputOpts = (ocfg1 mbOutputOpts) { Log._quiet = quiet } + llvmcfg <- llvmCruxConfig + let cfg = cfgJoin cruxOptions llvmcfg + -- TODO, load from an actual configuration file? + fileOpts <- fromFile "copilot-verifier" cfg Nothing + (cruxOpts0, llvmOpts0) <- foldM fromEnv fileOpts (cfgEnv cfg) + let odir0 = cSettingsOutputDirectory csettings0 + let odir = -- A bit grimy, but this corresponds to how crux-llvm sets + -- its output directory. + if odir0 == "." + then "results" prefix + else odir0 + let csettings = csettings0{ cSettingsOutputDirectory = odir } + let csrc = odir prefix ++ ".c" + let cruxOpts1 = cruxOpts0{ outDir = odir, bldDir = odir, inputFiles = [csrc] + , outputOptions = + (outputOptions cruxOpts0) + { quietMode = quiet + , simVerbose = if verbosity opts > Default + then 2 + else 0 + } + } + let ?outputConfig = ocfg2 (Just (outputOptions cruxOpts1)) + cruxOpts2 <- postprocessOptions cruxOpts1 + + -- Tweak the options passed to Clang: + -- + -- - Fix the optimization level to -O0. + -- + -- - Pass -ffp-contract=off to prevent sequences of floating-point + -- multiplications/additions from being optimized to llvm.fmuladd + -- intrinsics, which makes floating-point verification fragile. + let llvmOpts1 = llvmOpts0 + { optLevel = 0 + , clangOpts = "-ffp-contract=off" : clangOpts llvmOpts0 + } + (cruxOpts3, llvmOpts2) <- processLLVMOptions (cruxOpts2, llvmOpts1) + + let ocfg3 = ocfg2 (Just (outputOptions cruxOpts3)) + return (ocfg3, cruxOpts3, llvmOpts2, csettings, csrc) + + +data CopilotVerifierData t = CopilotVerifierData + + +-- | Main entry point for the verifier. +verifyBitcode :: + Log.Logs msgs => + Log.SupportsCruxLogMessage msgs => + Log.SupportsCruxLLVMLogMessage msgs => + Log.SupportsCopilotLogMessage msgs => + VerifierOptions {- ^ Verifier-specific settings -} -> + CSettings {- ^ Settings used to compile the Copilot spec. Used to find the names of functions and variables. -} -> + [String] {- ^ Names of properties to assume during verification. -} -> + Spec {- ^ The input Copilot specification -} -> + CruxOptions {- ^ Crux options -} -> + LLVMOptions {- ^ CruxLLVM options -} -> + FilePath {- ^ Path to the generated C file (for logging purposes only) -} -> + FilePath {- ^ Path to the bitcode file to verify -} -> + IO () +verifyBitcode opts csettings properties spec cruxOpts llvmOpts cFile bcFile = + FloatMode.withFloatMode (smtFloatMode opts) $ \fm -> + do -- Set up the expression builder and symbolic backend + halloc <- newHandleAllocator + sym <- newExprBuilder fm CopilotVerifierData globalNonceGenerator + bak <- newSimpleBackend sym + -- turn on hash-consing + startCaching sym + + FloatMode.withInterpretedFloatExprBuilder sym fm $ + verifyWithSymBackend bak halloc + where + verifyWithSymBackend :: + forall t st fm. + IsInterpretedFloatExprBuilder (ExprBuilder t st (Flags fm)) => + SimpleBackend t st (Flags fm) -> + HandleAllocator -> + IO () + verifyWithSymBackend bak halloc = do + let sym = backendGetSym bak + -- capture LLVM side-condition information for use in error reporting + clRefs <- newCopilotLogRefs + let ?recordLLVMAnnotation = recordLLVMAnnotation clRefs + + -- Set up the solver to use for verification. + let adapter :: SolverAdapter st + adapter = Solver.solverAdapter (smtSolver opts) + extendConfig (solver_adapter_config_options adapter) (getConfiguration sym) + + -- Set up the Crucible/LLVM simulation context + memVar <- mkMemVar "llvm_memory" halloc + let simctx = (setupSimCtxt halloc bak (memOpts llvmOpts) memVar) + { printHandle = view Log.outputHandle ?outputConfig } + + -- Load and translate the input LLVM module + llvmMod <- parseLLVM bcFile + Some trans <- + let ?transOpts = transOpts llvmOpts + in translateModule halloc memVar llvmMod + + Log.sayCopilot Log.TranslatedToCrucible + + -- Grab some metadata from the bitcode file and options; + -- make the available via implicit arguments to the places + -- that expect them. + let llvmCtxt = trans ^. transContext + let ?lc = llvmCtxt ^. llvmTypeCtx + let ?memOpts = memOpts llvmOpts + let ?intrinsicsOpts = intrinsicsOpts llvmOpts + + llvmPtrWidth llvmCtxt $ \ptrW -> + withPtrWidth ptrW $ + + do -- Compute the LLVM memory state with global variables allocated + -- but not initialized + emptyMem <- initializeAllMemory bak llvmCtxt llvmMod + + -- Compute the LLVM memory state with global variables initialized + -- to their initial values. + initialMem <- populateAllGlobals bak (trans ^. globalInitMap) emptyMem + + -- Use the Copilot spec directly to compute the symbolic states + -- necessary to carry out the states of the bisimulation proof. + Log.sayCopilot Log.GeneratingProofState + proofStateBundle <- CW4.computeBisimulationProofBundle sym properties spec + + -- First check that the initial state of the program matches the starting + -- segment of the associated Copilot streams. + let cruxOptsInit = setCruxOfflineSolverOutput "initial-step" cruxOpts + initGoals <- + verifyInitialState cruxOptsInit [adapter] clRefs simctx initialMem + (CW4.initialStreamState proofStateBundle) + + -- Now, the real meat. Carry out the bisimulation step of the proof. + let cruxOptsTrans = setCruxOfflineSolverOutput "transition-step" cruxOpts + bisimGoals <- + verifyStepBisimulation opts cruxOptsTrans [adapter] csettings + clRefs simctx llvmMod trans memVar initialMem proofStateBundle + + Log.sayCopilot $ Log.SuccessfulProofSummary cFile initGoals bisimGoals + -- We only want to inform users about Noisy if the verbosity level is + -- sufficiently low. Crux's logging framework isn't particularly + -- suited to doing this, as it assumes that all log messages enabled + -- for low verbosity levels should also be enabled for higher + -- verbosity levels. That is a reasonable assumption most of the time, + -- but not here. + -- + -- To compensate, we hack around the issue by manually checking the + -- verbosity level before logging the message. + when (verbosity opts < Noisy) $ + Log.sayCopilot Log.NoisyVerbositySuggestion + + -- If @logSmtInteractions@ is enabled, enable offline solver output in the + -- supplied 'CruxOptions' with the supplied file template. Otherwise, return + -- the supplied 'CruxOptions' unaltered. + setCruxOfflineSolverOutput :: FilePath -> CruxOptions -> CruxOptions + setCruxOfflineSolverOutput template cruxOpts' + | logSmtInteractions opts + = cruxOpts' + { offlineSolverOutput = Just $ outDir cruxOpts' template <.> "smt2" } + | otherwise + = cruxOpts' + +-- | Capture LLVM side-condition information for use in error reporting. +recordLLVMAnnotation :: + IsSymInterface sym => + CopilotLogRefs sym -> + CallStack -> + BoolAnn sym -> + BadBehavior sym -> + IO () +recordLLVMAnnotation clRefs stk bann bb = + modifyIORef' (llvmAnnMapRef clRefs) (Map.insert bann (stk, bb)) + +-- | Prove that the state of the global variables at program startup +-- matches the expected initial segments of the associated Copilot +-- streams. +verifyInitialState :: + IsSymInterface sym => + Log.Logs msgs => + Log.SupportsCruxLogMessage msgs => + Log.SupportsCopilotLogMessage msgs => + sym ~ ExprBuilder t st fs => + HasPtrWidth wptr => + HasLLVMAnn sym => + (?memOpts :: MemOptions) => + (?lc :: TypeContext) => + + CruxOptions -> + [SolverAdapter st] -> + CopilotLogRefs sym -> + SimCtxt Crux sym LLVM -> + MemImpl sym -> + CW4.BisimulationProofState sym -> + IO Integer +verifyInitialState cruxOpts adapters clRefs simctx mem initialState = + withBackend simctx $ \bak -> + do Log.sayCopilot $ Log.ComputingConditions Log.InitialState + frm <- pushAssumptionFrame bak + + assertStateRelation bak clRefs mem + Log.InitialStateRelation initialState + + popUntilAssumptionFrame bak frm + + Log.sayCopilot $ Log.ProvingConditions Log.InitialState + proveObls cruxOpts adapters clRefs Log.InitialState simctx + + +verifyStepBisimulation :: + IsSymInterface sym => + Log.Logs msgs => + Log.SupportsCruxLogMessage msgs => + Log.SupportsCruxLLVMLogMessage msgs => + Log.SupportsCopilotLogMessage msgs => + sym ~ ExprBuilder t st fs => + HasPtrWidth wptr => + HasLLVMAnn sym => + (1 <= ArchWidth arch) => + HasPtrWidth (ArchWidth arch) => + (?memOpts :: MemOptions) => + (?lc :: TypeContext) => + (?intrinsicsOpts :: IntrinsicsOptions) => + + VerifierOptions -> + CruxOptions -> + [SolverAdapter st] -> + CSettings -> + CopilotLogRefs sym -> + SimCtxt Crux sym LLVM -> + L.Module -> + ModuleTranslation arch -> + GlobalVar Mem -> + MemImpl sym -> + CW4.BisimulationProofBundle sym -> + IO Integer +verifyStepBisimulation opts cruxOpts adapters csettings clRefs simctx llvmMod modTrans memVar mem prfbundle = + withBackend simctx $ \bak -> + do Log.sayCopilot $ Log.ComputingConditions Log.StepBisimulation + + frm <- pushAssumptionFrame bak + + do -- set up the memory image + mem' <- setupPrestate bak mem prfbundle + + -- sanity check, verify that we set up the memory in the expected relation + assertStateRelation bak clRefs mem' + Log.PreStepStateRelation (CW4.preStreamState prfbundle) + + -- set up trigger guard global variables + let halloc = simHandleAllocator simctx + -- See Note [Global variables for trigger functions] + let prepTrigger (nm, guard, _) = + do gv <- freshGlobalVar halloc (Text.pack (nm ++ "_called")) NatRepr + return (nm, gv, guard) + + checkDuplicateTriggerNames :: [Name] -> IO () + checkDuplicateTriggerNames triggers = + traverse_ checkDuplicateTriggerName $ NE.group $ sort triggers + + checkDuplicateTriggerName :: NonEmpty Name -> IO () + checkDuplicateTriggerName (trig :| dupTrigs) = + unless (null dupTrigs) $ + fail $ unlines + [ "The specification invokes the `" ++ trig ++ + "` trigger function multiple times," + , "which copilot-verifier does not currently support." + , "See https://github.com/Copilot-Language/copilot-verifier/issues/74." + ] + let triggerState = CW4.triggerState prfbundle + checkDuplicateTriggerNames $ map (\(nm,_,_) -> nm) triggerState + triggerGlobals <- mapM prepTrigger triggerState + + -- execute the step function + let overrides = zipWith (triggerOverride clRefs) triggerGlobals triggerState + mem'' <- executeStep opts csettings clRefs simctx memVar mem' llvmMod modTrans triggerGlobals overrides (CW4.assumptions prfbundle) (CW4.sideConds prfbundle) + + -- assert the poststate is in the relation + assertStateRelation bak clRefs mem'' + Log.PostStepStateRelation (CW4.postStreamState prfbundle) + + popUntilAssumptionFrame bak frm + + Log.sayCopilot $ Log.ProvingConditions Log.StepBisimulation + proveObls cruxOpts adapters clRefs Log.StepBisimulation simctx + + +-- | Set up the "trigger override" functions. These dummy functions +-- take the place of the external functions called by the Copilot +-- monitor when a guarded condition occurs. +-- +-- Each trigger statement has a corresponding global variable that +-- is used to record if the trigger function was called; initially +-- the global is false, and is set to true when the trigger function +-- is called. At the end of verification, we check that the value +-- of this global variable is true iff the corresponding trigger guard +-- condition is true. +-- +-- The other function of the trigger overrides is to check that, when called, +-- the functions are given the expected argument values. +-- +-- Otherwise, the override functions have no effects, which corresponds +-- to the assumption that the external environment makes no changes to the +-- program state that are observable to the Copilot monitor. +triggerOverride :: forall sym t arch msgs. + IsSymInterface sym => + Log.Logs msgs => + Log.SupportsCopilotLogMessage msgs => + (?memOpts :: MemOptions) => + (?lc :: TypeContext) => + (?intrinsicsOpts :: IntrinsicsOptions) => + (1 <= ArchWidth arch) => + HasPtrWidth (ArchWidth arch) => + HasLLVMAnn sym => + + CopilotLogRefs sym -> + (Name, GlobalVar NatType, Pred sym) -> + (Name, BoolExpr t, [(Some Type, CW4.XExpr sym)]) -> + OverrideTemplate (Crux sym) sym LLVM arch +triggerOverride clRefs (_,triggerGlobal,_) (nm, _guard, args) = + let args' = map toTypeRepr args in + case Ctx.fromList args' of + Some argCtx -> + basic_llvm_override $ + LLVMOverride decl argCtx UnitRepr $ + \memOps calledArgs -> + ovrWithBackend $ \bak -> + do let sym = backendGetSym bak + modifyGlobal triggerGlobal $ \count -> do + -- See Note [Global variables for trigger functions] + countPlusOne <- liftIO $ do + one <- natLit sym 1 + natAdd sym count one + pure ((), countPlusOne) + mem <- readGlobal memOps + liftIO $ checkArgs bak mem (toListFC Some calledArgs) args + return () + + where + decl = L.Declare + { L.decLinkage = Nothing + , L.decVisibility = Nothing + , L.decRetType = L.PrimType L.Void + , L.decName = L.Symbol nm + , L.decArgs = map llvmArgTy args + , L.decVarArgs = False + , L.decAttrs = [] + , L.decComdat = Nothing + } + + -- Use the `-CompositePtr` functions here to ensure that arguments with array + -- or struct types are treated as pointers. See Note [Arrays and structs]. + toTypeRepr (Some ctp, _) = llvmTypeAsRepr (copilotTypeToMemTypeCompositePtr (llvmDataLayout ?lc) ctp) Some + llvmArgTy (Some ctp, _) = copilotTypeToLLVMTypeCompositePtr ctp + + checkArgs :: forall bak. IsSymBackend sym bak => + bak -> MemImpl sym -> [Some (RegEntry sym)] -> [(Some Type, CW4.XExpr sym)] -> IO () + checkArgs bak mem = loop (0::Integer) + where + loop i (x:xs) ((ctp,v):vs) = checkArg bak mem i x ctp v >> loop (i+1) xs vs + loop _ [] [] = return () + loop _ _ _ = fail $ "Argument list mismatch in " ++ nm + + checkArg :: forall bak. IsSymBackend sym bak => + bak -> MemImpl sym -> Integer -> Some (RegEntry sym) -> Some Type -> CW4.XExpr sym -> IO () + checkArg bak mem i (Some (RegEntry tp v)) (Some ctp) x = + do let sym = backendGetSym bak + eq <- computeEqualVals bak clRefs mem ctp x tp v + (ann, eq') <- annotateTerm sym eq + let shortmsg = "Trigger " ++ show nm ++ " argument " ++ show i + let longmsg = show (printSymExpr eq') + let rsn = AssertFailureSimError shortmsg longmsg + loc <- getCurrentProgramLoc sym + modifyIORef' (verifierAssertionMapRef clRefs) + $ Map.insert (BoolAnn ann) + $ Log.TriggerArgumentEqualityAssertion + $ Log.SomeSome + $ Log.TriggerArgumentEquality sym loc nm i ctp x tp v + addDurableProofObligation bak (LabeledPred eq' (SimError loc rsn)) + + +-- | Actually execute the Crucible simulator on the generated "step" function. +-- This will record proof side-conditions into the symbolic backend, and +-- return the memory state corresponding to the function post-state. +-- +-- This function will record side-conditions that arise from the semantics +-- of C itself (e.g., memory is accessed in bounds and signed arithmetic +-- doesn't overflow) as well as the conditions related to trigger functions. +executeStep :: forall sym arch msgs. + IsSymInterface sym => + Log.Logs msgs => + Log.SupportsCruxLLVMLogMessage msgs => + Log.SupportsCopilotLogMessage msgs => + (?memOpts :: MemOptions) => + (?lc :: TypeContext) => + (?intrinsicsOpts :: IntrinsicsOptions) => + (1 <= ArchWidth arch) => + HasPtrWidth (ArchWidth arch) => + HasLLVMAnn sym => + + VerifierOptions -> + CSettings -> + CopilotLogRefs sym -> + SimCtxt Crux sym LLVM -> + GlobalVar Mem -> + MemImpl sym -> + L.Module -> + ModuleTranslation arch -> + [(Name, GlobalVar NatType, Pred sym)] -> + [OverrideTemplate (Crux sym) sym LLVM arch] -> + [Pred sym] {- User-provided property assumptions -} -> + [Pred sym] {- Side conditions related to partial operations -} -> + IO (MemImpl sym) +executeStep opts csettings clRefs simctx memVar mem llvmmod modTrans triggerGlobals triggerOverrides assums sideConds = + do globSt <- foldM setupTrigger (llvmGlobals memVar mem) triggerGlobals + let initSt = InitialState simctx globSt defaultAbortHandler memRepr $ + runOverrideSim memRepr runStep + res <- executeCrucible [] initSt + case res of + FinishedResult _ pr -> return (pr^.partialValue.gpValue.to regValue) + AbortedResult _ abortRes -> fail $ show $ ppAbortedResult abortRes + TimeoutResult{} -> fail "simulation timed out!" + + where + -- See Note [Global variables for trigger functions] + setupTrigger gs (_,gv,_) = do + zero <- liftIO $ natLit sym 0 + pure $ insertGlobal gv zero gs + llvm_ctx = modTrans ^. transContext + stepName = cSettingsStepFunctionName csettings + sym = simctx^.ctxSymInterface + + -- TODO, would be lovely to be able to do better than dummy positions for all these things + -- so we can correspond assumptions and asserts back to the parts of the original spec that + -- gave rise to them. + dummyLoc = mkProgramLoc "<>" InternalPos + + assumeProperty b = + withBackend simctx $ \bak -> + addAssumption bak (GenericAssumption dummyLoc "Property assumption" b) + + assumeSideCond b = + withBackend simctx $ \bak -> + addAssumption bak (GenericAssumption dummyLoc "Side condition for partial operation" b) + + ppAbortedResult :: AbortedResult sym ext -> PP.Doc ann + ppAbortedResult abortRes = + case gatherReasons abortRes of + reason :| [] -> reason + reasons -> PP.vcat $ "Simulation aborted for multiple reasons." + : NE.toList reasons + + gatherReasons :: AbortedResult sym ext -> NonEmpty (PP.Doc ann) + gatherReasons (AbortedExec rsn _) = + PP.vcat ["Simulation aborted!", ppAbortExecReason rsn] :| [] + gatherReasons (AbortedExit ec) = + PP.vcat ["Simulation called exit!", PP.viaShow ec] :| [] + gatherReasons (AbortedBranch _ _ t f) = + gatherReasons t <> gatherReasons f + + -- Simulator entry point + runStep :: OverrideSim (Crux sym) sym LLVM (RegEntry sym Mem) EmptyCtx Mem (MemImpl sym) + runStep = + do -- set up built-in functions and trigger overrides + _ <- register_llvm_overrides llvmmod [] triggerOverrides llvm_ctx + -- set up functions defined in the module + registerLazyModule sayTranslationWarning modTrans + + -- make any property assumptions + liftIO (mapM_ assumeProperty assums) + + -- assume side conditions related to partial operations + when (assumePartialSideConds opts) $ liftIO $ + mapM_ assumeSideCond sideConds + + -- look up and call the step function + mbCfg <- liftIO $ getTranslatedCFG modTrans (L.Symbol stepName) + () <- case mbCfg of + Just (_, AnyCFG anyCfg, warns) -> do + liftIO $ mapM_ sayTranslationWarning warns + case (cfgArgTypes anyCfg, cfgReturnType anyCfg) of + (Empty, UnitRepr) -> regValue <$> callCFG anyCfg emptyRegMap + _ -> fail $ unwords [show stepName, "should take no arguments and return void"] + Nothing -> fail $ unwords ["Could not find step function named", show stepName] + + -- Assert that the trigger functions were called exactly once iff the + -- associated guard condition was true. + -- See Note [Global variables for trigger functions]. + forM_ triggerGlobals $ \(nm, gv, guard) -> + do expectedCount <- liftIO $ do + one <- natLit sym 1 + zero <- natLit sym 0 + natIte sym guard one zero + actualCount <- readGlobal gv + eq <- liftIO $ natEq sym expectedCount actualCount + (ann, eq') <- liftIO $ annotateTerm sym eq + let shortmsg = "Trigger guard equality condition: " ++ show nm + let longmsg = show (printSymExpr eq') + let rsn = AssertFailureSimError shortmsg longmsg + liftIO + $ modifyIORef' (verifierAssertionMapRef clRefs) + $ Map.insert (BoolAnn ann) + $ Log.TriggersInvokedCorrespondinglyAssertion + $ Log.TriggersInvokedCorrespondingly dummyLoc nm expectedCount actualCount + withBackend simctx $ \bak -> + liftIO $ addDurableProofObligation bak (LabeledPred eq' (SimError dummyLoc rsn)) + + -- return the final state of the memory + readGlobal memVar + +-- | Given a bisimulation proof bundle and an empty initial state, +-- populate the global ring-buffer variables with abstract state +-- values, and write the abstract values of the external stream +-- values into their proper locations. +setupPrestate :: + IsSymBackend sym bak => + HasPtrWidth wptr => + HasLLVMAnn sym => + (?memOpts :: MemOptions) => + (?lc :: TypeContext) => + + bak -> + MemImpl sym -> + CW4.BisimulationProofBundle sym -> + IO (MemImpl sym) +setupPrestate bak mem0 prfbundle = + do mem' <- foldM setupStreamState mem0 (CW4.streamState (CW4.preStreamState prfbundle)) + foldM setupExternalInput mem' (CW4.externalInputs prfbundle) + + where + sym = backendGetSym bak + + sizeTStorage :: StorageType + sizeTStorage = bitvectorType (bitsToBytes (intValue ?ptrWidth)) + + setupExternalInput mem (nm, Some ctp, v) = + do -- Compute LLVM/Crucible type information from the Copilot type + let memTy = copilotTypeToMemTypeBool8 (llvmDataLayout ?lc) ctp + let typeAlign = memTypeAlign (llvmDataLayout ?lc) memTy + stType <- toStorableType memTy + Some typeRepr <- return (llvmTypeAsRepr memTy Some) + + -- resolve the global variable to a pointers + ptrVal <- doResolveGlobal bak mem (L.Symbol nm) + + -- write the value into the global + regVal <- copilotExprToRegValue sym v typeRepr + doStore bak mem ptrVal typeRepr stType typeAlign regVal + + setupStreamState mem (nm, Some ctp, vs) = + do -- TODO, should get these from somewhere inside copilot instead of building these names directly + let idxName = "s" ++ show nm ++ "_idx" + let bufName = "s" ++ show nm + let buflen = genericLength vs :: Integer + + -- Compute LLVM/Crucible type information from the Copilot type + let memTy = copilotTypeToMemTypeBool8 (llvmDataLayout ?lc) ctp + let typeLen = memTypeSize (llvmDataLayout ?lc) memTy + let typeAlign = memTypeAlign (llvmDataLayout ?lc) memTy + stType <- toStorableType memTy + Some typeRepr <- return (llvmTypeAsRepr memTy Some) + + -- Resolve the global names into base pointers + idxPtr <- doResolveGlobal bak mem (L.Symbol idxName) + bufPtr <- doResolveGlobal bak mem (L.Symbol bufName) + + -- Create a fresh index value in the proper range + idxVal <- freshBoundedBV sym (safeSymbol idxName) ?ptrWidth + (Just 0) (Just (fromIntegral (buflen - 1))) + idxVal' <- llvmPointer_bv sym idxVal + + -- store the index value in the correct location + let sizeTAlign = memTypeAlign (llvmDataLayout ?lc) (IntType (natValue ?ptrWidth)) + mem' <- doStore bak mem idxPtr (LLVMPointerRepr ?ptrWidth) sizeTStorage sizeTAlign idxVal' + + buflen' <- bvLit sym ?ptrWidth (BV.mkBV ?ptrWidth buflen) + typeLen' <- bvLit sym ?ptrWidth (BV.mkBV ?ptrWidth (toInteger typeLen)) + + -- Write each value of the stream ring buffer into its correct location + flip execStateT mem' $ + forM_ (zip vs [0 ..]) $ \(v,i) -> + do ptrVal <- lift $ + do x1 <- bvAdd sym idxVal =<< bvLit sym ?ptrWidth (BV.mkBV ?ptrWidth i) + x2 <- bvUrem sym x1 buflen' + x3 <- bvMul sym x2 typeLen' + ptrAdd sym ?ptrWidth bufPtr x3 + + regVal <- lift $ copilotExprToRegValue sym v typeRepr + StateT $ \m -> + do m' <- doStore bak m ptrVal typeRepr stType typeAlign regVal + return ((),m') + +-- | Given a memory image and a "proof state", assert that the global values +-- for each stream ring buffer have values that correspond to the given +-- stream state. This collection of assertions defines the bisimulation +-- relation. +assertStateRelation :: + IsSymBackend sym bak => + Log.Logs msgs => + HasPtrWidth wptr => + HasLLVMAnn sym => + (?memOpts :: MemOptions) => + (?lc :: TypeContext) => + bak -> + CopilotLogRefs sym -> + MemImpl sym -> + Log.StateRelationStep -> + CW4.BisimulationProofState sym -> + IO () +assertStateRelation bak clRefs mem stateRelStep prfst = + -- For each stream in the proof state, assert that the + -- generated ring buffer global contains the corresponding + -- values. + forM_ (CW4.streamState prfst) assertStreamState + + where + sym = backendGetSym bak + + sizeTStorage :: StorageType + sizeTStorage = bitvectorType (bitsToBytes (intValue ?ptrWidth)) + + assertStreamState (nm, Some ctp, vs) = + do -- TODO, should get these from somewhere inside copilot instead of building these names directly + let idxName = "s" ++ show nm ++ "_idx" + let bufName = "s" ++ show nm + let buflen = genericLength vs :: Integer + + -- Compute LLVM/Crucible type information from the Copilot type + let memTy = copilotTypeToMemTypeBool8 (llvmDataLayout ?lc) ctp + let typeLen = memTypeSize (llvmDataLayout ?lc) memTy + let typeAlign = memTypeAlign (llvmDataLayout ?lc) memTy + stType <- toStorableType memTy + Some typeRepr <- return (llvmTypeAsRepr memTy Some) + + -- Resolve the global names into base pointers + idxPtr <- doResolveGlobal bak mem (L.Symbol idxName) + bufPtr <- doResolveGlobal bak mem (L.Symbol bufName) + + -- read the value of the ring buffer index + let sizeTAlign = memTypeAlign (llvmDataLayout ?lc) (IntType (natValue ?ptrWidth)) + (bannIdxVal, pIdxVal, idxVal) <- + doLoadWithAnn bak mem idxPtr sizeTStorage (LLVMPointerRepr ?ptrWidth) sizeTAlign + idxVal' <- projectLLVM_bv bak idxVal + locIdxVal <- getCurrentProgramLoc sym + modifyIORef' (verifierAssertionMapRef clRefs) + $ Map.insert bannIdxVal + $ Log.RingBufferIndexLoadAssertion + $ Log.RingBufferIndexLoad sym stateRelStep locIdxVal (Text.pack idxName) pIdxVal + + buflen' <- bvLit sym ?ptrWidth (BV.mkBV ?ptrWidth buflen) + typeLen' <- bvLit sym ?ptrWidth (BV.mkBV ?ptrWidth (toInteger typeLen)) + + -- For each value in the stream description, read a corresponding value from + -- memory and assert that they are equal. + forM_ (zip vs [0 ..]) $ \(v,i) -> + do ptrVal <- + do x1 <- bvAdd sym idxVal' =<< bvLit sym ?ptrWidth (BV.mkBV ?ptrWidth i) + x2 <- bvUrem sym x1 buflen' + x3 <- bvMul sym x2 typeLen' + ptrAdd sym ?ptrWidth bufPtr x3 + + (bannv', pv', v') <- doLoadWithAnn bak mem ptrVal stType typeRepr typeAlign + locv' <- getCurrentProgramLoc sym + let bufNameT = Text.pack bufName + modifyIORef' (verifierAssertionMapRef clRefs) + $ Map.insert bannv' + $ Log.RingBufferLoadAssertion + $ Log.SomeSome + $ Log.RingBufferLoad sym stateRelStep locv' bufNameT i buflen ctp typeRepr pv' + eq <- computeEqualVals bak clRefs mem ctp v typeRepr v' + (ann, eq') <- annotateTerm sym eq + let shortmsg = "State equality condition: " ++ show nm ++ " index value " ++ show i + let longmsg = show (printSymExpr eq') + let rsn = AssertFailureSimError shortmsg longmsg + let loc = mkProgramLoc "<>" InternalPos + modifyIORef' (verifierAssertionMapRef clRefs) + $ Map.insert (BoolAnn ann) + $ Log.StreamValueEqualityAssertion + $ Log.SomeSome + $ Log.StreamValueEquality sym stateRelStep loc bufNameT i buflen ctp v typeRepr v' + addDurableProofObligation bak (LabeledPred eq' (SimError loc rsn)) + + return () + +-- | Translate the @XExpr@ values from the "Copilot.Theorem.What4" module into +-- Crucible @RegValue@s suitable for injection into the Crucible simulator. +copilotExprToRegValue :: forall sym tp. + IsSymInterface sym => + sym -> + CW4.XExpr sym -> + TypeRepr tp -> + IO (RegValue sym tp) +copilotExprToRegValue sym = loop + where + loop :: forall tp'. CW4.XExpr sym -> TypeRepr tp' -> IO (RegValue sym tp') + + loop (CW4.XBool b) (LLVMPointerRepr w) | Just Refl <- testEquality w (knownNat @1) = + llvmPointer_bv sym =<< predToBV sym b knownRepr + loop (CW4.XBool b) (LLVMPointerRepr w) | Just Refl <- testEquality w (knownNat @8) = + llvmPointer_bv sym =<< predToBV sym b knownRepr + loop (CW4.XInt8 x) (LLVMPointerRepr w) | Just Refl <- testEquality w (knownNat @8) = + llvmPointer_bv sym x + loop (CW4.XInt16 x) (LLVMPointerRepr w) | Just Refl <- testEquality w (knownNat @16) = + llvmPointer_bv sym x + loop (CW4.XInt32 x) (LLVMPointerRepr w) | Just Refl <- testEquality w (knownNat @32) = + llvmPointer_bv sym x + loop (CW4.XInt64 x) (LLVMPointerRepr w) | Just Refl <- testEquality w (knownNat @64) = + llvmPointer_bv sym x + loop (CW4.XWord8 x) (LLVMPointerRepr w) | Just Refl <- testEquality w (knownNat @8) = + llvmPointer_bv sym x + loop (CW4.XWord16 x) (LLVMPointerRepr w) | Just Refl <- testEquality w (knownNat @16) = + llvmPointer_bv sym x + loop (CW4.XWord32 x) (LLVMPointerRepr w) | Just Refl <- testEquality w (knownNat @32) = + llvmPointer_bv sym x + loop (CW4.XWord64 x) (LLVMPointerRepr w) | Just Refl <- testEquality w (knownNat @64) = + llvmPointer_bv sym x + + loop (CW4.XFloat x) (FloatRepr SingleFloatRepr) = return x + loop (CW4.XDouble x) (FloatRepr DoubleFloatRepr) = return x + + loop (CW4.XEmptyArray _ctp) (VectorRepr _tpr) = + pure V.empty + loop (CW4.XArray xs) (VectorRepr tpr) = + V.generateM (PVec.lengthInt xs) (\i -> loop (PVec.elemAtUnsafe i xs) tpr) + loop (CW4.XStruct xs) (StructRepr ctx) = + Ctx.traverseWithIndex + (\i tpr -> RV <$> loop (xs !! Ctx.indexVal i) tpr) + ctx + + loop x tpr = + fail $ unlines ["Mismatch between Copilot value and crucible value", show x, show tpr] + + +-- | Given an @XExpr@ from from the "Copilot.Theorem.What4" module, and +-- a Crucible @RegValue@ which is expected to match, compute an equality +-- predicate between the values. The Crucible values may be pointers, +-- requiring us to resolve the indirection through memory; this is necessary +-- for array and struct values, but would also work for scalars. +computeEqualVals :: forall sym bak tp a wptr. + IsSymBackend sym bak => + HasPtrWidth wptr => + HasLLVMAnn sym => + (?lc :: TypeContext) => + (?memOpts :: MemOptions) => + bak -> + CopilotLogRefs sym -> + MemImpl sym -> + Type a -> + CW4.XExpr sym -> + TypeRepr tp -> + RegValue sym tp -> + IO (Pred sym) +computeEqualVals bak clRefs mem = loop + where + sym = backendGetSym bak + + loop :: forall tp' a'. Type a' -> CW4.XExpr sym -> TypeRepr tp' -> RegValue sym tp' -> IO (Pred sym) + loop Bool (CW4.XBool b) (LLVMPointerRepr w) v | Just Refl <- testEquality w (knownNat @1) = + isEq sym b =<< bvIsNonzero sym =<< projectLLVM_bv bak v + loop Bool (CW4.XBool b) (LLVMPointerRepr w) v | Just Refl <- testEquality w (knownNat @8) = + isEq sym b =<< bvIsNonzero sym =<< projectLLVM_bv bak v + loop Int8 (CW4.XInt8 x) (LLVMPointerRepr w) v | Just Refl <- testEquality w (knownNat @8) = + bvEq sym x =<< projectLLVM_bv bak v + loop Int16 (CW4.XInt16 x) (LLVMPointerRepr w) v | Just Refl <- testEquality w (knownNat @16) = + bvEq sym x =<< projectLLVM_bv bak v + loop Int32 (CW4.XInt32 x) (LLVMPointerRepr w) v | Just Refl <- testEquality w (knownNat @32) = + bvEq sym x =<< projectLLVM_bv bak v + loop Int64 (CW4.XInt64 x) (LLVMPointerRepr w) v | Just Refl <- testEquality w (knownNat @64) = + bvEq sym x =<< projectLLVM_bv bak v + loop Word8 (CW4.XWord8 x) (LLVMPointerRepr w) v | Just Refl <- testEquality w (knownNat @8) = + bvEq sym x =<< projectLLVM_bv bak v + loop Word16 (CW4.XWord16 x) (LLVMPointerRepr w) v | Just Refl <- testEquality w (knownNat @16) = + bvEq sym x =<< projectLLVM_bv bak v + loop Word32 (CW4.XWord32 x) (LLVMPointerRepr w) v | Just Refl <- testEquality w (knownNat @32) = + bvEq sym x =<< projectLLVM_bv bak v + loop Word64 (CW4.XWord64 x) (LLVMPointerRepr w) v | Just Refl <- testEquality w (knownNat @64) = + bvEq sym x =<< projectLLVM_bv bak v + + loop Float (CW4.XFloat x) (FloatRepr SingleFloatRepr) v = iFloatEq @_ @SingleFloat sym x v + loop Double (CW4.XDouble x) (FloatRepr DoubleFloatRepr) v = iFloatEq @_ @DoubleFloat sym x v + + loop (Array _ctp) (CW4.XEmptyArray _ctp2) (VectorRepr _tpr) vs = + pure $ backendPred sym $ V.null vs + loop (Array ctp) (CW4.XArray xs) (VectorRepr tpr) vs + | PVec.lengthInt xs == V.length vs + = V.ifoldM (\pAcc i v -> andPred sym pAcc =<< loop ctp (PVec.elemAtUnsafe i xs) tpr v) + (truePred sym) vs + | otherwise + = pure (falsePred sym) + loop (Struct struct) (CW4.XStruct xs) (StructRepr ctx) vs + | length copilotVals == Ctx.sizeInt (Ctx.size vs) + = ifoldlMFC (\i pAcc tpr -> + case copilotVals !! Ctx.indexVal i of + (Value ctp _, x) -> + andPred sym pAcc =<< loop ctp x tpr (unRV (vs Ctx.! i))) + (truePred sym) ctx + | otherwise + = pure (falsePred sym) + where + copilotVals :: [(Value a', CW4.XExpr sym)] + copilotVals = zip (toValues struct) xs + + -- If we encounter a pointer, read the memory that it points to and recurse, + -- using the Copilot type as a guide for how much memory to read. This is + -- needed to make array- or struct-typed arguments work (see + -- Note [Arrays and structs]), although there is nothing about this code + -- that is array- or struct-specific. In fact, this code could also work + -- for pointer arguments of any other type. + loop ctp x PtrRepr v = + do let memTy = copilotTypeToMemTypeBool8 (llvmDataLayout ?lc) ctp + typeAlign = memTypeAlign (llvmDataLayout ?lc) memTy + stp <- toStorableType memTy + llvmTypeAsRepr memTy $ \tpr -> + do loc <- getCurrentProgramLoc sym + (bann, p, regVal) <- doLoadWithAnn bak mem v stp tpr typeAlign + modifyIORef' (verifierAssertionMapRef clRefs) + $ Map.insert bann + $ Log.PointerArgumentLoadAssertion + $ Log.SomeSome + $ Log.PointerArgumentLoad sym loc ctp tpr p + loop ctp x tpr regVal + + loop _ctp x tpr _v = + fail $ unlines ["Mismatch between Copilot value and crucible value", show x, show tpr] + +-- | Convert a Copilot 'CT.Type' to a Crucible 'MemType'. 'CT.Bool's are +-- assumed to be one bit in size. See @Note [How LLVM represents bool]@. +copilotTypeToMemType :: + DataLayout -> + CT.Type a -> + MemType +copilotTypeToMemType dl = loop + where + loop :: forall t. CT.Type t -> MemType + loop CT.Bool = i1 + loop CT.Int8 = i8 + loop CT.Int16 = i16 + loop CT.Int32 = i32 + loop CT.Int64 = i64 + loop CT.Word8 = i8 + loop CT.Word16 = i16 + loop CT.Word32 = i32 + loop CT.Word64 = i64 + loop CT.Float = FloatType + loop CT.Double = DoubleType + loop t0@(CT.Array tp) = + let len = fromIntegral (typeLength t0) in + ArrayType len (copilotTypeToMemTypeBool8 dl tp) + loop (CT.Struct v) = + StructType (mkStructInfo dl False (map val (CT.toValues v))) + + val :: forall t. CT.Value t -> MemType + val (CT.Value tp _) = copilotTypeToMemTypeBool8 dl tp + +-- | Like 'copilotTypeToMemType', except that 'CT.Bool's are assumed to be +-- eight bits, not one bit. See @Note [How LLVM represents bool]@. +copilotTypeToMemTypeBool8 :: + DataLayout -> + CT.Type a -> + MemType +copilotTypeToMemTypeBool8 _dl CT.Bool = i8 +copilotTypeToMemTypeBool8 dl tp = copilotTypeToMemType dl tp + +-- | Like 'copilotTypeToMemType', except that composite types (i.e., +-- 'CT.Array's and 'CT.Struct's) are converted to 'PtrType's instead of direct +-- 'ArrayType's or 'StructType's. See @Note [Arrays and structs]@. +copilotTypeToMemTypeCompositePtr :: + DataLayout -> + CT.Type a -> + MemType +copilotTypeToMemTypeCompositePtr dl (CT.Array tp) = + PtrType (MemType (copilotTypeToMemTypeBool8 dl tp)) +copilotTypeToMemTypeCompositePtr _dl (CT.Struct struct) = + PtrType (Alias (copilotStructIdent struct)) +copilotTypeToMemTypeCompositePtr dl tp = copilotTypeToMemType dl tp + +-- | Convert a Copilot 'CT.Type' to an LLVM 'L.Type'. 'CT.Bool's are +-- assumed to be one bit in size. See @Note [How LLVM represents bool]@. +copilotTypeToLLVMType :: + CT.Type a -> + L.Type +copilotTypeToLLVMType = loop + where + loop :: forall t. CT.Type t -> L.Type + loop CT.Bool = L.PrimType (L.Integer 1) + loop CT.Int8 = L.PrimType (L.Integer 8) + loop CT.Int16 = L.PrimType (L.Integer 16) + loop CT.Int32 = L.PrimType (L.Integer 32) + loop CT.Int64 = L.PrimType (L.Integer 64) + loop CT.Word8 = L.PrimType (L.Integer 8) + loop CT.Word16 = L.PrimType (L.Integer 16) + loop CT.Word32 = L.PrimType (L.Integer 32) + loop CT.Word64 = L.PrimType (L.Integer 64) + loop CT.Float = L.PrimType (L.FloatType L.Float) + loop CT.Double = L.PrimType (L.FloatType L.Double) + loop t0@(CT.Array tp) = + let len = fromIntegral (typeLength t0) in + L.Array len (copilotTypeToLLVMTypeBool8 tp) + loop (CT.Struct v) = + -- NB: Don't use L.Struct here. That represents a literal, unnamed + -- struct, but all of the structs used in a copilot-c99 program are + -- named structs. As such, we must identify the struct by its alias. + L.Alias (copilotStructIdent v) + +-- | Like 'copilotTypeToLLVMType', except that 'CT.Bool's are assumed to be +-- eight bits, not one bit. See @Note [How LLVM represents bool]@. +copilotTypeToLLVMTypeBool8 :: + CT.Type a -> + L.Type +copilotTypeToLLVMTypeBool8 CT.Bool = L.PrimType (L.Integer 8) +copilotTypeToLLVMTypeBool8 tp = copilotTypeToLLVMType tp + +-- | Like 'copilotTypeToLLVMType', except that composite types (i.e., +-- 'CT.Array's and 'CT.Struct's) are given special treatment involving +-- pointers. See @Note [Arrays and structs]@. +copilotTypeToLLVMTypeCompositePtr :: + CT.Type a -> + L.Type +copilotTypeToLLVMTypeCompositePtr (CT.Array tp) = + L.PtrTo (copilotTypeToLLVMTypeBool8 tp) +copilotTypeToLLVMTypeCompositePtr (CT.Struct struct) = + L.PtrTo (L.Alias (copilotStructIdent struct)) +copilotTypeToLLVMTypeCompositePtr tp = copilotTypeToLLVMType tp + +-- | Given a struct @s@, construct the name @struct.s@ as an LLVM identifier. +copilotStructIdent :: Struct a => a -> L.Ident +copilotStructIdent struct = L.Ident $ "struct." ++ typeName struct + +{- +Note [How LLVM represents bool] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +How are C values of type `bool` represented in LLVM? It depends. If it's being +stored directly a `bool`, it's represented with `i1` (i.e., a single bit). If +a `bool` is a member of some composite type, such as a pointer, array, or +struct, however, it's representing with `i8` (i.e., eight bits). This means +that we have to be careful when converting Bool-typed Copilot values, as they +can become `i1` or `i8` depending on the context. + +copilot-verifier handles this by having both `copilotTypeToLLVMType` and +`copilotTypeToLLVMTypeBool8` functions. The former function treats `bool`s as +`i1`, whereas the latter treats `bool`s as `i8`. The former is used when +converting "top-level" types (e.g., the argument types in a trigger override), +whereas the latter is used when converting types that are part of a larger +composite type (e.g., the element type in an array). + +The story for the `copilotTypeToMemType` and `copilotTypeToMemTypeBool8` +functions is similar. + +Note [Arrays and structs] +~~~~~~~~~~~~~~~~~~~~~~~~~ +When Clang compiles a function with an array argument, such as this trigger +function: + + void func(int32_t func_arg0[2]) { ... } + +It will produce the following LLVM code: + + declare void @func(i32*) { ... } + +Note that the argument is an i32*, not a [2 x i32]. As a result, we can't +translate Copilot array types directly to LLVM array types when they're used as +arguments to a function. This impedance mismatch is handled in two places: + +1. The `copilotTypeToMemTypeCompositePtr`/`copilotTypeToLLVMTypeCompositePtr` + functions special-case Copilot arrays such that they are translated to + pointers. These functions are used when declaring the argument types of an + override for a trigger function (see `triggerOverride`). +2. The `computeEqualVals` function has a special case for pointer + arguments—see the case that matches on `PtrRepr`. When a `PtrRepr` is + encountered, the underlying array values that it points to are read from + memory. Because `PtrRepr` doesn't record the type of the thing being pointed + to, `computeEqualVals` uses the corresponding Copilot type as a guide to + determine how much memory to read and at what type the memory should be + used. After this, `computeEqualVals` reads from the read array + element-by-element—see the `VectorRepr` cases. + + Note that unlike `computeEqualVals`, `copilotExprToRegValue` does not need + a `PtrRepr` case. This is because `copilotExprToRegValue` is ultimately used + in service of calling writing elements of streams to memory, and streams do + not store pointer values (at least, not in today's Copilot). + +There is a very similar story for structs. Copilot passes structs by reference +in trigger functions (e.g., `void trigger(struct s *ss)`), so we must also load +from a `PtrRepr` in `computeEqualVals` to handle structs. + +See Note [Global variables for trigger functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As part of verifying that the behavior of a Copilot specification's trigger +functions behave the same way as the trigger functions in the corresponding C +program, we check that each trigger function in the C program is invoked the +appropriate number of times. That is, if the guard condition for a trigger is +true, the C trigger function should be invoked exactly once, and if the guard +condition is false, then the trigger function should not be invoked at all. + +To check this, we create a Nat-valued global variable for each trigger function +and initialize it to zero. Whenever we simulate a trigger function, we increment +the value of the corresponding global variable. At the end of simulation, we +check that the value in each global variable is equal to +`if guard_cond then 1 else 0`. +-} + +-- | Like @crucible-llvm@'s @doLoad@, but with the following differences: +-- +-- * This function returns the 'BoolAnn' and 'Pred' asserting the validity of +-- the load, which the verifier needs for logging purposes. +-- +-- * This always generates a durable proof goal so that Crucible will always +-- record it, even if it is trivial. +doLoadWithAnn :: + ( IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym + , ?memOpts :: MemOptions ) => + bak -> + MemImpl sym -> + LLVMPtr sym wptr {- ^ pointer to load from -} -> + StorageType {- ^ type of value to load -} -> + TypeRepr tp {- ^ crucible type of the result -} -> + Alignment {- ^ assumed pointer alignment -} -> + IO (BoolAnn sym, Pred sym, RegValue sym tp) +doLoadWithAnn bak mem ptr valType tpr alignment = do + partLLVMVal <- loadRaw sym mem ptr valType alignment + (bann, p, llvmVal) <- assertSafeWithAnn bak partLLVMVal + regVal <- unpackMemValue sym tpr llvmVal + pure (bann, p, regVal) + where + sym = backendGetSym bak + +-- | Like @crucible-llvm@'s @assertSafe@, but with the following differences: +-- +-- * This function returns the 'BoolAnn' and 'Pred' corresponding to the +-- assertion, which the verifier needs for logging purposes. +-- +-- * This generates a durable assertion so that Crucible will always record it, +-- even if it is trivial. +assertSafeWithAnn :: + IsSymBackend sym bak => + bak -> + PartLLVMVal sym -> + IO (BoolAnn sym, Pred sym, LLVMVal sym) +assertSafeWithAnn bak partVal = do + loc <- getCurrentProgramLoc sym + let err = SimError loc rsn + case partVal of + NoErr p v -> do + (ann, p') <- annotateTerm sym p + addDurableAssertion bak (LabeledPred p' err) + return (BoolAnn ann, p', v) + Err p -> do + (_ann, p') <- annotateTerm sym p + addDurableProofObligation bak (LabeledPred p' err) + abortExecBecause (AssertionFailure err) + where + rsn = AssertFailureSimError "Error during memory load" "" + sym = backendGetSym bak + +-- | Given a simulator state, extract any collected proof obligations, +-- attempt to prove them, and present the results to the user. +-- +-- Afterward, the simulator state will be cleared of any proof obligations, +-- regardless of if they could all be proved. +proveObls :: + IsSymInterface sym => + sym ~ ExprBuilder t st fs => + Log.Logs msgs => + Log.SupportsCruxLogMessage msgs => + Log.SupportsCopilotLogMessage msgs => + CruxOptions -> + [SolverAdapter st] -> + CopilotLogRefs sym -> + Log.VerificationStep -> + SimCtxt Crux sym LLVM -> + IO Integer +proveObls cruxOpts adapters clRefs step simctx = + withBackend simctx $ \bak -> + do let sym = backendGetSym bak + obls <- getProofObligations bak + clearProofObligations bak + +-- mapM_ (print . ppSimError) (summarizeObls sym obls) + + vaMap <- readIORef $ verifierAssertionMapRef clRefs + let laMapRef = llvmAnnMapRef clRefs + laMap <- readIORef laMapRef + results <- proveGoalsOffline adapters cruxOpts simctx (explainFailure sym laMapRef) obls + presentResults sym vaMap laMap step results + +{- +summarizeObls :: sym -> ProofObligations sym -> [SimError] +summarizeObls _ Nothing = [] +summarizeObls _ (Just obls) = map (view labeledPredMsg . proofGoal) (goalsToList obls) +-} + +-- | Compute the number of goals that were proven during verification, logging +-- the goals as they are proven. If all goals are proven successfully, return +-- the number of goals. Otherwise, log the failing proof goals and abort. +presentResults :: + Log.Logs msgs => + Log.SupportsCopilotLogMessage msgs => + IsSymInterface sym => + sym -> + Map.Map (BoolAnn sym) (Log.VerifierAssertion sym) -> + LLVMAnnMap sym -> + Log.VerificationStep -> + (ProcessedGoals, Maybe (Goals (Assumptions sym) (Assertion sym, [ProgramLoc], ProofResult sym))) -> + IO Integer +presentResults sym vaMap laMap step (num, goals) + | numTotalGoals == 0 + = do Log.sayCopilot Log.AllGoalsProved + pure 0 + + -- All goals were proven + | numProvedGoals == numTotalGoals + = do traverse_ (logVerifierAssertions sym vaMap laMap step num) goals + printGoals + pure numProvedGoals + + -- There were some unproved goals, so fail with exit code 1 + | otherwise + = do printGoals + exitFailure + where + numTotalGoals = totalProcessedGoals num + numProvedGoals = provedGoals num + + printGoals = + do Log.sayCopilot $ Log.OnlySomeGoalsProved numProvedGoals numTotalGoals + goals' <- provedGoalsTree sym goals + case goals' of + Just g -> Log.logGoal g + Nothing -> return () + +-- | Upon a successful verification, log the various assertions that the +-- verifier makes. These assertions will be visible in the output if the +-- 'verbosity' is set to 'Noisy'. +logVerifierAssertions :: + forall sym msgs. + IsSymInterface sym => + Log.Logs msgs => + Log.SupportsCopilotLogMessage msgs => + sym -> + Map.Map (BoolAnn sym) (Log.VerifierAssertion sym) -> + LLVMAnnMap sym -> + Log.VerificationStep -> + ProcessedGoals -> + Goals (Assumptions sym) (Assertion sym, [ProgramLoc], ProofResult sym) -> + IO () +logVerifierAssertions sym vaMap laMap step num goals = void $ go 0 goals + where + numTotalGoals = totalProcessedGoals num + + go :: Integer -> + Goals (Assumptions sym) (Assertion sym, [ProgramLoc], ProofResult sym) -> + IO Integer + go goalIdx gs = + case gs of + Assuming _ gs' -> + go goalIdx gs' + + Prove (gl, locs, _) -> do + let p = gl^.labeledPred + nearestLoc = nearestProgramLoc locs + + -- First, obtain the verifier assertion. + va <- case getAnnotation sym p of + -- If the assertion has a BoolAnn, look it up in the assertion maps + -- that we have accumulated during verification. + Just ann + | Just va <- Map.lookup (BoolAnn ann) vaMap + -> pure va + | Just (stk, bb) <- Map.lookup (BoolAnn ann) laMap + -> pure $ Log.LLVMBadBehaviorCheckAssertion + $ Log.LLVMBadBehaviorCheck sym nearestLoc stk bb p + | otherwise + -> fail $ unlines + [ "Cannot find BoolAnn for assertion" + , show $ gl^.labeledPredMsg + , show $ printSymExpr p + ] + -- If the assertion does not have a BoolAnn, fall back to using + -- heuristics to guess what kind of assertion it is. + Nothing -> pure $ verifierAssertionHeuristics sym nearestLoc p + + -- Log the assertion. + case va of + Log.StreamValueEqualityAssertion (Log.SomeSome a) -> + Log.sayCopilot $ + Log.StreamValueEqualityProofGoal step goalIdx numTotalGoals a + Log.TriggersInvokedCorrespondinglyAssertion a -> + Log.sayCopilot $ + Log.TriggersInvokedCorrespondinglyProofGoal step goalIdx numTotalGoals a + Log.TriggerArgumentEqualityAssertion (Log.SomeSome a) -> + Log.sayCopilot $ + Log.TriggerArgumentEqualityProofGoal step goalIdx numTotalGoals a + Log.RingBufferLoadAssertion (Log.SomeSome a) -> + Log.sayCopilot $ + Log.RingBufferLoadProofGoal step goalIdx numTotalGoals a + Log.RingBufferIndexLoadAssertion a -> + Log.sayCopilot $ + Log.RingBufferIndexLoadProofGoal step goalIdx numTotalGoals a + Log.PointerArgumentLoadAssertion (Log.SomeSome a) -> + Log.sayCopilot $ + Log.PointerArgumentLoadProofGoal step goalIdx numTotalGoals a + Log.AccessorFunctionLoadAssertion a -> + Log.sayCopilot $ + Log.AccessorFunctionLoadProofGoal step goalIdx numTotalGoals a + Log.GuardFunctionLoadAssertion a -> + Log.sayCopilot $ + Log.GuardFunctionLoadProofGoal step goalIdx numTotalGoals a + Log.UnknownFunctionLoadAssertion a -> + Log.sayCopilot $ + Log.UnknownFunctionLoadProofGoal step goalIdx numTotalGoals a + Log.LLVMBadBehaviorCheckAssertion a -> + Log.sayCopilot $ + Log.LLVMBadBehaviorCheckProofGoal step goalIdx numTotalGoals a + + -- Finally, return the current goal index. + pure goalIdx + + ProveConj gs1 gs2 -> do + goalIdx' <- go goalIdx gs1 + go (goalIdx' + 1) gs2 + +-- | If a verifier assertion does not have a corresponding 'BoolAnn', then we +-- must use heuristics to guess what kind of assertion it is. These heuristics +-- are not perfect, and we fall back to 'Log.UnknownFunctionLoad' in the event +-- that we cannot figure out a more obvious cause for the assertion. +verifierAssertionHeuristics :: + IsSymInterface sym => + sym -> + ProgramLoc -> + Pred sym -> + Log.VerifierAssertion sym +verifierAssertionHeuristics sym loc p + | "_get" `Text.isSuffixOf` functionName funName + = Log.AccessorFunctionLoadAssertion $ + Log.AccessorFunctionLoad sym loc funName p + + | "_guard" `Text.isSuffixOf` functionName funName + = Log.GuardFunctionLoadAssertion $ + Log.GuardFunctionLoad sym loc funName p + + | otherwise + = Log.UnknownFunctionLoadAssertion $ + Log.UnknownFunctionLoad sym loc funName p + where + funName = plFunction loc + +-- | Pick the most recent 'ProgramLoc' in a trace of locations. If there are +-- no locations available, return a dummy location. +nearestProgramLoc :: [ProgramLoc] -> ProgramLoc +nearestProgramLoc locs = + case locs of + loc:_ -> loc + _ -> mkProgramLoc "<>" InternalPos + +-- | A collection of 'IORef's used to accumulate log messages that the verifier +-- may display at the end of verification. +data CopilotLogRefs sym = CopilotLogRefs + { verifierAssertionMapRef :: !(IORef (Map.Map (BoolAnn sym) (Log.VerifierAssertion sym))) + -- ^ A map of 'BoolAnn's (i.e., unique numbers) to 'Log.VerifierAssertions'. + , llvmAnnMapRef :: !(IORef (LLVMAnnMap sym)) + -- ^ A map of 'BoolAnn's (i.e., unique numbers) to assertions about checks + -- for bad behavior in LLVM. + + -- This is kept in a separate 'IORef' for technical reasons, as + -- @crucible-llvm@'s 'explainFailure' function expects this 'IORef' as an + -- argument. We could put everything into 'verifierAssertionMapRef', but + -- that would require some tiresome 'IORef' massaging to make work. + } + +-- | Create a new 'CopilotLogRefs' value. +newCopilotLogRefs :: IsSymInterface sym => IO (CopilotLogRefs sym) +newCopilotLogRefs = do + vaMapRef <- newIORef mempty + laMapRef <- newIORef mempty + pure $ CopilotLogRefs + { verifierAssertionMapRef = vaMapRef + , llvmAnnMapRef = laMapRef + } + +data CopilotLogging + = LoggingCrux Log.CruxLogMessage + | LoggingCruxLLVM Log.CruxLLVMLogMessage + | LoggingCopilot Log.CopilotLogMessage + deriving stock Generic + deriving anyclass ToJSON + +copilotLoggingToSayWhat :: CopilotLogging -> Log.SayWhat +copilotLoggingToSayWhat (LoggingCrux msg) = Log.cruxLogMessageToSayWhat msg +copilotLoggingToSayWhat (LoggingCruxLLVM msg) = Log.cruxLLVMLogMessageToSayWhat msg +copilotLoggingToSayWhat (LoggingCopilot msg) = Log.copilotLogMessageToSayWhat msg + +withCopilotLogging :: + ( ( Log.SupportsCruxLogMessage CopilotLogging + , Log.SupportsCruxLLVMLogMessage CopilotLogging + , Log.SupportsCopilotLogMessage CopilotLogging + ) => computation ) -> + computation +withCopilotLogging computation = do + let ?injectCruxLogMessage = LoggingCrux + ?injectCruxLLVMLogMessage = LoggingCruxLLVM + ?injectCopilotLogMessage = LoggingCopilot + in computation + +sayTranslationWarning :: + Log.Logs msgs => + Log.SupportsCruxLLVMLogMessage msgs => + LLVMTranslationWarning -> IO () +sayTranslationWarning = Log.sayCruxLLVM . f + where + f (LLVMTranslationWarning s p msg) = + Log.TranslationWarning (Text.pack (show (ppSymbol s))) (Text.pack (show p)) msg diff --git a/copilot-verifier/src/Copilot/Verifier/FloatMode.hs b/copilot-verifier/src/Copilot/Verifier/FloatMode.hs new file mode 100644 index 000000000..7d2f62786 --- /dev/null +++ b/copilot-verifier/src/Copilot/Verifier/FloatMode.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} + +module Copilot.Verifier.FloatMode + ( FloatMode(..) + , withFloatMode + , withInterpretedFloatExprBuilder + ) where + +import qualified What4.Expr.Builder as W4 +import qualified What4.InterpretedFloatingPoint as W4 + +-- | How the verifier should interpret floating-point operations. +data FloatMode + = -- | Floating-point values are treated as bitvectors of the appropriate + -- width, and all operations on them are translated as uninterpreted + -- functions. This is the verifier's default interpretation, and it is what + -- allows the verifier to perform any reasoning at all over floating-point + -- operations that are not native to SMT-LIB (@sin@, @cos@, @tan@, etc.). + FloatUninterpreted + + | -- | Floating-point values are treated as bit-precise IEEE-754 floats. This + -- interpretation can perform deeper reasoning about floating-point + -- operations that are native to SMT-LIB, but at the expense of causing the + -- verifier to throw an error if it encounters operations that are not + -- native to SMT-LIB (@sin@, @cos@, @tan@, etc.). Use at your own risk. + FloatIEEE + deriving Show + +-- | Convert a 'FloatMode' into a What4 'W4.FloatModeRepr' and pass it to a +-- continuation. +withFloatMode :: + FloatMode -> + (forall fm. W4.FloatModeRepr fm -> r) -> + r +withFloatMode fm k = + case fm of + FloatUninterpreted -> + k W4.FloatUninterpretedRepr + FloatIEEE -> + k W4.FloatIEEERepr + +-- | Match on a 'W4.FloatModeRepr', compute evidence that it gives rise to an +-- instance of 'W4.IsInterpretedFloatExprBuilder', and pass the evidence to a +-- continutation. +withInterpretedFloatExprBuilder :: + W4.ExprBuilder t st (W4.Flags fm) -> + W4.FloatModeRepr fm -> + (W4.IsInterpretedFloatExprBuilder (W4.ExprBuilder t st (W4.Flags fm)) => r) -> + r +withInterpretedFloatExprBuilder _sym fm k = + case fm of + W4.FloatUninterpretedRepr -> k + W4.FloatIEEERepr -> k + W4.FloatRealRepr -> k diff --git a/copilot-verifier/src/Copilot/Verifier/Log.hs b/copilot-verifier/src/Copilot/Verifier/Log.hs new file mode 100644 index 000000000..0f34711a7 --- /dev/null +++ b/copilot-verifier/src/Copilot/Verifier/Log.hs @@ -0,0 +1,834 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TemplateHaskell #-} +module Copilot.Verifier.Log + ( SupportsCopilotLogMessage + , CopilotLogMessage(..) + , VerificationStep(..) + , StateRelationStep(..) + , VerifierAssertion(..) + , SomeSome(..) + , StreamValueEquality(..) + , TriggersInvokedCorrespondingly(..) + , TriggerArgumentEquality(..) + , RingBufferLoad(..) + , RingBufferIndexLoad(..) + , PointerArgumentLoad(..) + , AccessorFunctionLoad(..) + , GuardFunctionLoad(..) + , UnknownFunctionLoad(..) + , LLVMBadBehaviorCheck(..) + , sayCopilot + , copilotLogMessageToSayWhat + ) where + +import Crux (SayLevel (..), SayWhat (..)) +import qualified Crux.Log as Log +import Data.Aeson (ToJSON (..), Value (..)) +import Data.Aeson.TH (defaultOptions, deriveToJSON) +import Data.Kind (Type) +import qualified Data.Parameterized.Context as Ctx +import qualified Data.Parameterized.Vector as PV +import qualified Data.Parameterized.TraversableFC.WithIndex as PWI +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Vector as V +import GHC.Generics (Generic) +import qualified Prettyprinter as PP +import qualified Prettyprinter.Render.Text as PP + +import qualified Copilot.Core.Expr as CE +import qualified Copilot.Core.Type as CT +import qualified Copilot.Theorem.What4 as CW4 + +import qualified Lang.Crucible.Simulator as LCS +import qualified Lang.Crucible.Types as LCT +import qualified Lang.Crucible.LLVM.Errors as LCLE +import qualified Lang.Crucible.LLVM.Errors.MemoryError as LCLEME +import qualified Lang.Crucible.LLVM.Errors.UndefinedBehavior as LCLEUB +import qualified Lang.Crucible.LLVM.MemModel as LCLM +import qualified Lang.Crucible.LLVM.MemModel.CallStack as LCLMCS +import qualified What4.FunctionName as WF +import qualified What4.Interface as WI +import qualified What4.ProgramLoc as WPL + +data CopilotLogMessage where + GeneratedCFile :: + FilePath + -- ^ The path of the generated C File + -> CopilotLogMessage + CompiledBitcodeFile :: + String + -- ^ The prefix to use in the compiled bitcode's directory + -> FilePath + -- ^ The name of the generated LLVM bitcode file + -> CopilotLogMessage + TranslatedToCrucible :: CopilotLogMessage + GeneratingProofState :: CopilotLogMessage + ComputingConditions :: VerificationStep -> CopilotLogMessage + ProvingConditions :: VerificationStep -> CopilotLogMessage + AllGoalsProved :: CopilotLogMessage + OnlySomeGoalsProved :: + Integer + -- ^ Number of goals proved + -> Integer + -- ^ Number of total goals + -> CopilotLogMessage + SuccessfulProofSummary :: + FilePath + -- ^ Name of the generated C file. + -> Integer + -- ^ Number of goals proven during for the initial state of the proof. + -> Integer + -- ^ Number of goals proven during the bisimulation step of the proof. + -> CopilotLogMessage + NoisyVerbositySuggestion :: CopilotLogMessage + + ----- + -- Types of proof goals the verifier emits + -- + -- The first three arguments to each constructor are: + -- + -- * Which step of the verifier we are on + -- * The current goal number (zero-indexed) + -- * The total number of goals + ----- + + StreamValueEqualityProofGoal :: + WI.IsSymExprBuilder sym + => VerificationStep + -> Integer + -> Integer + -> StreamValueEquality sym copilotType crucibleType + -> CopilotLogMessage + + TriggersInvokedCorrespondinglyProofGoal :: + WI.IsSymExprBuilder sym + => VerificationStep + -> Integer + -> Integer + -> TriggersInvokedCorrespondingly sym + -> CopilotLogMessage + + TriggerArgumentEqualityProofGoal :: + WI.IsSymExprBuilder sym + => VerificationStep + -> Integer + -> Integer + -> TriggerArgumentEquality sym copilotType crucibleType + -> CopilotLogMessage + + RingBufferLoadProofGoal :: + WI.IsSymExprBuilder sym + => VerificationStep + -> Integer + -> Integer + -> RingBufferLoad sym copilotType crucibleType + -> CopilotLogMessage + + RingBufferIndexLoadProofGoal :: + WI.IsSymExprBuilder sym + => VerificationStep + -> Integer + -> Integer + -> RingBufferIndexLoad sym + -> CopilotLogMessage + + PointerArgumentLoadProofGoal :: + WI.IsSymExprBuilder sym + => VerificationStep + -> Integer + -> Integer + -> PointerArgumentLoad sym copilotType crucibleType + -> CopilotLogMessage + + AccessorFunctionLoadProofGoal :: + WI.IsSymExprBuilder sym + => VerificationStep + -> Integer + -> Integer + -> AccessorFunctionLoad sym + -> CopilotLogMessage + + GuardFunctionLoadProofGoal :: + WI.IsSymExprBuilder sym + => VerificationStep + -> Integer + -> Integer + -> GuardFunctionLoad sym + -> CopilotLogMessage + + UnknownFunctionLoadProofGoal :: + WI.IsSymExprBuilder sym + => VerificationStep + -> Integer + -> Integer + -> UnknownFunctionLoad sym + -> CopilotLogMessage + + LLVMBadBehaviorCheckProofGoal :: + WI.IsSymExprBuilder sym + => VerificationStep + -> Integer + -> Integer + -> LLVMBadBehaviorCheck sym + -> CopilotLogMessage + +data VerificationStep + = InitialState + | StepBisimulation + deriving stock Generic + deriving anyclass ToJSON + +-- | The provenance of an assertion. +data AssertionProvenance + = VerifierProvenance + -- ^ Assertions that the verifier directly makes to check the correspondence + -- between the Copilot specification and the generated C code. Because these + -- assertions are core to the proof that the verifier is computing, these + -- assertions' proof goals are always logged, even if they are trivial. + | StepExecutionProvenance + -- ^ Assertions that arise during symbolic execution of the @step()@ + -- function as part of proving the memory safety of the generated C code. + -- These assertions' proof goals are only logged if they are non-trivial, + -- as there would be an excessive number of these proof goals otherwise. + +-- | At what step of the proof are we checking the state relation? We record +-- this so that we can better distinguish between transition step–related +-- proof goals that arise before or after calling the @step()@ function. +data StateRelationStep + = InitialStateRelation + -- ^ Check the state relation for the initial state. + | PreStepStateRelation + -- ^ During the transition step of the proof, check the state relation + -- before calling the @step()@ function. + | PostStepStateRelation + -- ^ During the transition step of the proof, check the state relation + -- after calling the @step()@ function. + deriving stock Generic + deriving anyclass ToJSON + +-- | Types of assertions that the verifier can make, which will count towards +-- the total number of proof goals. +data VerifierAssertion sym + = StreamValueEqualityAssertion (SomeSome (StreamValueEquality sym)) + | TriggersInvokedCorrespondinglyAssertion (TriggersInvokedCorrespondingly sym) + | TriggerArgumentEqualityAssertion (SomeSome (TriggerArgumentEquality sym)) + | RingBufferLoadAssertion (SomeSome (RingBufferLoad sym)) + | RingBufferIndexLoadAssertion (RingBufferIndexLoad sym) + | PointerArgumentLoadAssertion (SomeSome (PointerArgumentLoad sym)) + | AccessorFunctionLoadAssertion (AccessorFunctionLoad sym) + | GuardFunctionLoadAssertion (GuardFunctionLoad sym) + | UnknownFunctionLoadAssertion (UnknownFunctionLoad sym) + | LLVMBadBehaviorCheckAssertion (LLVMBadBehaviorCheck sym) + +-- | Like @Some@ in @parameterized-utils@, but existentially closing over two +-- type parameters instead of just one. +data SomeSome (f :: j -> k -> Type) where + SomeSome :: f x y -> SomeSome f + +-- | An assertion that an element in a Copilot stream is equal to the +-- corresponding element in a C ring buffer. +data StreamValueEquality sym copilotType crucibleType where + StreamValueEquality :: + sym + -> StateRelationStep + -- ^ When the values are checked for equality + -> WPL.ProgramLoc + -- ^ The locations of the values + -> Text + -- ^ The name of the buffer + -> Integer + -- ^ The offset from the buffer's index, which is used to compute the + -- element of the buffer to load + -> Integer + -- ^ The number of elements in the buffer + -> CT.Type copilotType + -- ^ The Copilot type + -> CW4.XExpr sym + -- ^ The Copilot value + -> LCT.TypeRepr crucibleType + -- ^ The Crucible type + -> LCS.RegValue sym crucibleType + -- ^ The Crucible value + -> StreamValueEquality sym copilotType crucibleType + +-- | An assertion that, given a Copilot trigger stream and its corresponding C +-- trigger function on a particular time step, either both fired at the same +-- time or both did not fire at all. +data TriggersInvokedCorrespondingly sym where + TriggersInvokedCorrespondingly :: + WPL.ProgramLoc + -- ^ The location of the trigger + -> CE.Name + -- ^ The trigger name + -> WI.SymNat sym + -- ^ The expected number of times the trigger was fired this step + -- (should be either 1 or 0). + -> WI.SymNat sym + -- ^ The actual number of times the trigger was fired this step. + -> TriggersInvokedCorrespondingly sym + +-- | An assertion that an argument to a Copilot trigger is equal to the +-- corresponding argument to a C trigger function. +data TriggerArgumentEquality sym copilotType crucibleType where + TriggerArgumentEquality :: + sym + -> WPL.ProgramLoc + -- ^ The locations of the arguments + -> CE.Name + -- ^ The trigger name + -> Integer + -- ^ The number of the argument (starting from 0) + -> CT.Type copilotType + -- ^ The Copilot type + -> CW4.XExpr sym + -- ^ The Copilot value + -> LCT.TypeRepr crucibleType + -- ^ The Crucible type + -> LCS.RegValue sym crucibleType + -- ^ The Crucible value + -> TriggerArgumentEquality sym copilotType crucibleType + +-- | An assertion that a load from a ring buffer in C is valid. +data RingBufferLoad sym copilotType crucibleType where + RingBufferLoad :: + sym + -> StateRelationStep + -- ^ When the ring buffer is loaded from + -> WPL.ProgramLoc + -- ^ The location of the buffer + -> Text + -- ^ The name of the buffer + -> Integer + -- ^ The offset from the buffer's index, which is used to compute the + -- element of the buffer to load + -> Integer + -- ^ The number of elements in the buffer + -> CT.Type copilotType + -- ^ The Copilot type of the elements of the array + -> LCT.TypeRepr crucibleType + -- ^ The Crucible type of the elements of the array + -> WI.Pred sym + -- ^ The assertion that must hold in order for this load to be valid + -> RingBufferLoad sym copilotType crucibleType + +-- | An assertion that a load from a global variable representing a ring +-- buffer's index in C is valid. +data RingBufferIndexLoad sym where + RingBufferIndexLoad :: + sym + -> StateRelationStep + -- ^ When the index's global variable is loaded from + -> WPL.ProgramLoc + -- ^ The location of the global index + -> Text + -- ^ The name of the global index + -> WI.Pred sym + -- ^ The assertion that must hold in order for this load to be valid + -> RingBufferIndexLoad sym + +-- | An assertion that a load from a pointer argument to a trigger function in C +-- is valid. +data PointerArgumentLoad sym copilotType crucibleType where + PointerArgumentLoad :: + sym + -> WPL.ProgramLoc + -- ^ The location of the pointer + -> CT.Type copilotType + -- ^ The Copilot type of the underlying memory + -> LCT.TypeRepr crucibleType + -- ^ The Crucible type of the underlying memory + -> WI.Pred sym + -- ^ The assertion that must hold in order for this load to be valid + -> PointerArgumentLoad sym copilotType crucibleType + +-- | An assertion that a load occurring from somewhere in a stream accessor +-- function in C (e.g., @s0_get@) is valid. This is a somewhat imprecise +-- assertion, as it doesn't identify /why/ the load occurs. (Most likely, it +-- happens because of an array index.) +data AccessorFunctionLoad sym where + AccessorFunctionLoad :: + sym + -> WPL.ProgramLoc + -- ^ The location of the accessor function + -> WF.FunctionName + -- ^ The name of the accessor function + -> WI.Pred sym + -- ^ The assertion that must hold in order for this load to be valid + -> AccessorFunctionLoad sym + +-- | An assertion that a load occurring from somewhere in a trigger guard +-- function in C (e.g., @even_guard@) is valid. This is a somewhat imprecise +-- assertion, as it doesn't identify /why/ the load occurs. (Most likely, it +-- happens because of an array index.) +data GuardFunctionLoad sym where + GuardFunctionLoad :: + sym + -> WPL.ProgramLoc + -- ^ The location of the guard function + -> WF.FunctionName + -- ^ The name of the guard function + -> WI.Pred sym + -- ^ The assertion that must hold in order for this load to be valid + -> GuardFunctionLoad sym + +-- | An assertion that a load occurring in some function is valid. If you +-- see this assertion, it is because the heuristics used to identify where +-- load-related assertions come from could not identify a more precise cause +-- for a load. +data UnknownFunctionLoad sym where + UnknownFunctionLoad :: + sym + -> WPL.ProgramLoc + -- ^ The location of the function + -> WF.FunctionName + -- ^ The name of the function + -> WI.Pred sym + -- ^ The assertion that must hold in order for this load to be valid + -> UnknownFunctionLoad sym + +-- | An assertion that checks that some form of bad behavior in LLVM does not +-- occur. Bad behavior includes both undefined behavior and memory unsafety. +data LLVMBadBehaviorCheck sym where + LLVMBadBehaviorCheck :: + sym + -> WPL.ProgramLoc + -- ^ The location of the check + -> LCLMCS.CallStack + -- ^ A call stack for the check, if one exists + -> LCLE.BadBehavior sym + -- ^ What type of LLVM bad behavior is being checked for + -> WI.Pred sym + -- ^ The assertion that must hold in order for this check to succeed + -> LLVMBadBehaviorCheck sym + +-- Silly ToJSON instances. Crux is only requiring a ToJSON constraint for +-- IDE-related functionality that we do not make use of, so the behavior of +-- these instances aren't very important. + +instance ToJSON (StreamValueEquality sym copilotType crucibleType) where + toJSON _ = String "StreamValueEquality" + +instance ToJSON (TriggersInvokedCorrespondingly sym) where + toJSON _ = String "TriggersInvokedCorrespondingly" + +instance ToJSON (TriggerArgumentEquality sym copilotType crucibleType) where + toJSON _ = String "TriggerArgumentEquality" + +instance ToJSON (RingBufferLoad sym copilotType crucibleType) where + toJSON _ = String "RingBufferLoad" + +instance ToJSON (RingBufferIndexLoad sym) where + toJSON _ = String "RingBufferIndexLoad" + +instance ToJSON (PointerArgumentLoad sym copilotType crucibleType) where + toJSON _ = String "PointerArgumentLoad" + +instance ToJSON (AccessorFunctionLoad sym) where + toJSON _ = String "AccessorFunctionLoad" + +instance ToJSON (GuardFunctionLoad sym) where + toJSON _ = String "GuardFunctionLoad" + +instance ToJSON (UnknownFunctionLoad sym) where + toJSON _ = String "UnknownFunctionLoad" + +instance ToJSON (LLVMBadBehaviorCheck sym) where + toJSON _ = String "LLVMBadBehaviorCheck" + +type SupportsCopilotLogMessage msgs = + (?injectCopilotLogMessage :: CopilotLogMessage -> msgs) + +sayCopilot :: + Log.Logs msgs => + SupportsCopilotLogMessage msgs => + CopilotLogMessage -> + IO () +sayCopilot msg = + let ?injectMessage = ?injectCopilotLogMessage + in Log.say msg + +copilotTag :: Text +copilotTag = "copilot-verifier" + +-- copilotFail :: Text -> SayWhat +-- copilotFail = SayWhat Fail copilotTag + +copilotSimply :: Text -> SayWhat +copilotSimply = SayWhat Simply copilotTag + +copilotNoisily :: Text -> SayWhat +copilotNoisily = SayWhat Noisily copilotTag + +-- copilotWarn :: Text -> SayWhat +-- copilotWarn = SayWhat Warn copilotTag + +copilotLogMessageToSayWhat :: CopilotLogMessage -> SayWhat +copilotLogMessageToSayWhat (GeneratedCFile csrc) = + copilotSimply $ "Generated " <> T.pack (show csrc) +copilotLogMessageToSayWhat (CompiledBitcodeFile prefix bcFile) = + copilotSimply $ "Compiled " <> T.pack prefix <> " into " <> T.pack bcFile +copilotLogMessageToSayWhat TranslatedToCrucible = + copilotSimply "Translated bitcode into Crucible" +copilotLogMessageToSayWhat GeneratingProofState = + copilotSimply "Generating proof state data" +copilotLogMessageToSayWhat (ComputingConditions step) = + copilotSimply $ "Computing " <> describeVerificationStep step <> " verification conditions" +copilotLogMessageToSayWhat (ProvingConditions step) = + copilotSimply $ "Proving " <> describeVerificationStep step <> " verification conditions" +copilotLogMessageToSayWhat AllGoalsProved = + copilotSimply "All obligations proved by concrete simplification" +copilotLogMessageToSayWhat (OnlySomeGoalsProved numProvedGoals numTotalGoals) = + copilotSimply $ T.unwords + [ "Proved", T.pack (show numProvedGoals) + , "of" + , T.pack (show numTotalGoals), "total goals" + ] +copilotLogMessageToSayWhat (SuccessfulProofSummary cFileName initGoals bisimGoals) = + copilotSimply $ T.unlines + [ "" + , "copilot-verifier has produced a mathematical proof that the behavior of" + , "the generated C program (" <> T.pack cFileName + <> ") precisely matches the behavior of" + , "the Copilot specification. This proof shows that the behaviors match for" + , "all possible moments in time, and in doing so, copilot-verifier examined" + , "how the programs behave at the start of execution (the \"initial state\")" + , "and at an arbitrary point of time in execution (the \"step bisimulation\")." + , "copilot-verifier decomposed the overall proof into smaller goals, the" + , "number of which depends on the size and complexity of the program. In this" + , "example, there are " <> T.pack (show initGoals) <> " initial state goal(s)" + <> " and " <> T.pack (show bisimGoals) <> " step bisimulation goal(s)," + , "and copilot-verifier was able to prove all of them." + ] +copilotLogMessageToSayWhat NoisyVerbositySuggestion = + copilotSimply $ T.unlines + [ "" + , "copilot-verifier is displaying an abridged summary of the verification results." + , "copilot-verifier also includes a \"noisy\" mode that prints detailed" + , "descriptions of each individual proof goal, including what type of goal it is," + , "why it needs to be proven, and where in the Copilot specification and/or C code" + , "the proof goal originated from. To enable noisy mode, invoke the verifier with" + , "the following options:" + , "" + , "```" + , "verifyWithOptions (defaultVerifierOptions { verbosity = Noisy }) ..." + , "```" + ] +copilotLogMessageToSayWhat + (StreamValueEqualityProofGoal verifStep goalIdx numTotalGoals + (StreamValueEquality + sym stateRelStep loc + bufName offset len + copilotTy copilotVal + crucibleTy crucibleVal)) = + copilotNoisily $ + displayStateRelationProofGoal + verifStep stateRelStep VerifierProvenance goalIdx numTotalGoals + "asserting the equality between two stream values" + [ renderStrict $ ppProgramLoc loc + , "* Ring buffer name: " <> bufName + , "* Offset into buffer (from current index): " <> T.pack (show offset) + , "* Number of elements in buffer: " <> T.pack (show len) + , "* Copilot type: " <> T.pack (showsCopilotType 0 copilotTy "") + , "* Copilot value:" + , renderStrict $ PP.indent 4 $ ppCopilotValue copilotVal + , "* Crucible value:" + , renderStrict $ PP.indent 4 $ ppCrucibleValue sym crucibleTy crucibleVal + ] +copilotLogMessageToSayWhat + (TriggersInvokedCorrespondinglyProofGoal step goalIdx numTotalGoals + (TriggersInvokedCorrespondingly loc name expected actual)) = + copilotNoisily $ + displayProofGoal + step VerifierProvenance goalIdx numTotalGoals + "asserting triggers fired in corresponding ways" + [ renderStrict $ ppProgramLoc loc + , "* Trigger name: " <> T.pack name + , "* Expected number of times trigger was fired:" + , renderStrict $ PP.indent 4 $ WI.printSymNat expected + , "* Actual number of times trigger was fired:" + , renderStrict $ PP.indent 4 $ WI.printSymNat actual + ] +copilotLogMessageToSayWhat + (TriggerArgumentEqualityProofGoal step goalIdx numTotalGoals + (TriggerArgumentEquality + sym loc + triggerName argNum + copilotTy copilotVal + crucibleTy crucibleVal)) = + copilotNoisily $ + displayProofGoal + step VerifierProvenance goalIdx numTotalGoals + "asserting the equality between two trigger arguments" + [ renderStrict $ ppProgramLoc loc + , "* Trigger name: " <> T.pack triggerName + , "* Number of argument: " <> T.pack (show argNum) + , "* Copilot type: " <> T.pack (showsCopilotType 0 copilotTy "") + , "* Copilot value:" + , renderStrict $ PP.indent 4 $ ppCopilotValue copilotVal + , "* Crucible value:" + , renderStrict $ PP.indent 4 $ ppCrucibleValue sym crucibleTy crucibleVal + ] +copilotLogMessageToSayWhat + (RingBufferLoadProofGoal verifStep goalIdx numTotalGoals + (RingBufferLoad + _sym stateRelStep loc bufName offset len copilotTy _crucibleTy p)) = + copilotNoisily $ + displayStateRelationProofGoal + verifStep stateRelStep VerifierProvenance goalIdx numTotalGoals + "asserting the validity of a memory load from a stream's ring buffer in C" + [ renderStrict $ ppProgramLoc loc + , "* Ring buffer name: " <> bufName + , "* Offset into buffer (from current index): " <> T.pack (show offset) + , "* Number of elements in buffer: " <> T.pack (show len) + , "* Copilot type of buffer elements:" <> T.pack (showsCopilotType 0 copilotTy "") + , "* Validity predicate:" + , renderStrict $ PP.indent 4 $ WI.printSymExpr p + ] +copilotLogMessageToSayWhat + (RingBufferIndexLoadProofGoal verifStep goalIdx numTotalGoals + (RingBufferIndexLoad _sym stateRelStep loc idxName p)) = + copilotNoisily $ + displayStateRelationProofGoal + verifStep stateRelStep VerifierProvenance goalIdx numTotalGoals + "asserting the validity of a memory load from the index to a stream's ring buffer in C" + [ renderStrict $ ppProgramLoc loc + , "* Ring buffer index name: " <> idxName + , "* Validity predicate:" + , renderStrict $ PP.indent 4 $ WI.printSymExpr p + ] +copilotLogMessageToSayWhat + (PointerArgumentLoadProofGoal step goalIdx numTotalGoals + (PointerArgumentLoad + _sym loc copilotTy _crucibleTy p)) = + copilotNoisily $ + displayProofGoal + step VerifierProvenance goalIdx numTotalGoals + "asserting the validity of a memory load from a pointer argument to a trigger" + [ renderStrict $ ppProgramLoc loc + , "* Copilot type: " <> T.pack (showsCopilotType 0 copilotTy "") + , "* Validity predicate:" + , renderStrict $ PP.indent 4 $ WI.printSymExpr p + ] +copilotLogMessageToSayWhat + (AccessorFunctionLoadProofGoal step goalIdx numTotalGoals + (AccessorFunctionLoad _sym loc accessorName p)) = + copilotNoisily $ + displayProofGoal + step StepExecutionProvenance goalIdx numTotalGoals + "asserting the validity of a memory load from a stream accessor function" + [ renderStrict $ ppProgramLoc loc + , "* Accessor function name: " <> WF.functionName accessorName + , "* Validity predicate:" + , renderStrict $ PP.indent 4 $ WI.printSymExpr p + ] +copilotLogMessageToSayWhat + (GuardFunctionLoadProofGoal step goalIdx numTotalGoals + (GuardFunctionLoad _sym loc accessorName p)) = + copilotNoisily $ + displayProofGoal + step StepExecutionProvenance goalIdx numTotalGoals + "asserting the validity of a memory load from a trigger guard function" + [ renderStrict $ ppProgramLoc loc + , "* Guard function name: " <> WF.functionName accessorName + , "* Validity predicate:" + , renderStrict $ PP.indent 4 $ WI.printSymExpr p + ] +copilotLogMessageToSayWhat + (UnknownFunctionLoadProofGoal step goalIdx numTotalGoals + (UnknownFunctionLoad _sym loc accessorName p)) = + copilotNoisily $ + displayProofGoal + step StepExecutionProvenance goalIdx numTotalGoals + "asserting the validity of a memory load from an unknown function" + [ renderStrict $ ppProgramLoc loc + , "* Function name: " <> WF.functionName accessorName + , "* Validity predicate:" + , renderStrict $ PP.indent 4 $ WI.printSymExpr p + ] +copilotLogMessageToSayWhat + (LLVMBadBehaviorCheckProofGoal step goalIdx numTotalGoals + (LLVMBadBehaviorCheck _sym loc stk bb p)) = + let ppLoc = renderStrict $ ppProgramLoc loc + ppCallStackLines = + [ "* Call stack:" + , " " <> renderCallStack stk + ] + ppValidPredLines = + [ "* Validity predicate:" + , renderStrict $ PP.indent 4 $ WI.printSymExpr p + ] in + case bb of + LCLE.BBUndefinedBehavior ub -> + copilotNoisily $ + displayProofGoal + step StepExecutionProvenance goalIdx numTotalGoals + "asserting that LLVM undefined behavior does not occur" + $ ppLoc : ppCallStackLines ++ + [ "* Undefined behavior description:" + , renderStrict $ PP.indent 4 $ LCLEUB.ppDetails ub + ] ++ ppValidPredLines + LCLE.BBMemoryError me -> + copilotNoisily $ + displayProofGoal + step StepExecutionProvenance goalIdx numTotalGoals + "asserting that LLVM memory unsafety does not occur" + $ ppLoc : ppCallStackLines ++ + [ "* Memory unsafety description:" + , renderStrict $ PP.indent 4 $ LCLEME.explain me + ] ++ ppValidPredLines + +describeVerificationStep :: VerificationStep -> Text +describeVerificationStep InitialState = "initial state" +describeVerificationStep StepBisimulation = "step bisimulation" + +-- | Display information about an emitted proof goal. +displayProofGoal :: + VerificationStep + -> AssertionProvenance + -> Integer + -> Integer + -> Text + -> [Text] + -> Text +displayProofGoal step assertProv goalIdx numTotalGoals why ls = T.unlines $ + [ banner + , "Emitted a proof goal (" <> why <> ")" + , " During the " <> displayStep + , " Required for proving the " <> displayAssertProv + , " Proof goal " <> T.pack (show goalIdx) + <> " (" + <> T.pack (show numTotalGoals) + <> " total)" + , "" + ] + ++ ls ++ [banner] + where + banner = "=====" + displayStep = + case step of + InitialState -> + "initial bisimulation state step" + StepBisimulation -> + "transition step of bisimulation" + displayAssertProv = + case assertProv of + VerifierProvenance -> + "correspondence between the spec and C code" + StepExecutionProvenance -> + "memory safety of the generated step() function" + +-- | Display information about an emitted proof goal that involves checking the +-- state relation. +displayStateRelationProofGoal :: + VerificationStep + -> StateRelationStep + -> AssertionProvenance + -> Integer + -> Integer + -> Text + -> [Text] + -> Text +displayStateRelationProofGoal verifStep stateRelStep assertProv goalIdx numTotalGoals why = + displayProofGoal verifStep assertProv goalIdx numTotalGoals why' + where + why' :: Text + why' = + case stateRelStep of + PreStepStateRelation -> why <> " before calling step()" + PostStepStateRelation -> why <> " after calling step()" + -- `displayProofGoal` already makes a note of the fact that we're + -- checking the initial state, so no need to do so again here. + InitialStateRelation -> why + +ppProgramLoc :: WPL.ProgramLoc -> PP.Doc a +ppProgramLoc pl = PP.vcat + [ "* Function:" PP.<+> PP.pretty (WPL.plFunction pl) + , " Position:" PP.<+> PP.pretty (WPL.plSourceLoc pl) + ] + +renderCallStack :: LCLMCS.CallStack -> Text +renderCallStack cs + | T.null ppText + = "" + | otherwise + = ppText + where + ppText = renderStrict $ LCLMCS.ppCallStack cs + +showsCopilotType :: Int -> CT.Type tp -> ShowS +showsCopilotType prec tp = + case tp of + CT.Bool -> showString "Bool" + CT.Int8 -> showString "Int8" + CT.Int16 -> showString "Int16" + CT.Int32 -> showString "Int32" + CT.Int64 -> showString "Int64" + CT.Word8 -> showString "Word8" + CT.Word16 -> showString "Word16" + CT.Word32 -> showString "Word32" + CT.Word64 -> showString "Word64" + CT.Float -> showString "Float" + CT.Double -> showString "Double" + CT.Array t -> showParen (prec >= 11) $ + showString "Array" . + showsPrec 11 (CT.typeSize tp) . + showsCopilotType 11 t + CT.Struct x -> showString $ CT.typeName x + +ppCopilotValue :: WI.IsSymExprBuilder sym => CW4.XExpr sym -> PP.Doc a +ppCopilotValue val = + case val of + CW4.XBool b -> WI.printSymExpr b + CW4.XInt8 i -> WI.printSymExpr i + CW4.XInt16 i -> WI.printSymExpr i + CW4.XInt32 i -> WI.printSymExpr i + CW4.XInt64 i -> WI.printSymExpr i + CW4.XWord8 w -> WI.printSymExpr w + CW4.XWord16 w -> WI.printSymExpr w + CW4.XWord32 w -> WI.printSymExpr w + CW4.XWord64 w -> WI.printSymExpr w + CW4.XFloat f -> WI.printSymExpr f + CW4.XDouble d -> WI.printSymExpr d + CW4.XEmptyArray {} -> "[]" + CW4.XArray a -> ppBracesWith ppCopilotValue (PV.toList a) + CW4.XStruct s -> ppBracketsWith ppCopilotValue s + +ppCrucibleValue :: WI.IsSymExprBuilder sym + => sym + -> LCT.TypeRepr tp + -> LCS.RegValue sym tp + -> PP.Doc a +ppCrucibleValue sym tp val = + case tp of + LCLM.LLVMPointerRepr _ -> LCLM.ppPtr val + LCT.FloatRepr _ -> WI.printSymExpr val + LCT.VectorRepr tpr -> ppBracketsWith (ppCrucibleValue sym tpr) (V.toList val) + LCT.StructRepr ctx -> withBraces $ + PWI.itoListFC (\i (LCS.RV v) -> ppCrucibleValue sym (ctx Ctx.! i) v) val + _ -> error $ "ppCrucibleValue: Unsupported type: " ++ show tp + +renderStrict :: PP.Doc a -> Text +renderStrict = PP.renderStrict . PP.layoutPretty PP.defaultLayoutOptions + +ppBracketsWith :: (a -> PP.Doc b) -> [a] -> PP.Doc b +ppBracketsWith f = PP.align . PP.list . map f + +ppBracesWith :: (a -> PP.Doc b) -> [a] -> PP.Doc b +ppBracesWith f = withBraces . map f + +withBraces :: [PP.Doc a] -> PP.Doc a +withBraces = + PP.align + . PP.encloseSep (PP.flatAlt "{ " "{") (PP.flatAlt " }" "}") ", " + +$(deriveToJSON defaultOptions ''CopilotLogMessage) diff --git a/copilot-verifier/src/Copilot/Verifier/Solver.hs b/copilot-verifier/src/Copilot/Verifier/Solver.hs new file mode 100644 index 000000000..8887be811 --- /dev/null +++ b/copilot-verifier/src/Copilot/Verifier/Solver.hs @@ -0,0 +1,25 @@ +module Copilot.Verifier.Solver + ( Solver(..) + , solverAdapter + ) where + +import qualified What4.Solver.Adapter as W4 +import qualified What4.Solver.CVC4 as W4.CVC4 +import qualified What4.Solver.CVC5 as W4.CVC5 +import qualified What4.Solver.Yices as W4.Yices +import qualified What4.Solver.Z3 as W4.Z3 + +-- | General-purpose SMT solvers that @copilot-verifier@ supports. +data Solver + = CVC4 + | CVC5 + | Yices + | Z3 + deriving Show + +-- | Return the @what4@ 'W4.SolverAdapter' corresponding to a given 'Solver'. +solverAdapter :: Solver -> W4.SolverAdapter st +solverAdapter CVC4 = W4.CVC4.cvc4Adapter +solverAdapter CVC5 = W4.CVC5.cvc5Adapter +solverAdapter Yices = W4.Yices.yicesAdapter +solverAdapter Z3 = W4.Z3.z3Adapter diff --git a/copilot-verifier/test/Test.hs b/copilot-verifier/test/Test.hs new file mode 100644 index 000000000..8ed51e915 --- /dev/null +++ b/copilot-verifier/test/Test.hs @@ -0,0 +1,32 @@ +module Main (main) where + +import qualified Data.CaseInsensitive as CI +import qualified Data.Map as Map +import qualified Data.Text as Text +import System.IO (stderr, stdout) +import System.IO.Silently (hSilence) +import Test.Tasty +import Test.Tasty.ExpectedFailure +import Test.Tasty.HUnit + +import Copilot.Verifier (Verbosity(..)) +import Copilot.Verifier.Examples (shouldFailExamples, shouldPassExamples) + +main :: IO () +main = defaultMain $ + testGroup "copilot-verifier-examples tests" + [ testGroup "should-fail tests" $ + -- Why use hSilence for the should-fail tests when we are passing + -- Quiet? It's because crux-llvm errors are logged at the highest + -- severity possible, and even Crux's quietMode isn't enough to + -- suppress those messages. We could try messing with things on the + -- Crux side to avoid this, but it's simpler just to use hSilence here. + -- After all, we don't really care about the output of failing tests + -- anyway, just their exit codes. + map (\(name, action) -> expectFail (testCase (Text.unpack (CI.original name)) + (hSilence [stderr, stdout] action))) + (Map.toAscList (shouldFailExamples Quiet)) + , testGroup "should-pass tests" $ + map (\(name, action) -> testCase (Text.unpack (CI.original name)) action) + (Map.toAscList (shouldPassExamples Quiet)) + ] diff --git a/copilot-visualizer/CHANGELOG b/copilot-visualizer/CHANGELOG new file mode 100644 index 000000000..b578bedb9 --- /dev/null +++ b/copilot-visualizer/CHANGELOG @@ -0,0 +1,35 @@ +2026-11-07 + * Version bump (4.8.2). (#792) + +2026-09-07 + * Version bump (4.8.1). (#760) + * Fix inconsistent version bounds for `copilot` in Cabal file. (#749) + * Relax version constraints on `ogma-extra`. (#757) + +2026-07-07 + * Version bump (4.8). (#745) + +2026-05-07 + * Version bump (4.7.1). (#730) + +2026-03-07 + * Version bump (4.7). (#714) + * Relax version constraints on ogma-extra. (#716) + +2026-01-07 + * Version bump (4.6.1). (#705) + +2025-11-07 + * Version bump (4.6). (#679) + +2025-09-07 + * Version bump (4.5.1). (#666) + * Relax version constraint on `ogma-extra`. (#645) + +2025-07-07 + * Version bump (4.5). (#642) + * Include in mainline. (#624) + +2025-06-26 + * Release 4.4. (copilot-visualizer#5) + * Initial version. (copilot-visualizer#4) diff --git a/copilot-visualizer/LICENSE b/copilot-visualizer/LICENSE new file mode 100644 index 000000000..d3c9e46cd --- /dev/null +++ b/copilot-visualizer/LICENSE @@ -0,0 +1,29 @@ +2024-2025 (c) NASA +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. diff --git a/copilot-visualizer/README.md b/copilot-visualizer/README.md new file mode 100644 index 000000000..f4a93c4a2 --- /dev/null +++ b/copilot-visualizer/README.md @@ -0,0 +1,34 @@ +[![Build Status](https://travis-ci.com/Copilot-Language/copilot.svg?branch=master)](https://app.travis-ci.com/github/Copilot-Language/copilot) + +# Copilot: a stream DSL + +The visualizer, which draws Copilot specifications using different graphical +formats. + +Copilot is a runtime verification framework written in Haskell. It allows the +user to write programs in a simple but powerful way using a stream-based +approach. + +Programs can be interpreted for testing (with the library copilot-interpreter), +or translated C99 code to be incorporated in a project, or as a standalone +application. The C99 backend ensures us that the output is constant in memory +and time, making it suitable for systems with hard realtime requirements. + +## Installation + +Copilot-visualizer can be found on +[Hackage](https://hackage.haskell.org/package/copilot-interpreter). It is +typically only installed as part of the complete Copilot distribution. For +installation instructions, please refer to the [Copilot +website](https://copilot-language.github.io). + +## Further information + +For further information, install instructions and documentation, please visit +the Copilot website: +[https://copilot-language.github.io](https://copilot-language.github.io) + +## License + +Copilot is distributed under the BSD-3-Clause license, which can be found +[here](https://raw.githubusercontent.com/Copilot-Language/copilot/master/copilot-interpreter/LICENSE). diff --git a/copilot-visualizer/Setup.hs b/copilot-visualizer/Setup.hs new file mode 100644 index 000000000..9a994af67 --- /dev/null +++ b/copilot-visualizer/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/copilot-visualizer/copilot-visualizer.cabal b/copilot-visualizer/copilot-visualizer.cabal new file mode 100644 index 000000000..34d2289bd --- /dev/null +++ b/copilot-visualizer/copilot-visualizer.cabal @@ -0,0 +1,130 @@ +cabal-version: >= 1.10 +name: copilot-visualizer +version: 4.8.2 +synopsis: Visualizer for Copilot. +description: + Visualizer for Copilot. + . + 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 + . + +author: Ivan Perez, Frank Dedden, Ryan Scott, Kyle Beechly +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 + examples/gui/Main.hs + examples/gui/main.html + examples/gui/copilot.css + examples/gui/copilot.js + examples/tikz/Heater.hs + +data-files: data/tikz/tikz.tex + data/static_html/index.html + +x-curation: uncurated + +source-repository head + type: git + location: https://github.com/Copilot-Language/copilot.git + subdir: copilot-visualizer + +flag examples + description: Enable examples + default: False + manual: True + +library + + default-language: + Haskell2010 + + hs-source-dirs: + src + + ghc-options: + -Wall + + build-depends: + base >= 4.9 && < 5, + aeson >= 2.0.0.0 && < 2.3, + filepath >= 1.4.2 && < 1.6, + hint >= 0.9.0 && < 1.10, + pretty >= 1.0 && < 1.2, + ogma-extra >= 1.6.0 && < 1.17, + text >= 1.2.3.1 && < 2.2, + websockets >= 0.12.7 && < 0.14, + + copilot >= 4.8.2 && < 4.9, + copilot-core >= 4.8.2 && < 4.9, + copilot-interpreter >= 4.8.2 && < 4.9, + copilot-language >= 4.8.2 && < 4.9 + + exposed-modules: + + Copilot.Visualize.Live + Copilot.Visualize.Static + + other-modules: + + Copilot.Visualize.Dynamic + Copilot.Visualize.TypedTrace + Copilot.Visualize.UntypedTrace + Paths_copilot_visualizer + +executable gui-example + main-is: + Main.hs + + default-language: + Haskell2010 + + hs-source-dirs: + examples/gui + + ghc-options: + -Wall + + build-depends: + base >= 4.9 && < 5, + + copilot-visualizer + + if flag(examples) + buildable: True + else + buildable: False + +executable tikz-example + main-is: + Heater.hs + + default-language: + Haskell2010 + + hs-source-dirs: + examples/tikz + + ghc-options: + -Wall + + build-depends: + base >= 4.9 && < 5, + + copilot >= 4.8.2 && < 4.9, + copilot-visualizer + + if flag(examples) + buildable: True + else + buildable: False diff --git a/copilot-visualizer/data/static_html/index.html b/copilot-visualizer/data/static_html/index.html new file mode 100644 index 000000000..2160ec87a --- /dev/null +++ b/copilot-visualizer/data/static_html/index.html @@ -0,0 +1,255 @@ + + + + + + Copilot Visualizer + + + + + + + +
+ +
+ + + + diff --git a/copilot-visualizer/data/tikz/tikz.tex b/copilot-visualizer/data/tikz/tikz.tex new file mode 100644 index 000000000..b05f2c186 --- /dev/null +++ b/copilot-visualizer/data/tikz/tikz.tex @@ -0,0 +1,37 @@ +{{=<% %>=}} +\documentclass{standalone} +\usepackage{tikz} +\usepackage{tikz-timing} +\usepackage{xcolor} +\definecolor{false}{HTML}{ECD9ED} +\definecolor{true}{HTML}{D9ECED} +\begin{document} +\newcommand{\true}{T} +\newcommand{\false}{F} +\tikzset{ +every picture/.style={ + execute at end picture={ + \path (current bounding box.south west) +(-1,-1) (current bounding box.north east) +(1,1); + } +} +} + +\tikzset{ +timing/.style={x=5ex,y=2ex}, +timing/rowdist=4ex, +timing/dslope=0.1, +x=5ex, +timing/coldist=1ex, +timing/name/.style={font=\sffamily\scriptsize}, +timing/d/text/.style={font=\sffamily\tiny}, +} +\begin{tikztimingtable} +<%#adTraceElems%> +<%teName%> & g<%#teValues%><%#tvIsEmpty%>S<%/tvIsEmpty%><%^tvIsEmpty%><%#teIsBoolean%>[fill=<%tvValue%>]D{\<%tvValue%>}<%/teIsBoolean%><%^teIsBoolean%>D{<%tvValue%>}<%/teIsBoolean%><%/tvIsEmpty%><%/teValues%>\\ +<%/adTraceElems%> +\extracode +\begin{background}[shift={(0.05,0)},help lines] +\vertlines[help lines,opacity=0.3]{-0.3ex,...,<%adLastSample%>} +\end{background} +\end{tikztimingtable} +\end{document} diff --git a/copilot-visualizer/examples/gui/Main.hs b/copilot-visualizer/examples/gui/Main.hs new file mode 100644 index 000000000..8b93b7cbd --- /dev/null +++ b/copilot-visualizer/examples/gui/Main.hs @@ -0,0 +1,20 @@ +import Copilot.Visualize.Live + +main = visualize spec + +spec :: String +spec = unlines + [ "let temperature :: Stream Word8" + , " temperature = extern \"temperature\" (Just [0, 15, 20, 25, 30])" + , "" + , " ctemp :: Stream Float" + , " ctemp = (unsafeCast temperature) * (150.0 / 255.0) - 50.0" + , "" + , " trueFalse :: Stream Bool" + , " trueFalse = [True] ++ not trueFalse" + , "" + , "in do trigger \"heaton\" (temperature < 18) [arg ctemp, arg (constI16 1), arg trueFalse]" + , " trigger \"heatoff\" (temperature > 21) [arg (constI16 1), arg ctemp]" + , " observer \"temperature\" temperature" + , " observer \"temperature2\" (temperature + 1)" + ] diff --git a/copilot-visualizer/examples/gui/copilot.css b/copilot-visualizer/examples/gui/copilot.css new file mode 100644 index 000000000..82a1a0af6 --- /dev/null +++ b/copilot-visualizer/examples/gui/copilot.css @@ -0,0 +1,50 @@ +/* Timeline */ +/* Timeline decoration: Grid */ +.axis path, +.axis line { + fill: none; + stroke: #000; + shape-rendering: crispEdges; +} +.grid-line { + stroke: #ccc; + stroke-width: 1; + stroke-dasharray: 3,3; +} + +/* Timeline decoration: Labels */ +.label { + font-size: 12px; +} +.time-label { + font-family: sans-serif; + font-size: 12px; + fill: black; +} +.value-text { + font-size: 10px; + text-anchor: middle; + dominant-baseline: middle; +} + +/* Timeline decoration: Values */ +.hexagon { + stroke: black; + stroke-width: 1px; + color: green; +} +.bool-background { + opacity: 0.3; +} + +/* Toolbar buttons */ +button { + width: 100px !important; + height: 48px !important; + border-radius: 24px !important; + background-color: #f1316b !important; + color: #fff !important; + margin-top: 45px !important; + border:none !important; + font-size: 12px !important; +} diff --git a/copilot-visualizer/examples/gui/copilot.js b/copilot-visualizer/examples/gui/copilot.js new file mode 100644 index 000000000..943e3c704 --- /dev/null +++ b/copilot-visualizer/examples/gui/copilot.js @@ -0,0 +1,489 @@ +/* Constants */ + +/* Timeline dimensions */ +const margin = {top: 20, right: 20, bottom: 30, left: 90}; +const width = 960 - margin.left - margin.right; +const height = 200 - margin.top - margin.bottom; +const rowHeight = 40; + +/** + * Position of the stream labels wrt. to the left side of the timeline. + */ +const labelPosX = -90; + +/* Timeline colors */ + +/* Default colors for true and false (just dim green and red). */ +const booleanColorDefaultTrue = "#90EE90"; +const booleanColorDefaultFalse = "#FFB6C1"; + +/* + * Alternative colors for true and false, making colored backgrounds more + * easily distinguishable in conditions with reduced color. Specifically: + * + * - Increase blue content in the 'false' color to increase distinction from + * the 'true' color in protanopic (no red) and deuteranopic (no green). + * + * - Decrease red content in the 'false' color to increase distinction from the + * 'true' color in achromatopsic (no color) conditions. + * + * This does not meaningfully address visibility considerations in reduced + * contrast or blurry conditions. + */ +const booleanColorHighContrastTrue = "#90EE90"; +const booleanColorHighContrastFalse = "#E1B6ED"; + +/* Timeline state */ +let svg; +let data = { adLastSample: 0, adTraceElems: [] }; +let xScale; +let numRows = 0; +let numSteps = 2; +let booleanColorTrue = booleanColorDefaultTrue; +let booleanColorFalse = booleanColorDefaultFalse; + +/** + * Process numeric data, adding duration and y-positions to each trace element. + */ +function processNumericData(data) +{ + // Calculate bounds of stream. + const maxValue = Math.max(...data.map(d => d.tvValue)); + const minValue = Math.min(...data.map(d => d.tvValue)); + + // Vertical scale of the stream. + const yScale = d3.scaleLinear() + .domain([minValue, maxValue]) + .range([rowHeight * 0.8, rowHeight * 0.2]); + + // Return the data augmented with duration for each sample, and the vertical + // scale. + return data.map((d, i) => ({ + ...d, + duration: + i < data.length - 1 ? data[i + 1].time - d.time : numSteps + 1 - d.time, + y: yScale(d.tvValue) + })); +} + +/** + * Create timeline labels. + */ +function createLabels() +{ + document.querySelectorAll(".label").forEach(function(lst) { + lst.remove(); + }); + + // Add row labels. + const labels = data.adTraceElems.map((x) => x.teName); + svg.selectAll(".label") + .data(labels) + .enter() + .append("text") + .attr("class", "label") + .attr("x", labelPosX) + .attr("y", (d, i) => i * rowHeight + rowHeight/2) + .text(d => d); +} + +/** + * Draw numeric row with stretched hexagons. + */ +function drawNumericRow(data, rowIndex) +{ + const rowG = svg.append("g") + .attr("class", "value_list") + .attr("transform", `translate(0,${rowIndex * rowHeight})`); + + const hexHeight = rowHeight * 0.8; + + time = 0; + + // Create hexagon groups. + const hexGroups = rowG.selectAll("g") + .data(data) + .enter() + .append("g") + .attr("transform", d => `translate(${xScale(time++)},${rowHeight * 0.1})`); + + // Add hexagons. + hexGroups.append("path") + .attr("class", "hexagon") + .attr("d", d => hexagonPath(xScale(1) - xScale(0), hexHeight)) + .attr("fill", "#f7fbff"); + + // Add value text. + hexGroups.append("text") + .attr("class", "value-text") + .attr("x", d => (xScale(1) - xScale(0)) / 2) + .attr("y", hexHeight / 2) + .text(d => d.tvValue); +} + +/** + * Draw boolean rows with colored backgrounds. + */ +function drawBooleanRow(data, rowIndex) +{ + const rowG = svg.append("g") + .attr("class", "value_list") + .attr("transform", `translate(0,${rowIndex * rowHeight})`); + + time = 0; + + // Draw colored backgrounds. + rowG.selectAll("rect") + .data(data) + .enter() + .append("rect") + .attr("class", "bool-background") + .attr("x", d => xScale(time++)) + .attr("y", 0) + .attr("width", d => xScale(1) - xScale(0)) + .attr("height", rowHeight) + .attr("fill", d => d.tvValue == "true" ? booleanColorTrue : booleanColorFalse); +} + +/** + * Re-draw complete timeline. + */ +function redraw() +{ + document.querySelectorAll(".value_list").forEach(function(lst) { + lst.remove(); + }); + + // Draw all rows. + i = 0; + data.adTraceElems.forEach(function(traceElem) { + if (traceElem.teIsBoolean) + { + drawBooleanRow(traceElem.teValues, i); + } + else + { + drawNumericRow(processNumericData(traceElem.teValues), i); + } + i++; + }); +} + +/** + * Create SVG for the timeline. + */ +function createSVG() +{ + // Clear all existing elements. + if (typeof svg !== 'undefined' ) { svg.selectAll("*").remove(); } + + // Calculate number of rows and columns (steps) from available data. + numRows = data.adTraceElems.length; + numSteps = data.adLastSample; + + // Create SVG. + svg = d3.select("#timeline") + .attr("width", width + margin.left + margin.right) + .attr("height", (rowHeight * numRows) + margin.top + margin.bottom) + .append("g") + .attr("transform", `translate(${margin.left},${margin.top})`); + + // Create scales. + xScale = d3.scaleLinear() + .domain([0, numSteps + 1]) + .range([0, width]); + + // Create x-axis with ticks at integer positions. + const xAxis = d3.axisBottom(xScale) + .tickValues(Array.from({length: 11}, (_, i) => i)) + .tickFormat(''); + + createLabels(); + redraw(); + + // Add the axis. + const axisGroup = svg.append("g") + .attr("class", "axis") + .attr("transform", `translate(0,${rowHeight * numRows})`) + .call(xAxis); + + // After creating the axis and labels, add vertical grid lines. + // + // Use light gray as color, a dotted line, start from the top (negative + // because we are going up from the axis), and end at the axis. + const gridLines = axisGroup.selectAll(".grid-line") + .data(Array.from({length: 11}, (_, i) => i)) + .enter() + .append("line") + .attr("class", "grid-line") + .attr("x1", d => xScale(d)) + .attr("x2", d => xScale(d)) + .attr("y1", -rowHeight * (numRows + 1)) + .attr("y2", 0) + .style("stroke", "#ccc") + .style("stroke-width", "1") + .style("stroke-dasharray", "3,3"); + + // Add offset labels. + const timeLabels = axisGroup.selectAll(".time-label") + .data(Array.from({length: numRows + 1}, (_, i) => i)) + .enter() + .append("text") + .attr("class", "time-label") + .attr("x", d => xScale(d + 0.5)) + .attr("y", 25) + .attr("text-anchor", "middle") + .text(d => d + ""); + + // Detect clicks on timeline. + svg.on("click", function(event) { + const mouseX = d3.pointer(event)[0]; + const time = Math.floor(xScale.invert(mouseX).toFixed(2)); + const row = Math.floor((event.offsetY - margin.top) / rowHeight); + const label = data.adTraceElems[row].teName; + + console.log("Label:", label , "Time:", time); + ws.send('(Up ' + time + ', "' + label + '")'); + }); + + // Detect mouse wheel on timeline. + svg.on("wheel", function(event) { + // Prevent default scroll behavior. + event.preventDefault(); + + const mouseX = d3.pointer(event)[0]; + const time = Math.floor(xScale.invert(mouseX).toFixed(2)); + const row = Math.floor((event.offsetY - margin.top) / rowHeight); + const label = data.adTraceElems[row].teName; + const dir = event.deltaY < 0 ? 'Up' : 'Down'; + + ws.send('(' + dir + ' ' + time + ', "' + label + '")'); + + console.log ( "Label:", label, "Time:", time, "Direction:", dir); + }); +} + +/** + * Add a step to the simulation. + */ +function stepUp() +{ + ws.send('(StepUp, "")'); +} + +/** + * Reduce the number of steps of the simulation. + */ +function stepDown() +{ + ws.send('(StepDown, "")'); +} + +/** + * Open a dialog requesting information to add a new stream to the simulation. + */ +function addStream() +{ + const popup = document.getElementById("popup"); + popup.classList.remove("hidden"); +} + +/** + * Cancel dialog requesting information to add a new stream to the simulation. + */ +function closePopup() +{ + const popup = document.getElementById("popup"); + popup.classList.add("hidden"); +} + +/** + * Add a new stream to the simulation. The definition provided must be correct + * in the context of the current simulation, and the name given to the new + * stream must be valid in Haskell, unique in the current context, and not + * clash with any existing names. + */ +function addStreamSubmit() +{ + const popup = document.getElementById("popup"); + const inputName = document.getElementById("inputName").value; + const inputExpr = document.getElementById("inputExpr").value; + ws.send('(AddStream "' + inputName + '" "(' + inputExpr + ')", "")'); + popup.classList.add("hidden"); +} + +/** + * Toggle the color scheme of the timeline. + */ +function toggleColors() +{ + const highContrastBtn = document.getElementById('high_contrast'); + if (highContrastBtn.checked) { + booleanColorTrue = booleanColorHighContrastTrue; + booleanColorFalse = booleanColorHighContrastFalse; + } else { + booleanColorTrue = booleanColorDefaultTrue; + booleanColorFalse = booleanColorDefaultFalse; + } + + createSVG(); +} + +/* Attach event handlers to UI elements */ + +// Somehow this does not work if we match the svg element directly, so we match +// the parent div. +document.getElementById("copyPNG").addEventListener("click", () => copyPNG("#timeline-parent")); + +document.getElementById("copySVG").addEventListener("click", () => copySVG("#timeline")); + +// Somehow this does not work if we match the svg element directly, so we match +// the parent div. +document.getElementById("downloadPNG").addEventListener("click", () => downloadPNG("#timeline-parent", "timeline")); + +document.getElementById("downloadSVG").addEventListener("click", () => downloadSVG("#timeline", "timeline")); + +document.getElementById("stepUp").addEventListener("click", stepUp); +document.getElementById("stepDown").addEventListener("click", stepDown); +document.getElementById("addStream").addEventListener("click", addStream); +document.getElementById("closePopup").addEventListener("click", closePopup); +document.getElementById("submitPopup").addEventListener("click", addStreamSubmit); + +// Adjust colors using high-contrast when applicable. +document.getElementById('high_contrast').addEventListener('change', toggleColors); + +createSVG(); + +// Communicate with the backend instance of Copilot via a websocket. +let ws = new WebSocket('ws://localhost:9160'); + +ws.onmessage = function(event) { + data = JSON.parse(event.data); + createSVG(); +}; + +ws.onclose = function() { + console.log('Disconnected from server'); +}; + +ws.onerror = function(error) { + console.log('Error: ' + error.message); +}; + +/* Auxiliary functions */ + +/** + * Create an hexagon path (used for cells or samples). + */ +function hexagonPath(width, height) +{ + return ` + M ${width-10},0 + L ${width},${height/2} + L ${width-10},${height} + L ${10},${height} + L ${0},${height/2} + L ${10},0 + Z + `; +} + +/** + * Download a file containing a given text. + */ +function download(filename, text) +{ + var element = document.createElement('a'); + element.setAttribute('href', 'data:text/plain;charset=utf-8,' + encodeURIComponent(text)); + element.setAttribute('download', filename); + + element.style.display = 'none'; + document.body.appendChild(element); + + element.click(); + + document.body.removeChild(element); +} + +/** + * Copy element as SVG to clipboard as SVG. + * + * @param {svg} queryString - Query string referring to an SVG element in the + * current document. + */ +function copySVG(queryString) +{ + const mySVG = document.querySelector(queryString); + const data = new XMLSerializer().serializeToString(mySVG); + + navigator.clipboard.writeText(data).then( + () => { + console.log("SVG copied to clipboard"); + }, + (err) => { + console.log("Failed to copy SVG to clipboard"); + } + ); +} + +/** + * Copy timeline to clipboard as PNG. + * + * @param {string} queryString - Query string referring to element in the + * current document. + */ +function copyPNG(queryString) +{ + const elem = document.querySelector(queryString); + html2canvas(elem).then(function(canvas) { + canvas.toBlob(function(blob) { + navigator.clipboard + .write([ + new ClipboardItem( + Object.defineProperty({}, blob.type, { + value: blob, + enumerable: true + }) + ) + ]).then(function() { + console.log("Copied to clipboard"); + }); + }); + }); +} + +/** + * Download screenshot of an element as a PNG file. + * + * @param {string} queryString - Query string referring to element in the + * current document. + * + * @param {string} defaultFilename - Default file name used in the save file + * dialog. + */ +function downloadPNG(queryString, defaultFilename) +{ + const mySVG = document.querySelector(queryString); + html2canvas(mySVG).then(function(canvas) { + var a = document.createElement('a'); + a.href = canvas.toDataURL(); + a.download = defaultFilename + ".png"; + a.click(); + }); +} + +/** + * Download screenshot of timeline as SVG file. + * + * @param {string} queryString - Query string referring to element in the + * current document. + * + * @param {string} defaultFilename - Default file name used in the save file + * dialog. + */ +function downloadSVG(queryString, defaultFilename) +{ + const mySVG = document.querySelector(queryString); + const data = new XMLSerializer().serializeToString(mySVG); + download(defaultFilename + ".svg", data); +} diff --git a/copilot-visualizer/examples/gui/main.html b/copilot-visualizer/examples/gui/main.html new file mode 100644 index 000000000..a2003d72a --- /dev/null +++ b/copilot-visualizer/examples/gui/main.html @@ -0,0 +1,67 @@ + + + Copilot Visualizer + + + + + + + + + + + + + + +
+ +
+ + +
+ + + + + + + +
+ + +
+ +
+ + + + + + + + diff --git a/copilot-visualizer/examples/tikz/Heater.hs b/copilot-visualizer/examples/tikz/Heater.hs new file mode 100644 index 000000000..e36cde926 --- /dev/null +++ b/copilot-visualizer/examples/tikz/Heater.hs @@ -0,0 +1,37 @@ +-- Copyright 2025 NASA +-- Copyright 2019 National Institute of Aerospace / Galois, Inc. + +-- This is a simple example with basic usage. It implements a simple home +-- heating system: It heats when temp gets too low, and stops when it is high +-- enough. It read temperature as a byte (range -50C to 100C) and translates +-- this to Celsius. + +module Main where + +import Language.Copilot +import Copilot.Visualize.Static + +import Prelude hiding ((>), (<)) + +-- External temperature as a byte, range of -50C to 100C +temp :: Stream Word8 +temp = extern "temperature" (Just [ 10, 15, 18, 19, 25, 5, 45 ]) + +-- Calculate temperature in Celsius. +-- We need to cast the Word8 to a Float. Note that it is an unsafeCast, as there +-- is no direct relation between Word8 and Float. +ctemp :: Stream Float +ctemp = (unsafeCast temp) * (150.0 / 255.0) - 50.0 + +spec = do + -- Triggers that fire when the ctemp is too low or too high, + -- pass the current ctemp as an argument. + trigger "heaton" (ctemp < 18.0) [arg ctemp] + trigger "heatoff" (ctemp > 21.0) [arg ctemp] + +-- Compile the spec and produce a LaTeX file in the current directory with a +-- Tikz drawing of the spec. +main :: IO () +main = do + spec' <- reify spec + visualize 3 spec' "tikz" "." diff --git a/copilot-visualizer/src/Copilot/Visualize/Dynamic.hs b/copilot-visualizer/src/Copilot/Visualize/Dynamic.hs new file mode 100644 index 000000000..26c535a93 --- /dev/null +++ b/copilot-visualizer/src/Copilot/Visualize/Dynamic.hs @@ -0,0 +1,253 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | +-- Copyright : (c) NASA, 2024-2025 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Allow loading Copilot specifications from strings and modifying them live. +-- +-- An example of a spec that can be passed as argument to the live simulator +-- follows: +-- +-- @ +-- spec :: String +-- spec = unlines +-- [ "let temperature :: Stream Word8" +-- , " temperature = extern \"temperature\" (Just [0, 15, 20, 25, 30])" +-- , "" +-- , " ctemp :: Stream Float" +-- , " ctemp = (unsafeCast temperature) * (150.0 / 255.0) - 50.0" +-- , "" +-- , " trueFalse :: Stream Bool" +-- , " trueFalse = [True] ++ not trueFalse" +-- , "" +-- , "in do trigger \"heaton\" (temperature < 18) [arg ctemp, arg (constI16 1), arg trueFalse]" +-- , " trigger \"heatoff\" (temperature > 21) [arg (constI16 1), arg ctemp]" +-- , " observer \"temperature\" temperature" +-- , " observer \"temperature2\" (temperature + 1)" +-- ] +-- @ +-- +-- The imports are predefined. +module Copilot.Visualize.Dynamic + ( simInit + , simStep + , SimulationSettings(..) + , mkDefaultSimulationSettings + , SimData(..) + ) + where + +-- External imports +import qualified Language.Haskell.Interpreter as HI +import Prelude hiding (div, not, (++), (<), (>)) +import qualified Prelude + +-- External imports: Copilot +import qualified Copilot.Core as Core +import Copilot.Language hiding (interpret, typeOf) +import Language.Copilot hiding (interpret, typeOf) + +-- Internal imports +import Copilot.Visualize.TypedTrace + +-- | Simulation data. +data SimData = SimData + { simSteps :: Int -- ^ Number of steps to simulate. + , simSpec :: Core.Spec -- ^ Copilot spec to simulate. + , simString :: String -- ^ Textual representation of Copilot spec. + } + +-- | Initialize a simulation. +simInit :: SimulationSettings -> String -> IO SimData +simInit simulationSettings spec = do + -- Load the spec, and save it so that it doesn't need to be reloaded if it + -- doesn't change. + let numSteps = simulationSettingsInitialSteps simulationSettings + spec' <- readSpec simulationSettings spec + let simData = SimData numSteps spec' spec + return simData + +-- | Update the spec based on the input command received. +simStep :: SimulationSettings + -> SimData + -> (Command, String) + -> IO SimData +simStep _ simData (StepUp, _) = + pure simData { simSteps = simSteps simData + 1 } + +simStep _ simData (StepDown, _) = + pure simData { simSteps = simSteps simData + 1 } + +simStep simulationSettings simData (AddStream name expr, _) = do + let specN = concat [ simString simData, "\n", " ", completeExpr] + + completeExpr = concat [ "observer ", show name, " (", expr, ")" ] + + let trace = extractTrace $ simSpec simData + spec2 <- readSpec simulationSettings specN + let spec3 = updateWithTrace trace spec2 + + pure simData { simSpec = spec3, simString = specN } + +simStep simulationSettings simData (command, name) = do + spec' <- apply simulationSettings (simSpec simData) name command + pure simData { simSpec = spec' } + +-- | Settings used for a simulation. +data SimulationSettings = SimulationSettings + { simulationSettingsInitialSteps :: Int + , simulationSettingsImports :: [(String, Maybe String)] + } + +-- | Default settings that simulates 3 steps and provides default imports of +-- the main Copilot modules. +mkDefaultSimulationSettings :: SimulationSettings +mkDefaultSimulationSettings = + SimulationSettings + 3 + [ ("Control.Monad.Writer", Nothing) + , ("Copilot.Language", Nothing) + , ("Copilot.Language.Spec", Nothing) + , ("Data.Functor.Identity", Nothing) + , ("Language.Copilot", Nothing) + , ("Prelude", Just "P") + ] + +-- * Commands + +-- * Load specs from strings + +-- | Read a specification from a string and reify it. +readSpec :: SimulationSettings -> String -> IO Core.Spec +readSpec settings spec = do + r <- HI.runInterpreter (loadSpec settings spec) + case r of + Left err -> do putStrLn $ "Error: " Prelude.++ show err + error $ show err + Right s -> return s + +-- | Load a spec from a string, adding standard imports. +loadSpec :: SimulationSettings -> String -> HI.Interpreter Core.Spec +loadSpec settings spec = do + HI.setImportsQ (simulationSettingsImports settings) + spec' <- HI.interpret spec (HI.as :: Spec) + HI.liftIO $ reify spec' + +-- | Commands to apply to a running simulation. +data Command = StepUp + | StepDown + | Up Int + | Down Int + | AddStream String String + | Noop + deriving (Eq, Read, Show) + +-- | Apply a command to a simulation. +apply :: SimulationSettings -> Core.Spec -> String -> Command -> IO Core.Spec +apply settings spec _name (AddStream sName sExpr) = do + spec' <- addStream settings sName sExpr + -- TODO: I need to bring the streams from the other spec too, otherwise the + -- streams to include may refer to streams by ID that are in a different + -- scope. + let observers' = Core.specObservers spec' + observers = Core.specObservers spec + return $ spec { Core.specObservers = observers Prelude.++ observers' } + +apply _settings spec name command = pure $ spec + { Core.specStreams = + map (updateStream name command) (Core.specStreams spec) + , Core.specObservers = + map (updateObserver name command) (Core.specObservers spec) + , Core.specTriggers = + map (updateTrigger name command) (Core.specTriggers spec) + } + +-- | Apply a command to an observer. +updateObserver :: String -> Command -> Core.Observer -> Core.Observer +updateObserver name command (Core.Observer i e ty) = + Core.Observer i (updateExpr name command e) ty + +-- | Apply a command to a trigger. +updateTrigger :: String -> Command -> Core.Trigger -> Core.Trigger +updateTrigger name command (Core.Trigger i e es) = Core.Trigger i e' es' + where + e' = updateExpr name command e + es' = map (updateUExpr name command) es + +-- | Apply a command to a core expression. +updateExpr :: String -> Command -> Core.Expr a -> Core.Expr a +updateExpr name command expr = case expr of + Core.ExternVar ty nameE vs + | nameE Prelude.== name + -> Core.ExternVar ty nameE (updateValues vs ty command) + + | otherwise + -> expr + + Core.Op1 op expr1 -> + Core.Op1 op (updateExpr name command expr1) + + Core.Op2 op expr1 expr2 -> + Core.Op2 op (updateExpr name command expr1) (updateExpr name command expr2) + + Core.Op3 op expr1 expr2 expr3 -> + Core.Op3 + op + (updateExpr name command expr1) + (updateExpr name command expr2) + (updateExpr name command expr3) + + _ -> expr + +-- | Apply a command to an untyped expression that carries the information +-- about the type of the expression as a value (existential). +updateUExpr :: String -> Command -> Core.UExpr -> Core.UExpr +updateUExpr name cmd (Core.UExpr ty expr) = + Core.UExpr ty (updateExpr name cmd expr) + +-- | Apply a command to a stream. +updateStream :: String -> Command -> Core.Stream -> Core.Stream +updateStream name command (Core.Stream i buf expr ty) = + Core.Stream i buf (updateExpr name command expr) ty + +-- | Apply a command to a series of typed values, if any. +updateValues :: Maybe [a] -> Type a -> Command -> Maybe [a] +updateValues vsM ty command = + fmap (fmap (updateValue command ty) . zip [0..]) vsM + +-- | Apply a command to a typed value. +updateValue :: Command -> Type a -> (Int, a) -> a +updateValue (Up n) Core.Bool (ix, a) = + if n Prelude.== ix then Prelude.not a else a +updateValue (Down n) Core.Bool (ix, a) = + if n Prelude.== ix then Prelude.not a else a +updateValue (Up n) Core.Word8 (ix, a) = + if n Prelude.== ix then a + 1 else a +updateValue (Down n) Core.Word8 (ix, a) = + if n Prelude.== ix then a - 1 else a +updateValue _ _ (_, a) = a + +-- * Sample spec + +-- | Produce a specification from the expression for a stream. +addStream :: SimulationSettings -> String -> String -> IO Core.Spec +addStream settings name expr = do + r <- HI.runInterpreter (addStream' settings name expr) + case r of + Left err -> do putStrLn $ "Error: " Prelude.++ show err + error $ show err + Right spec -> return spec + +-- | Produce a specification from the expression for a stream, in an +-- interpreter context. +-- +-- Observe that Interpreter () is an alias for InterpreterT IO () +addStream' :: SimulationSettings -> String -> String -> HI.Interpreter Core.Spec +addStream' settings name expr = do + HI.setImportsQ (simulationSettingsImports settings) + let completeExpr = concat [ "observer ", show name, " (", expr, ")" ] + + spec <- HI.interpret completeExpr (HI.as :: Spec) + HI.liftIO $ reify spec diff --git a/copilot-visualizer/src/Copilot/Visualize/Live.hs b/copilot-visualizer/src/Copilot/Visualize/Live.hs new file mode 100644 index 000000000..973cd2feb --- /dev/null +++ b/copilot-visualizer/src/Copilot/Visualize/Live.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +-- | +-- Copyright : (c) NASA, 2024-2025 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Run a Copilot simulation live and allow interacting with it using a +-- websocket. +-- +-- This visualizer enables adding new streams to a visualization. To do so, the +-- visualizer needs access to the original spec, and needs to be able to +-- interpret new expressions in the same context as the prior expressions. +-- +-- An example of a spec that can be passed as argument to the visualizer +-- follows: +-- +-- @ +-- spec :: String +-- spec = unlines +-- [ "let temperature :: Stream Word8" +-- , " temperature = extern \"temperature\" (Just [0, 15, 20, 25, 30])" +-- , "" +-- , " ctemp :: Stream Float" +-- , " ctemp = (unsafeCast temperature) * (150.0 / 255.0) - 50.0" +-- , "" +-- , " trueFalse :: Stream Bool" +-- , " trueFalse = [True] ++ not trueFalse" +-- , "" +-- , "in do trigger \"heaton\" (temperature < 18) [arg ctemp, arg (constI16 1), arg trueFalse]" +-- , " trigger \"heatoff\" (temperature > 21) [arg (constI16 1), arg ctemp]" +-- , " observer \"temperature\" temperature" +-- , " observer \"temperature2\" (temperature + 1)" +-- ] +-- @ +-- +-- The imports are predefined. +module Copilot.Visualize.Live + ( visualize + , visualizeWith + , VisualSettings(..) + , mkDefaultVisualSettings + , SimulationSettings(..) + , mkDefaultSimulationSettings + ) + where + +-- External imports +import Control.Exception (SomeException (..), handle) +import Data.Aeson (ToJSON (..), encode) +import qualified Data.Text as T +import qualified Network.WebSockets as WS +import Prelude hiding (div, not, (++), (<), (>)) +import qualified Prelude +import Text.Read (readMaybe) + +-- External imports: Copilot +import qualified Copilot.Core as Core +import Copilot.Interpret.Eval (ShowType (Haskell), eval) +import Copilot.Language hiding (interpret, typeOf) +import Copilot.Visualize.UntypedTrace (AppData, makeTraceEval) + +-- Internal imports +import Copilot.Visualize.Dynamic + +-- | Start a simulation for an input spec, listening for commands and +-- communicating the status via a websocket. +visualize :: String -> IO () +visualize = visualizeWith mkDefaultVisualSettings + +-- | Start a simulation for an input spec, listening for commands and +-- communicating the status via a websocket. +visualizeWith :: VisualSettings -> String -> IO () +visualizeWith settings spec = do + putStrLn $ concat + [ "WebSocket server starting on port " + , show (visualSettingsPort settings) + , "..." + ] + WS.runServer + (visualSettingsHost settings) + (visualSettingsPort settings) + (app settings spec) + +-- | Settings used to customize the simulation and interaction. +data VisualSettings = VisualSettings + { visualSettingsHost :: String + -- ^ Host interface to listen to. Use + -- "127.0.0.1" to listen at localhost. + + , visualSettingsPort :: Int + -- ^ Port to listen to. + + , visualSettingsSimulation :: SimulationSettings + -- ^ Settings for the simulation. + } + +-- | Default settings that simulates 3 steps and listens on localhost at port +-- 9160. +mkDefaultVisualSettings :: VisualSettings +mkDefaultVisualSettings = VisualSettings + { visualSettingsHost = "127.0.0.1" + , visualSettingsPort = 9160 + , visualSettingsSimulation = mkDefaultSimulationSettings + } + +-- * Server + +-- | Server application using web sockets. +app :: VisualSettings -> String -> WS.ServerApp +app settings spec pending = do + conn <- WS.acceptRequest pending + WS.withPingThread conn 30 (return ()) $ appInit settings spec conn + +-- | Initialize the backend. +appInit :: VisualSettings -> String -> WS.Connection -> IO () +appInit settings spec conn = handle appException $ do + -- Initialize the simulation. + simData <- simInit (visualSettingsSimulation settings) spec + + -- Communicate the current values of the trace, in JSON, via the web + -- socket. + let appData = mkAppData (simSteps simData) (simSpec simData) + let samples = encode $ toJSON appData + WS.sendTextData conn samples + + -- Start the application loop. + appMainLoop settings conn simData + + where + + appException :: SomeException -> IO () + appException e = do + putStrLn $ "Error:" Prelude.++ show e + error $ show e + +-- | Run the main application, repeatedly reading commands from a web socket +-- and returning results via the same web socket. +appMainLoop :: VisualSettings + -> WS.Connection + -> SimData + -> IO () +appMainLoop settings conn simData = do + -- Read a command from the web socket. + cmdM <- readMaybe . T.unpack <$> WS.receiveData conn + + -- Run a simulation step, if a command has been received. + let simulationSettings = visualSettingsSimulation settings + simData' <- maybe (pure simData) (simStep simulationSettings simData) cmdM + + -- Communicate the current values of the trace, in JSON, via the web socket. + let appData = mkAppData (simSteps simData') (simSpec simData') + samples = encode $ toJSON appData + WS.sendTextData conn samples + + appMainLoop settings conn simData' + +-- * Auxiliary functions + +-- | Obtain the trace data from a Copilot spec for a number of steps. +mkAppData :: Int -> Core.Spec -> AppData +mkAppData numSteps spec' = + makeTraceEval numSteps spec' (eval Haskell numSteps spec') diff --git a/copilot-visualizer/src/Copilot/Visualize/Static.hs b/copilot-visualizer/src/Copilot/Visualize/Static.hs new file mode 100644 index 000000000..bfe5f34a8 --- /dev/null +++ b/copilot-visualizer/src/Copilot/Visualize/Static.hs @@ -0,0 +1,36 @@ +-- | +-- Copyright : (c) NASA, 2024-2025 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Produce a visual representation of a Copilot specification. +module Copilot.Visualize.Static + ( visualize + ) + where + +-- External imports +import Data.Aeson (ToJSON (..)) +import System.Directory.Extra (copyTemplate) +import System.FilePath (()) + +-- External imports: Copilot +import Copilot.Core (Spec (..)) +import Copilot.Interpret.Eval (ShowType (Haskell), eval) + +-- Internal imports +import Copilot.Visualize.UntypedTrace (makeTraceEval) +import Paths_copilot_visualizer (getDataDir) + +-- | Produce a visual representation of a Copilot specification, for a given +-- number of steps, using a template. +visualize :: Int -- ^ Number of steps to interpret. + -> Spec -- ^ Specification to interpret. + -> String -- ^ Base used to expand the static file (i.e., @"tikz"@, + -- @"static_html"@). + -> FilePath + -> IO () +visualize k spec base target = do + dir <- getDataDir + let f = dir "data" base + let subs = toJSON $ makeTraceEval k spec $ eval Haskell k spec + copyTemplate f subs target diff --git a/copilot-visualizer/src/Copilot/Visualize/TypedTrace.hs b/copilot-visualizer/src/Copilot/Visualize/TypedTrace.hs new file mode 100644 index 000000000..901f42820 --- /dev/null +++ b/copilot-visualizer/src/Copilot/Visualize/TypedTrace.hs @@ -0,0 +1,158 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | +-- Copyright : (c) NASA, 2024-2025 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Read and modify traces of specifications. +-- +-- In the context of this module, a trace refers only to the values of +-- externs, since the state of a spec can be reproduced if the values of +-- externs are known. +module Copilot.Visualize.TypedTrace + ( extractTrace + , updateWithTrace + , Trace(..) + , UValues(..) + ) + where + +-- External imports +import Data.List hiding ((++)) +import Data.Maybe (fromMaybe) +import qualified Data.Type.Equality as DE +import Data.Typeable (Typeable) +import Prelude hiding (div, not, (++), (<), (>)) + +-- External imports: Copilot +import qualified Copilot.Core as Core +import Language.Copilot hiding (interpret, typeOf) + +-- | Map stream names to their values. +newtype Trace = Trace + { traceMap :: [ (String, UValues) ] + } + +-- | Existentially typed list of values of a stream. +data UValues = forall a . Typeable a => UValues + { uvType :: Core.Type a + , uvValues :: [ a ] + } + +-- | Extract a trace from a core specification. +extractTrace :: Core.Spec -> Trace +extractTrace spec = Trace $ concat $ concat + [ fmap extractTraceStream (Core.specStreams spec) + , fmap extractTraceObserver (Core.specObservers spec) + , fmap extractTraceTrigger (Core.specTriggers spec) + ] + +-- | Extract the values of a core 'Stream'. +extractTraceStream :: Core.Stream -> [ (String, UValues) ] +extractTraceStream (Core.Stream _id _buf expr _ty) = + extractTraceExpr expr + +-- | Extract the values of a core 'Observer'. +extractTraceObserver :: Core.Observer -> [ (String, UValues) ] +extractTraceObserver (Core.Observer _name expr _ty) = + extractTraceExpr expr + +-- | Extract the values of a core 'Trigger'. +extractTraceTrigger :: Core.Trigger -> [ (String, UValues) ] +extractTraceTrigger (Core.Trigger _name expr args) = concat $ + extractTraceExpr expr + : fmap extractTraceUExpr args + +-- | Extract the values of a core 'Expr'. +extractTraceExpr :: Core.Expr a -> [ (String, UValues) ] +extractTraceExpr (Core.Local _ _ _ expr1 expr2) = concat + [ extractTraceExpr expr1 + , extractTraceExpr expr2 + ] +extractTraceExpr (Core.ExternVar ty name values) = + [ (name, UValues ty (fromMaybe [] values)) ] +extractTraceExpr (Core.Op1 _op expr) = + extractTraceExpr expr +extractTraceExpr (Core.Op2 _op expr1 expr2) = concat + [ extractTraceExpr expr1 + , extractTraceExpr expr2 + ] +extractTraceExpr (Core.Op3 _op expr1 expr2 expr3) = concat + [ extractTraceExpr expr1 + , extractTraceExpr expr2 + , extractTraceExpr expr3 + ] +extractTraceExpr (Core.Label _ty _lbl expr) = + extractTraceExpr expr +extractTraceExpr _ = [] + +-- | Extract the values of a core 'UExpr'. +extractTraceUExpr :: Core.UExpr -> [ (String, UValues) ] +extractTraceUExpr (Core.UExpr ty expr) = extractTraceExpr expr + +-- | Update externs in a spec. +updateWithTrace :: Trace -> Core.Spec -> Core.Spec +updateWithTrace trace spec = spec + { Core.specStreams = + fmap (updateWithTraceStream trace) (Core.specStreams spec) + , Core.specObservers = + fmap (updateWithTraceObserver trace) (Core.specObservers spec) + , Core.specTriggers = + fmap (updateWithTraceTrigger trace) (Core.specTriggers spec) + } + +-- | Update the values of a 'Stream' based on an input trace. +updateWithTraceStream :: Trace -> Core.Stream -> Core.Stream +updateWithTraceStream trace (Core.Stream ident buf expr ty) = + Core.Stream ident buf (updateWithTraceExpr trace expr) ty + +-- | Update the values of an 'Observer' based on an input trace. +updateWithTraceObserver :: Trace -> Core.Observer -> Core.Observer +updateWithTraceObserver trace (Core.Observer name expr ty) = + Core.Observer name (updateWithTraceExpr trace expr) ty + +-- | Update the values of a 'Trigger' based on an input trace. +updateWithTraceTrigger :: Trace -> Core.Trigger -> Core.Trigger +updateWithTraceTrigger trace (Core.Trigger name expr args) = + Core.Trigger + name + (updateWithTraceExpr trace expr) + (fmap (updateWithTraceUExpr trace) args) + +-- | Update the values of an 'Expr' based on an input trace. +updateWithTraceExpr :: Trace -> Core.Expr a -> Core.Expr a +updateWithTraceExpr trace (Core.Local ty1 ty2 name expr1 expr2) = + Core.Local + ty1 + ty2 + name + (updateWithTraceExpr trace expr1) + (updateWithTraceExpr trace expr2) +updateWithTraceExpr trace (Core.ExternVar ty name values) = + Core.ExternVar ty name values' + where + values' | Just (UValues ty2 vals) <- lookup name (traceMap trace) + , Just DE.Refl <- DE.testEquality ty ty2 + = Just vals + | otherwise + = values +updateWithTraceExpr trace (Core.Op1 op expr) = + Core.Op1 op (updateWithTraceExpr trace expr) +updateWithTraceExpr trace (Core.Op2 op expr1 expr2) = + Core.Op2 op + (updateWithTraceExpr trace expr1) + (updateWithTraceExpr trace expr2) +updateWithTraceExpr trace (Core.Op3 op expr1 expr2 expr3) = + Core.Op3 op + (updateWithTraceExpr trace expr1) + (updateWithTraceExpr trace expr2) + (updateWithTraceExpr trace expr3) +updateWithTraceExpr trace (Core.Label ty lbl expr) = + Core.Label ty lbl (updateWithTraceExpr trace expr) +updateWithTraceExpr trace x = x + +-- | Update the values of a 'UExpr' based on an input trace. +updateWithTraceUExpr :: Trace -> Core.UExpr -> Core.UExpr +updateWithTraceUExpr trace (Core.UExpr ty expr) = + Core.UExpr ty (updateWithTraceExpr trace expr) diff --git a/copilot-visualizer/src/Copilot/Visualize/UntypedTrace.hs b/copilot-visualizer/src/Copilot/Visualize/UntypedTrace.hs new file mode 100644 index 000000000..6bbc8365d --- /dev/null +++ b/copilot-visualizer/src/Copilot/Visualize/UntypedTrace.hs @@ -0,0 +1,176 @@ +{-# LANGUAGE DeriveGeneric #-} +-- | +-- Copyright : (c) NASA, 2024-2025 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Abstract representation of a trace as a series named streams with their +-- values, together with functions needed to convert a 'Spec' into a trace. +-- +-- This trace is flat (untyped). Information about the types is captured +-- using boolean flags. This kind of trace is most useful to render values +-- on in logicless templates, since they don't have the capability to examine +-- the Haskell types. +module Copilot.Visualize.UntypedTrace + ( AppData(..) + , Trace + , TraceElem(..) + , TraceValue(..) + , makeTraceEval + ) + where + +-- External imports +import Data.Aeson (ToJSON (..)) +import Data.Bifunctor (second) +import Data.List (find, transpose) +import Data.Maybe (isJust, isNothing) +import GHC.Generics (Generic) +import Text.Printf (printf) +import Text.Read (readMaybe) + +-- External imports: Copilot +import Copilot.Core (Spec (..), triggerArgs, triggerName) +import Copilot.Interpret.Eval (ExecTrace, Output, interpObservers, + interpTriggers) + +-- * Abstract representation of a trace + +-- | Data related to a specification. +data AppData = AppData + { adTraceElems :: Trace + , adLastSample :: Int + } + deriving (Generic, Show) + +instance ToJSON AppData + +-- | A trace, defined by a list of trace elements, each defining a stream (in +-- an abstract sense). +type Trace = [ TraceElem ] + +-- | An element of a trace, or stream, with a name, its values, and information +-- about its type, needed to render it correctly. +data TraceElem = TraceElem + { teName :: String + , teIsBoolean :: Bool + , teIsFloat :: Bool + , teValues :: [ TraceValue ] + } + deriving (Generic, Show) + +instance ToJSON TraceElem + +-- | An individual sample, with a value and an indication of whether the sample +-- exists. +data TraceValue = TraceValue + { tvValue :: String + , tvIsEmpty :: Bool + } + deriving (Generic, Show) + +instance ToJSON TraceValue + +-- | Generate an abstract representation of a trace of a specification +-- interpreted for a given number of steps. +makeTraceEval :: Int + -> Spec + -> ExecTrace + -> AppData +makeTraceEval k spec e = + AppData (observerTEs ++ triggerTEs) (k - 1) + where + observerTEs = map mkTraceElem (interpObserversOpt spec e) + triggerTEs = map mkTraceElem (interpTriggersWithArgs spec e) + +-- | Generate an element of a trace from a stream name and its values over +-- time. +mkTraceElem :: (String, [Maybe Output]) -> TraceElem +mkTraceElem (name, outputs) = TraceElem + { teName = name + , teValues = values + , teIsBoolean = any (isBoolean . tvValue) values + , teIsFloat = any (isFloat . tvValue) values + } + where + values = map mkTraceValue outputs + +-- | Generate an individual value (sample) of a trace. +mkTraceValue :: Maybe Output -> TraceValue +mkTraceValue x = TraceValue (showValue x) (isNothing x) + +-- * Auxiliary functions + +-- | Compute the list of values associated to observers. +interpObserversOpt :: Spec -> ExecTrace -> [(String, [Maybe Output])] +interpObserversOpt _spec = map (second (map Just)) . interpObservers + +-- | Compute the list of values associated to triggers and their arguments. +-- +-- For each trigger, we first include the values of the trigger itself, and +-- then the values of the arguments to the trigger. +interpTriggersWithArgs :: Spec -> ExecTrace -> [(String, [Maybe Output])] +interpTriggersWithArgs spec = concatMap triggerOutputs . interpTriggers + where + -- This function adds one more output for the trigger itself. + triggerOutputs :: (String, [Maybe [Output]]) -> [(String, [Maybe Output])] + triggerOutputs (triggerName, triggerArgs) = + (triggerName, triggerValues) : zip argNames argValues + where + triggerValues = map triggerValue triggerArgs + + -- Value for the trigger at a given time, based on the values of its + -- arguments. + triggerValue :: Maybe [Output] -> Maybe Output + triggerValue Nothing = Just "false" + triggerValue (Just _) = Just "true" + + -- Names and values for the arguments. + argNames = map (\ix -> triggerName ++ "Arg" ++ show ix) [0..] + argValues = transpose (transMaybes numArgs triggerArgs) + numArgs = triggerNumArgs spec triggerName + +-- Number of arguments to a trigger in a spec. +-- +-- PRE: name exists as a trigger in spec. +triggerNumArgs :: Spec -> String -> Int +triggerNumArgs spec name = + case find (\t -> triggerName t == name) (specTriggers spec) of + Nothing -> error "Couldn't find given trigger in spec, should never occur!" + Just t -> length $ triggerArgs t + +-- | True if the input value denotes a boolean value. +isBoolean :: String -> Bool +isBoolean "true" = True +isBoolean "false" = True +isBoolean _ = False + +-- | True if the input value denotes a floating point value. +isFloat :: String -> Bool +isFloat s = isJust asInt || isJust asFloat + where + asInt :: Maybe Int + asInt = readMaybe s + + asFloat :: Maybe Float + asFloat = readMaybe s + +-- | Show a value. +showValue :: Maybe Output -> String +showValue Nothing = "--" +showValue (Just s) | isFloat s = showValueFloat s + | otherwise = s + +-- | Show a floating point value. +showValueFloat :: Output -> String +showValueFloat = formatFloat . read + where + formatFloat :: Double -> String + formatFloat = printf "%.2g" + +-- | Given a list of maybe lists of known length, this function creates a list +-- of lists, pushing the Maybe's inside. +transMaybes :: Int -> [Maybe [a]] -> [[Maybe a]] +transMaybes = map . transMaybes' + where + transMaybes' argsLength (Just xs) = map Just xs + transMaybes' argsLength Nothing = replicate argsLength Nothing diff --git a/copilot/CHANGELOG b/copilot/CHANGELOG index b1293dca1..8b691705e 100644 --- a/copilot/CHANGELOG +++ b/copilot/CHANGELOG @@ -1,8 +1,147 @@ -2021-09-16 +2026-11-07 + * Version bump (4.8.2). (#792) + * Adjust Travis CI script to flag presence of tabs as an error. (#774) + * Adjust Travis CI script to flag trailing space as an error. (#777) + * Update README to correct typos and improve readability. (#779) + * Replace Travis CI with Github Actions. (#790) + +2026-09-07 + * Version bump (4.8.1). (#760) + * Disable secure mode in Cabal in Travis CI. (#753) + +2026-07-07 + * Version bump (4.8). (#745) + +2026-05-07 + * Version bump (4.7.1). (#730) + +2026-03-07 + * Version bump (4.7). (#714) + +2026-01-07 + * Version bump (4.6.1). (#705) + * Relax version constraint on optparse-applicative. (#603) + +2025-11-07 + * Version bump (4.6). (#679) + +2025-09-07 + * Version bump (4.5.1). (#666) + * Add hello world example for FPGA. (#657) + +2025-07-07 + * Version bump (4.5). (#642) + +2025-05-07 + * Version bump (4.4). (#618) + * Update build status badge URL. (#612) + +2025-03-07 + * Version bump (4.3). (#604) + * Include missing dependencies in installation instructions. (#591) + * Update version of GHC in README. (#590) + * Add example of how to use proveWithCounterExample. (#589) + * List all Copilot packages in installation command in README. (#597) + +2025-01-07 + * Version bump (4.2). (#577) + * Bump upper version constraint on filepath. (#570) + * Update struct examples to use generic method implementations. (#564) + +2024-11-07 + * Version bump (4.1). (#561) + * Update contribution guidelines. (#476) + * Update README with missing publications. (#544) + * Make the what4-propositional example's comments match results. (#535) + * Add example describing how to implement updateField. (#525) + * Standardize changelog format. (#550) + * Add installation instructions for Fedora 40 and up. (#542) + +2024-09-07 + * Version bump (4.0). (#532) + * Update example to demonstrate struct update support. (#524) + * Update example to demonstrate array update support. (#36) + +2024-07-07 + * Version bump (3.20). (#522) + * Update README to reflect support for GHC 9.8. (#518) + +2024-05-07 + * Version bump (3.19.1). (#512) + +2024-03-07 + * Version bump (3.19). (#504) + +2024-01-07 + * Version bump (3.18.1). (#493) + * Update README to reflect support for GHC 9.6. (#491) + +2024-01-07 + * Version bump (3.18). (#487) + * Enable tests for copilot-theorem in CI script. (#474) + * Enable tests for copilot-libraries in CI script. (#475) + * Replace uses of forall with forAll. (#470) + * Update CI job to check for MISRA compliance with cppcheck. (#472) + * Relax version constraint on optparse-applicative. (#488) + +2023-11-07 + * Version bump (3.17). (#466) + * Replace uses of deprecated functions. (#457) + +2023-11-03 + * Fix typo in README. (#459) + +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) + * Replace import of Copilot.Language.prettyPrint. (#412) + * Re-structure README. (#415) + * Update README to reflect support for GHC 9.4. (#423) + +2023-01-07 + * Version bump (3.13). (#406) + +2022-11-07 + * Version bump (3.12). (#389) + +2022-09-07 + * Version bump (3.11). (#376) + +2022-07-07 + * Version bump (3.10). (#356) + * Run tests in CI. (#329) + * Remove duplicated compiler option. (#328) + * Fix typos in README and Heater example. (#352) + * Relax version bounds of dependencies. (#335) + * Update repo info in cabal file. (#333) + +2022-05-06 + * Version bump (3.9). (#320) + * Compliance with style guide (partial). (#316) + * Add support for GHC 9.0. (#294) + +2022-03-07 + * Version bump (3.8). (#298) + * Mark package as uncurated to avoid modification. (#288) + +2022-01-07 + * Version bump (3.7). (#287) + * Add example with nested structs. (#275) + +2021-11-07 + * Version bump (3.6). (#264) * Fix missing dependency in example executable. (#252) * Fix outdated/broken links. (#252) * Update installation instructions in README to - match new repo structure. (#248) + match new repo structure. (#248) 2021-08-19 * Version bump (3.5). (#247) @@ -37,11 +176,11 @@ 2020-12-06 * Update optparse-applicative dependency version for newer base - versions. (#61). - * Add Ivan Perez as co-maintainer (#51). - * Update description in cabal file to match copilot-core (#50). - -2019-11-22 Ivan Perez - * Version bump (3.1). - * Update multiple examples (#41). - * Update instructions to match new repositry name (#45). + versions. (#61) + * Add Ivan Perez as co-maintainer. (#51) + * Update description in cabal file to match copilot-core. (#50) + +2019-11-22 + * Version bump (3.1). (#46) + * Update multiple examples. (#41) + * Update instructions to match new repositry name. (#45) diff --git a/copilot/README.md b/copilot/README.md index 3c829c34b..63a2459ef 100644 --- a/copilot/README.md +++ b/copilot/README.md @@ -1,89 +1,184 @@ -# Copilot: Stream DSL for hard real-time runtime verification +
-[![Build Status](https://travis-ci.com/Copilot-Language/copilot.svg?branch=master)](https://app.travis-ci.com/github/Copilot-Language/copilot) -[![Version on Hackage](https://img.shields.io/hackage/v/copilot.svg)](https://hackage.haskell.org/package/copilot) +# Copilot -Copilot is a runtime verification framework written in Haskell. It allows the -user to write programs in a simple but powerful way using a stream-based -approach. +[![Build Status](https://github.com/Copilot-Language/copilot/actions/workflows/build.yml/badge.svg?branch=master)](https://github.com/Copilot-Language/copilot/actions/workflows/build.yml) +[![Version on Hackage](https://img.shields.io/hackage/v/copilot.svg)](https://hackage.haskell.org/package/copilot) +Copilot is a runtime verification framework for hard real-time systems. Programs can be interpreted for testing, or translated into C99 code to be -incorporated in a project or as a standalone application. The C99 backend -output is constant in memory and time, making it suitable for systems with hard -realtime requirements. +incorporated into a project or standalone application. The C99 code generated +is constant in memory and time, making it suitable for systems with hard +real-time requirements. +[Installation](#installation) • +[Examples](#examples) • +[Related projects](#related-projects) • +[Documentation](#documentation) • +[Contributions](#contributions) • +[Acknowledgements](#acknowledgements) -## Using Copilot -Assuming you have GHC and cabal already installed (see [Haskell -Platform](http://hackage.haskell.org/platform/) or -[ghcup](https://www.haskell.org/ghcup/)), there are several ways to use -Copilot: +
-* Adding Copilot to your project +## Features - Copilot is available from - [Hackage](https://hackage.haskell.org/package/copilot). Adding `copilot` - to your project's cabal file should be enough to get going. +- Write simple, high-level specifications using a stream-based language. -* Adding Copilot to the default GHC environment +- Produce hard real-time C99 runtime monitors that run in constant memory and time. - ```bash - cabal v2-install --lib copilot - ``` +- Catch errors in specifications early using an expressive static type system. - After which Copilot will be available from ghci. +- Prove properties about specifications using theorem proving extensions. -* Launching a repl with Copilot +- Interpret specifications for testing and debugging purposes. - Another quick solution is to cabal to launch a repl with Copilot - available. +- Obtain proofs of correctness of the generated code. - ```bash - cabal v2-repl --build-depends copilot - ``` +## Table of Contents - Cabal will download and build Copilot only to make it available in the - launched repl. The global GHC environment will not be affected. +- [Installation](#installation) + - [Linux installation](#linux-installation) + - [Mac installation](#mac-installation) + - [Troubleshooting](#troubleshooting) +- [Examples](#examples) +- [Related projects](#related-projects) +- [Documentation](#documentation) + - [API documentation and tutorials](#api-documentation-and-tutorials) + - [Publications](#publications) + - [Website](#website) +- [Contributions](#contributions) +- [Acknowledgements](#acknowledgements) + - [The Copilot team](#the-copilot-team) + - [Institutional support](#institutional-support) -* Building from source (typically done for development): +# Installation +[(Back to top)](#table-of-contents) - ```bash - git clone https://github.com/Copilot-Language/copilot.git - cd copilot - ``` +## Linux installation +[(Back to top)](#table-of-contents) - Compiling can either be done in a Nix-style build, or a traditional one: +### Debian Bookworm / Ubuntu 23.04 - _Nix-Style build (Cabal >= 2.x)_ +On Debian Bookworm / Ubuntu 23.04 or newer, Copilot can be installed directly +from the package repositories with: - ```bash - cabal build copilot-*/ # For Cabal 3.x - cabal v2-build copilot-*/ # For Cabal 2.x - ``` +```sh +$ sudo apt-get install libghc-copilot-dev +``` - _Traditional build (Cabal 1.x)_ - ```bash - cd copilot - cabal install --dependencies-only . ../copilot-*/ - cabal install ../copilot-*/ - cabal build - ``` +To test that Copilot is available, execute the following: +```sh +$ ghci <<< 'import Language.Copilot' +``` -Note there is a TravisCI build (linked to at the top of this README) if you -have trouble building/installing. +It should end with a line like the following and not print any error messages: +```sh +ghci> ghci> Leaving GHCi. +``` +### Fedora 40 + +On Fedora 40 or newer, Copilot can be installed directly from the package +repositories with: + +```sh +$ sudo dnf install ghc-copilot-devel +``` + +To test that Copilot is available, execute the following: +```sh +$ ghci <<< 'import Language.Copilot' +``` -## Example -Here follows a simple example of a heating system. Other examples can be found +It should end with a line like the following and not print any error messages: +```sh +ghci> ghci> Leaving GHCi. +``` + +### Other Linux distributions + +On other Linux distributions or older Debian-based distributions, to use +Copilot, you must install a Haskell compiler (GHC) and the package manager +Cabal. We currently support all versions of GHC from 8.6.5 to modern versions +(9.10 as of this writing). You can install the toolchain using +[ghcup](https://www.haskell.org/ghcup/) or, if you are on Debian/Ubuntu, +you can use `apt-get` to install all dependencies as follows: + +```sh +$ sudo apt-get install ghc cabal-install alex happy pkg-config libz-dev +``` + +Once the compiler is installed, install Copilot from +[Hackage](https://hackage.haskell.org/package/copilot) with: + +```sh +cabal v2-install --lib copilot copilot-core copilot-c99 copilot-language \ + copilot-theorem copilot-libraries copilot-interpreter copilot-prettyprinter +``` + +To test that Copilot is available, execute the following: +```sh +$ ghci <<< 'import Language.Copilot' +``` + +It should end with a line like the following and not print any error messages: +```sh +ghci> ghci> Leaving GHCi. +``` + +## Mac installation +[(Back to top)](#table-of-contents) + +To use Copilot, you must have a Haskell compiler (GHC) and the package manager +Cabal. We currently support all versions of GHC from 8.6.5 to modern versions +(9.6 as of this writing). You can install the toolchain using +[ghcup](https://www.haskell.org/ghcup/), as well as with Homebrew: + +```sh +$ brew install ghc cabal-install +``` + +Once the compiler is installed, install Copilot from +[Hackage](https://hackage.haskell.org/package/copilot) with: + +```sh +$ cabal v2-install --lib copilot copilot-core copilot-c99 copilot-language \ + copilot-theorem copilot-libraries copilot-interpreter copilot-prettyprinter +``` + +To test that Copilot is available, execute the following: +```sh +$ ghci <<< 'import Language.Copilot' +``` + +It should end with a line like the following and not print any error messages: +```sh +ghci> ghci> Leaving GHCi. +``` + +## Troubleshooting +[(Back to top)](#table-of-contents) + +Feel free to open an issue if you are unable to install Copilot following these +instructions. + +There is a Travis CI file at the root of the repository that may help with +troubleshooting the installation. Our issues often include comments with +Dockerfiles listing the steps necessary to install Copilot from scratch. + +## Examples +[(Back to top)](#table-of-contents) + +Here follows a simple example of a heating system. More examples can be found in the [examples directory](https://github.com/Copilot-Language/copilot/tree/master/copilot/examples) of the main repository. ```haskell --- This is a simple example with basic usage. It implements a simple home --- heating system: It heats when temp gets too low, and stops when it is high --- enough. It read temperature as a byte (range -50C to 100C) and translates --- this to Celcius. +-- This example implements a simple home heating system. The system heats +-- when the temperature gets too low, and stops when it is high enough. It +-- reads the temperature as a byte (range -50C to 100C) and translates it to +-- Celsius. module Heater where @@ -92,12 +187,13 @@ import Copilot.Compile.C99 import Prelude hiding ((>), (<), div) --- External temperature as a byte, range of -50C to 100C +-- External temperature as a byte, ranging from -50C to 100C. temp :: Stream Word8 temp = extern "temperature" Nothing --- Calculate temperature in Celcius. --- We need to cast the Word8 to a Float. Note that it is an unsafeCast, as there +-- Temperature in Celsius. +-- +-- We need to cast the Word8 to a Float. This is an unsafeCast, as there -- is no direct relation between Word8 and Float. ctemp :: Stream Float ctemp = (unsafeCast temp) * (150.0 / 255.0) - 50.0 @@ -112,83 +208,188 @@ spec = do main = reify spec >>= compile "heater" ``` -The examples located in the `examples/` directory can be run from the root of -the project. Each example has a name. As a rule of thumb, the examples are -named after the filename (without extension) in lowercase letters, and -directory seperators replaced with a '-'. For example: +If you save this example in a file `Heater.hs` and run: +```sh +$ runhaskell Heater.hs +``` +it will produce the files `heater.c`, `heater.h` and `heater_types.h`, +containing, respectively, the implementation of the monitors, the interface, +and a declaration of any types declared in the specification (empty in this +case). + +If you clone the repository, the examples in the `examples/` directory can be +run from the root of the project. As a rule of thumb, each example is named +after the filename (without extension) in lowercase letters, and directory +separators replaced with a '-'. For example: ```sh -cabal run addmult -f examples -cabal run counter -f examples -cabal run what4-arithmetic -f examples +$ cabal run addmult -f examples +$ cabal run counter -f examples +$ cabal run what4-arithmetic -f examples ``` -## Contributions -Feel free to open new issues and send pull requests. +# Related projects +[(Back to top)](#table-of-contents) + +_Disclaimer: The following projects are not part of Copilot. Their mention here +does not constitute any form of endorsement._ + +- [Ogma](https://github.com/nasa/ogma) is a NASA tool to facilitate the + integration of safe runtime monitors into other systems, including those + built using NASA's Core Flight System or the Robot Operating System (ROS 2). -In order to contribute to Copilot, please use the following steps which will -make the process of evaluating and including your changes much easier: +- [arduino-copilot](https://hackage.haskell.org/package/arduino-copilot) + facilitates building Copilot applications that run on Arduino. -* Create an issue for every individual change or problem with Copilot. Document - the issue well. +- [sketch-frp-copilot](https://hackage.haskell.org/package/sketch-frp-copilot) + extends Copilot with an FRP-like interface. -* Always comment on the issues you are addressing in every commit. Be - descriptive, and use the syntax `#` so that we can track - changes and issues easily. +- [zephyr-copilot](https://hackage.haskell.org/package/zephyr-copilot) + facilitates building Copilot applications that run on boards supported by the + Zephyr project. -* Every commit should mention one issue and, ideally, only one. +# Documentation +[(Back to top)](#table-of-contents) -* Do not send a PR or commit that addresses multiple problems, unless they are - related and cannot be separated. +## API documentation and tutorials +[(Back to top)](#table-of-contents) -* Do not commit to master directly, except for branch merges. Make sure you - always merge onto master using `--no-ff` so that we can tell that features - were addressed separately, completed, tested, and then merged. If you are a - Copilot developer, create a branch for every issue you are addressing, complete - it, and then merge onto master. Document every commit in every branch, - including the last merge commit, stating the issues it addresses or closes. +A tutorial on Copilot can be found +[here](https://copilot-language.github.io/downloads/copilot_tutorial.pdf). -This process is similar to [Git -Flow](http://nvie.com/posts/a-successful-git-branching-model/). The equivalent -of Git Flow's master branch is our latest tag, and the equivalent of Git Flow's -develop branch is our master. +The API is documented throughout the different libraries and published on +Hackage: +- [copilot](https://hackage.haskell.org/package/copilot) +- [copilot-c99](https://hackage.haskell.org/package/copilot-c99) +- [copilot-core](https://hackage.haskell.org/package/copilot-core) +- [copilot-interpreter](https://hackage.haskell.org/package/copilot-interpreter) +- [copilot-language](https://hackage.haskell.org/package/copilot-language) +- [copilot-libraries](https://hackage.haskell.org/package/copilot-libraries) +- [copilot-prettyprinter](https://hackage.haskell.org/package/copilot-prettyprinter) +- [copilot-theorem](https://hackage.haskell.org/package/copilot-theorem) -## Further information -For further information, including documentation and a tutorial, please visit -the Copilot website: +## Publications +[(Back to top)](#table-of-contents) + +The best introduction to the fundamentals of Copilot apart from the tutorial +is: + +- [Copilot 3](https://ntrs.nasa.gov/citations/20200003164) + +Other relevant papers include: + +- [Runtime Verification in Real-Time with the Copilot Language: A Tutorial](https://link.springer.com/chapter/10.1007/978-3-031-71177-0_27) + +- [Trustworthy Runtime Verification via Bisimulation (Experience Report)](https://dl.acm.org/doi/abs/10.1145/3607841) + +- [An Introduction to Copilot](https://copilot-language.github.io/downloads/copilot_tutorial.pdf) + +- [Assuring the Guardians](https://link.springer.com/chapter/10.1007/978-3-319-23820-3_6) + +- [Experience report: a do-it-yourself high-assurance compiler](https://dl.acm.org/doi/abs/10.1145/2364527.2364553) + +- [Compiling an Haskell EDSL to C: A new C back-end for the Copilot runtime verification framework](https://studenttheses.uu.nl/handle/20.500.12932/29176) + +- [Challenges in High-Assurance Runtime Verification](https://link.springer.com/chapter/10.1007/978-3-319-47166-2_31) + +- [Runtime Monitoring On Hard Real-Time Operating Systems](http://hdl.handle.net/10342/4999) + +- [Design and Testing of an Approach to Automated In-Flight Safety Risk Management for sUAS Operations](https://ntrs.nasa.gov/citations/20220005948) + +- [The Essence of Reactivity](https://dl.acm.org/doi/10.1145/3609026.3609727) + +- [Types that Change: The Extensible Type Design Pattern](https://dl.acm.org/doi/abs/10.1145/3609025.3609475) + +- [Automated Translation of Natural Language Requirements to Runtime Monitors](https://link.springer.com/chapter/10.1007/978-3-030-99524-9_21) + +- [Copilot: A Hard Real-Time Runtime Monitor](https://link.springer.com/chapter/10.1007/978-3-642-16612-9_26) + +- [Copilot: monitoring embedded systems](https://link.springer.com/article/10.1007/s11334-013-0223-x) + +- [From Requirements to Autonomous Flight: An Overview of the Monitoring ICAROUS Project](https://arxiv.org/abs/2012.03745) + +- [Integrating FRET with Copilot: Automated Translation of Natural Language Requirements to Runtime Monitors](https://ntrs.nasa.gov/citations/20220000049) + +- [Monitoring Distributed Real-Time Systems: A Survey and Future Directions](https://ntrs.nasa.gov/citations/20100027427) + +- [Monitoring ROS2: from Requirements to Autonomous Robots](https://arxiv.org/abs/2209.14030) + +## Website +[(Back to top)](#table-of-contents) + +For further information, including links to more documentation and the +tutorial, please visit the Copilot website: [https://copilot-language.github.io](https://copilot-language.github.io). +# Contributions +[(Back to top)](#table-of-contents) -## Acknowledgements -We are grateful for NASA Contract NNL08AD13T to Galois, Inc. and the National -Institute of Aerospace, which partially supported this work. +We'd love to receive your contributions, be it code fixes, new features, bug +reports, discussions, or anything else that can help the Copilot project. -Additionally NASA Langley contracts 80LARC17C0004 and NNL09AA00A supported -further development of Copilot. +If you have any comments, questions, ideas, or other topics that you think may +be of interest, start a new discussion +[here](https://github.com/Copilot-Language/copilot/discussions). +If you would like to contribute a fix for an issue, please comment on the issue +indicating that you want to fix it so that we can assign it to you and track +the status on our end. If the issue does not exist, create it first or ask that +an existing discussion be promoted to an issue. -## License -Copilot is distributed under the BSD-3-Clause license, which can be found -[here](https://raw.githubusercontent.com/Copilot-Language/copilot/master/copilot/LICENSE). +If you are unsure about whether your submission should be filed as an issue or +as a discussion, file it as a discussion. We can always move it later. +To facilitate merging any pull requests that you send, please: +- Reference the issue you are addressing with the text `Refs #.` + at the end of the subject line of each commit message, in *every commit*. + Replace `` with the number of the specific issue that your pull + request is addressing. +- Describe what each commit does individually *in the commit's message*. It's + best to err on the side of being more descriptive than less. +- Update the CHANGELOGs in the *last commit(s)*. -## The Copilot Team -The development of Copilot spans across several years. During these years -the following people have helped develop Copilot (in no particular order): +You can take a look at the repository's [commit +history](https://github.com/Copilot-Language/copilot/commits/master/) to better +understand the process we follow. Click on each commit to see how we write +commit messages. -* Lee Pike -* Alwyn Goodloe (maintainer) -* Robin Morisset -* Sebastian Niller -* Nis Wegmann +# Acknowledgements +[(Back to top)](#table-of-contents) + +## The Copilot team +[(Back to top)](#table-of-contents) + +Copilot is currently maintained by: + +* Alwyn Goodloe +* Ivan Perez + +Past and current team members also include (in alphabetical order): + +* Macallan Cruff +* Frank Dedden * Chris Hathhorn -* Eli Mendelson -* Jonathan Laurent -* Laura Titolo * Georges-Axel Jolayan -* Macallan Cruff -* Ryan Spring +* Jonathan Laurent +* Eli Mendelson +* Robin Morisset +* Sebastian Niller * Lauren Pick -* Frank Dedden (maintainer: contact at dev@dedden.net) -* Ivan Perez (maintainer) +* Lee Pike +* Will Pogge +* Ryan Spring +* Laura Titolo +* Nis Wegmann + +For a complete list of contributors, including external contributors, see: +https://github.com/Copilot-Language/copilot/graphs/contributors + +## Institutional support +[(Back to top)](#table-of-contents) + +We are grateful for NASA Contract NNL08AD13T to Galois, Inc. and the National +Institute of Aerospace, which partially supported this work. + +Additionally, NASA Langley contracts 80LARC17C0004 and NNL09AA00A supported +further development of Copilot. diff --git a/copilot/copilot.cabal b/copilot/copilot.cabal index dec9b1be2..00a495e3f 100644 --- a/copilot/copilot.cabal +++ b/copilot/copilot.cabal @@ -1,5 +1,5 @@ name: copilot -version: 3.5 +version: 4.8.2 cabal-version: >= 1.10 license: BSD3 license-file: LICENSE @@ -24,6 +24,8 @@ description: A tutorial, examples, and other information are available at . +x-curation: uncurated + extra-source-files: README.md CHANGELOG @@ -31,6 +33,7 @@ extra-source-files: source-repository head type: git location: https://github.com/Copilot-Language/copilot.git + subdir: copilot flag examples description: Enable examples @@ -42,19 +45,19 @@ library default-language: Haskell2010 ghc-options: -Wall - -fwarn-tabs -fno-warn-orphans build-depends: - base >= 4.9 && < 5 - , optparse-applicative >= 0.14 && < 0.16 - , directory >= 1.3 && < 1.4 - , filepath >= 1.4 && < 1.5 + base >= 4.9 && < 5 + , optparse-applicative >= 0.14 && < 0.20 + , directory >= 1.3 && < 1.4 + , filepath >= 1.4 && < 1.6 - , copilot-core >= 3.5 && < 3.6 - , copilot-theorem >= 3.5 && < 3.6 - , copilot-language >= 3.5 && < 3.6 - , copilot-libraries >= 3.5 && < 3.6 - , copilot-c99 >= 3.5 && < 3.6 + , copilot-core >= 4.8.2 && < 4.9 + , copilot-theorem >= 4.8.2 && < 4.9 + , copilot-language >= 4.8.2 && < 4.9 + , copilot-libraries >= 4.8.2 && < 4.9 + , copilot-c99 >= 4.8.2 && < 4.9 + , copilot-prettyprinter >= 4.8.2 && < 4.9 exposed-modules: Language.Copilot, Language.Copilot.Main @@ -83,6 +86,19 @@ executable what4-arithmetic else buildable: False +executable what4-arithmetic-counterexamples + main-is: ArithmeticCounterExamples.hs + hs-source-dirs: examples/what4 + build-depends: base + , containers + , copilot + , copilot-theorem + default-language: Haskell2010 + if flag(examples) + buildable: True + else + buildable: False + executable what4-structs main-is: Structs.hs hs-source-dirs: examples/what4 @@ -192,6 +208,30 @@ executable heater else buildable: False +executable structs + main-is: Structs.hs + hs-source-dirs: examples + build-depends: base >= 4.9 && < 5 + , copilot + , copilot-c99 + default-language: Haskell2010 + if flag(examples) + buildable: True + else + buildable: False + +executable structs-update-field + main-is: StructsUpdateField.hs + hs-source-dirs: examples + build-depends: base >= 4.9 && < 5 + , copilot + , copilot-c99 + default-language: Haskell2010 + if flag(examples) + buildable: True + else + buildable: False + executable voting main-is: Voting.hs hs-source-dirs: examples diff --git a/copilot/examples/AddMult.hs b/copilot/examples/AddMult.hs index af9acfec4..679b77a7b 100644 --- a/copilot/examples/AddMult.hs +++ b/copilot/examples/AddMult.hs @@ -1,6 +1,4 @@ --------------------------------------------------------------------------------- -- Copyright © 2019 National Institute of Aerospace / Galois, Inc. --------------------------------------------------------------------------------- -- | Another small example that calculates a constant value using a recursive -- function. diff --git a/copilot/examples/Array.hs b/copilot/examples/Array.hs index d0e4a4dc1..7f43a21b1 100644 --- a/copilot/examples/Array.hs +++ b/copilot/examples/Array.hs @@ -1,6 +1,4 @@ --------------------------------------------------------------------------------- -- Copyright © 2019 National Institute of Aerospace / Galois, Inc. --------------------------------------------------------------------------------- -- | This is a simple example for arrays. As a program, it does not make much -- sense, however it shows of the features of arrays nicely. @@ -8,8 +6,8 @@ -- | Enable compiler extension for type-level data, necesary for the array -- length. -{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE RebindableSyntax #-} module Main where @@ -28,7 +26,21 @@ spec = do -- It passes the current value of arr as an argument. -- The prototype of 'func' would be: -- void func (int8_t arg[3]); - trigger "func" (arr .!! 0) [arg arr] + trigger "func" (arr ! 0) [arg arr] + + -- A trigger that fires 'func2' every time. + -- It passes the current value of arr as an argument, but updating the first + -- element of the array to always be True. + -- The prototype of 'func2' would be: + -- void func2 (int8_t arg[3]); + trigger "func2" true [arg (arr !! 0 =: true)] + + -- A trigger that fires 'func2' every time. + -- It passes the current value of arr as an argument, but negating the second + -- element of the array. + -- The prototype of 'func3' would be: + -- void func3 (int8_t arg[3]); + trigger "func3" true [arg (arr !! 1 =$ not)] -- Compile the spec main :: IO () diff --git a/copilot/examples/Cast.hs b/copilot/examples/Cast.hs index f2cdaf3dd..67e597a18 100644 --- a/copilot/examples/Cast.hs +++ b/copilot/examples/Cast.hs @@ -1,6 +1,4 @@ --------------------------------------------------------------------------------- -- Copyright © 2019 National Institute of Aerospace / Galois, Inc. --------------------------------------------------------------------------------- -- | Examples of casting types. diff --git a/copilot/examples/Clock.hs b/copilot/examples/Clock.hs index f8dbc196b..e4845283d 100644 --- a/copilot/examples/Clock.hs +++ b/copilot/examples/Clock.hs @@ -1,6 +1,4 @@ --------------------------------------------------------------------------------- -- Copyright © 2019 National Institute of Aerospace / Galois, Inc. --------------------------------------------------------------------------------- -- | Example showing usage of clocks to generate periodically recurring truth -- values. diff --git a/copilot/examples/Counter.hs b/copilot/examples/Counter.hs index 5a0fe6d51..8d7104193 100644 --- a/copilot/examples/Counter.hs +++ b/copilot/examples/Counter.hs @@ -1,6 +1,4 @@ -------------------------------------------------------------------------------- -- Copyright © 2019 National Institute of Aerospace / Galois, Inc. --------------------------------------------------------------------------------- -- | Example showing an implementation of a resettable counter. @@ -22,8 +20,9 @@ counter inc reset = cnt -- Counter that resets when it reaches 256 bytecounter :: Stream Int32 -bytecounter = counter true reset where - reset = counter true false `mod` 256 == 0 +bytecounter = counter true reset + where + reset = counter true false `mod` 256 == 0 spec :: Spec spec = trigger "counter" true [arg $ bytecounter] diff --git a/copilot/examples/Engine.hs b/copilot/examples/Engine.hs index 27d2b540b..1200170f9 100644 --- a/copilot/examples/Engine.hs +++ b/copilot/examples/Engine.hs @@ -1,6 +1,4 @@ --------------------------------------------------------------------------------- -- Copyright © 2011 National Institute of Aerospace / Galois, Inc. --------------------------------------------------------------------------------- -- | Example implementing an engine cooling control system. @@ -11,11 +9,10 @@ module Main where import Language.Copilot import qualified Prelude as P -{- If the majority of the engine temperature probes exeeds 250 degrees, then - - the cooler is engaged and remains engaged until the majority of the engine - - temperature probes drop to 250 or below. Otherwise, trigger an immediate - - shutdown of the engine. --} +-- If the majority of the engine temperature probes exeeds 250 degrees, then +-- the cooler is engaged and remains engaged until the majority of the engine +-- temperature probes drop to 250 or below. Otherwise, trigger an immediate +-- shutdown of the engine. engineMonitor :: Spec engineMonitor = do @@ -28,7 +25,7 @@ engineMonitor = do exceed = map (> 250) vals maj = majority exceed checkMaj = aMajority exceed maj - ok = alwaysBeen ((maj && checkMaj) ==> extern "cooler" cooler) + ok = alwaysBeen ((maj && checkMaj) ==> extern "cooler" cooler) two51 = Just $ [251, 251] P.++ repeat (250 :: Word8) zero = Just $ repeat (0 :: Word8) diff --git a/copilot/examples/Heater.hs b/copilot/examples/Heater.hs index 6204aa126..59c88f992 100644 --- a/copilot/examples/Heater.hs +++ b/copilot/examples/Heater.hs @@ -1,11 +1,9 @@ --------------------------------------------------------------------------------- -- Copyright 2019 National Institute of Aerospace / Galois, Inc. --------------------------------------------------------------------------------- -- This is a simple example with basic usage. It implements a simple home -- heating system: It heats when temp gets too low, and stops when it is high -- enough. It read temperature as a byte (range -50C to 100C) and translates --- this to Celcius. +-- this to Celsius. module Main where @@ -18,7 +16,7 @@ import Prelude hiding ((>), (<), div) temp :: Stream Word8 temp = extern "temperature" Nothing --- Calculate temperature in Celcius. +-- Calculate temperature in Celsius. -- We need to cast the Word8 to a Float. Note that it is an unsafeCast, as there -- is no direct relation between Word8 and Float. ctemp :: Stream Float diff --git a/copilot/examples/Structs.hs b/copilot/examples/Structs.hs new file mode 100644 index 000000000..1b036fe5e --- /dev/null +++ b/copilot/examples/Structs.hs @@ -0,0 +1,77 @@ +-- | An example showing how specifications involving structs (in particular, +-- nested structs) are compiled to C using copilot-c99. + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} + +module Main where + +import qualified Prelude as P +import Control.Monad (void, forM_) +import GHC.Generics (Generic) + +import Language.Copilot +import Copilot.Compile.C99 + +-- | Definition for `Volts`. +data Volts = Volts + { numVolts :: Field "numVolts" Word16 + , flag :: Field "flag" Bool + } + deriving Generic + +-- | `Struct` instance for `Volts`. +instance Struct Volts where + typeName = typeNameDefault + toValues = toValuesDefault + -- Note that we do not implement `updateField` here. `updateField` is only + -- needed to make updates to structs work in the Copilot interpreter, and we + -- do not use the interpreter in this example. (See + -- `examples/StructsUpdateField.hs` for an example that does implement + -- `updateField`.) + +-- | `Volts` instance for `Typed`. +instance Typed Volts where + typeOf = typeOfDefault + +data Battery = Battery + { temp :: Field "temp" Word16 + , volts :: Field "volts" (Array 10 Volts) + , other :: Field "other" (Array 10 (Array 5 Word32)) + } + deriving Generic + +-- | `Battery` instance for `Struct`. +instance Struct Battery where + typeName = typeNameDefault + toValues = toValuesDefault + -- Note that we do not implement `updateField` here for the same reasons as in + -- the `Struct Volts` instance above. + +-- | `Battery` instance for `Typed`. +instance Typed Battery where + typeOf = typeOfDefault + +spec :: Spec +spec = do + let battery :: Stream Battery + battery = extern "battery" Nothing + + -- Check equality, indexing into nested structs and arrays. Note that this is + -- trivial by equality. + trigger "equalitySameIndex" + ((((battery#volts) ! 0)#numVolts) == (((battery#volts) ! 0)#numVolts)) + [arg battery] + + -- Same as previous example, but get a different array index (so should be + -- false). + trigger "equalityDifferentIndices" + ((((battery#other) ! 2) ! 3) == (((battery#other) ! 2) ! 4)) + [arg battery] + +main :: IO () +main = do + spec' <- reify spec + + -- Compile the specific to C. + compile "structs" spec' diff --git a/copilot/examples/StructsUpdateField.hs b/copilot/examples/StructsUpdateField.hs new file mode 100644 index 000000000..5b0c7a35d --- /dev/null +++ b/copilot/examples/StructsUpdateField.hs @@ -0,0 +1,161 @@ +-- | An example showing how specifications involving structs (in particular, +-- nested structs) are interpreted and how they are compiled to C using +-- copilot-c99. + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Main where + +import qualified Prelude as P +import Control.Monad (void, forM_) +import Data.Proxy (Proxy(..)) +import Data.Type.Equality (TestEquality(..), (:~:)(..)) +import GHC.Generics (Generic) +import GHC.TypeLits (sameSymbol) + +import Language.Copilot +import Copilot.Compile.C99 + +-- | Definition for `Volts`. +data Volts = Volts + { numVolts :: Field "numVolts" Word16 + , flag :: Field "flag" Bool + } + deriving Generic + +-- | `Struct` instance for `Volts`. +instance Struct Volts where + typeName = typeNameDefault + toValues = toValuesDefault + -- In order to run struct updates (as used in the "equalityStructUpdate" + -- trigger below) in the Copilot interpreter, we must implement the + -- `updateField` method. To do so, we must check to see if the supplied + -- `Value` has a `Field` with the same name and type as a field in `Volts`. + -- (Alternatively, we could define this as @updateField = updateFieldDefault@, + -- but we demonstrate how to manually implement it below for educational + -- purposes.) + updateField volts (Value fieldTy (field :: Field fieldName a)) + -- For each field in `Volts`, we must: + -- + -- 1. Check that the field names match using `sameSymbol`. Here, + -- "numVolts" is the expected name, and `fieldName` is the actual name + -- that is supplied as an argument to `updateField`. If the check + -- succeeds, then the `sameSymbol` function will return `Just p`, where + -- `p` is proof that the two names are the same. + | Just Refl <- sameSymbol (Proxy @"numVolts") (Proxy @fieldName) + -- 2. Check that the field types match using `testEquality`. Here, + -- `Word16` is the expected type, and `fieldTy` is the actual type that + -- is supplied as an argument. Again, `testEquality` will return `Just + -- p` (where `p` is a proof) if the two are the same. + , Just Refl <- testEquality Word16 fieldTy + -- 3. If both of the checks above succeed, then we can update the field's + -- value using a record update. + = volts { numVolts = field } + + -- It is possible that the `Value` passed as an argument could correspond + -- to any of the fields in `Volts`, so we must repeat this process for + -- the `flag` field as well. + | Just Refl <- sameSymbol (Proxy @fieldName) (Proxy @"flag") + , Just Refl <- testEquality fieldTy Bool + = volts { flag = field } + + -- If the supplied `Value` does not correspond to any field in `Volts`, + -- then something went wrong in the Copilot interpreter. This case reports + -- this as an error. + | otherwise + = error $ "Unexpected field: " P.++ show field + +-- | `Volts` instance for `Typed`. +instance Typed Volts where + typeOf = typeOfDefault + +data Battery = Battery + { temp :: Field "temp" Word16 + , volts :: Field "volts" (Array 10 Volts) + , other :: Field "other" (Array 10 (Array 5 Word32)) + } + deriving Generic + +-- | `Battery` instance for `Struct`. +instance Struct Battery where + typeName = typeNameDefault + toValues = toValuesDefault + -- We implement `updateField` similarly to how we implement it in the + -- `Struct Volts` instance above. (Alternatively, we could define this as + -- @updateField = updateFieldDefault@, but we demonstrate how to manually + -- implement it below for educational purposes.) + updateField battery (Value fieldTy (field :: Field fieldName a)) + | Just Refl <- sameSymbol (Proxy @fieldName) (Proxy @"temp") + , Just Refl <- testEquality fieldTy Word16 + = battery { temp = field } + + | Just Refl <- sameSymbol (Proxy @fieldName) (Proxy @"volts") + -- Note that writing out the full `Type` for `Volts` is somewhat verbose, + -- so we make use of the `Typed Volts` instance and write `typeOf @Volts` + -- instead. + , Just Refl <- testEquality fieldTy (Array @10 (typeOf @Volts)) + = battery { volts = field } + + | Just Refl <- sameSymbol (Proxy @fieldName) (Proxy @"other") + , Just Refl <- testEquality fieldTy (Array @10 (Array @5 Word32)) + = battery { other = field } + + | otherwise + = error $ "Unexpected field: " P.++ show field + +-- | `Battery` instance for `Typed`. +instance Typed Battery where + typeOf = typeOfDefault + +spec :: Spec +spec = do + let voltsValue :: Volts + voltsValue = + Volts + { numVolts = Field 42 + , flag = Field True + } + + batteryValue :: Battery + batteryValue = + Battery + { temp = Field 0 + , volts = Field (array (replicate 10 voltsValue)) + , other = Field (array (replicate 10 (array (replicate 5 0)))) + } + + battery :: Stream Battery + battery = extern "battery" (Just [batteryValue]) + + -- Check equality, indexing into nested structs and arrays. Note that this is + -- trivial by equality. + trigger "equalitySameIndex" + ((((battery#volts) ! 0)#numVolts) == (((battery#volts) ! 0)#numVolts)) + [arg battery] + + -- Same as previous example, but get a different array index (so should be + -- false). + trigger "equalityDifferentIndices" + ((((battery#other) ! 2) ! 3) == (((battery#other) ! 2) ! 4)) + [arg battery] + + -- Update a struct field, then check it for equality. + let batteryTemp1, batteryTemp2 :: Stream Word16 + batteryTemp1 = (battery ## temp =$ (+1))#temp + batteryTemp2 = battery#temp + 1 + trigger "equalityStructUpdate" + (batteryTemp1 == batteryTemp2) + [arg battery, arg batteryTemp1, arg batteryTemp2] + +main :: IO () +main = do + -- Run the specification using the Copilot interpreter. + interpret 1 spec + + -- Compile the specification to C. + spec' <- reify spec + compile "structs" spec' diff --git a/copilot/examples/Voting.hs b/copilot/examples/Voting.hs index 14a3341b3..d534fe2c7 100644 --- a/copilot/examples/Voting.hs +++ b/copilot/examples/Voting.hs @@ -1,6 +1,4 @@ --------------------------------------------------------------------------------- -- Copyright © 2019 National Institute of Aerospace / Galois, Inc. --------------------------------------------------------------------------------- -- | Fault-tolerant voting examples. diff --git a/copilot/examples/WCV.hs b/copilot/examples/WCV.hs index 80ab4af26..3ac016fb3 100644 --- a/copilot/examples/WCV.hs +++ b/copilot/examples/WCV.hs @@ -3,7 +3,7 @@ -- Well-Clear Bounday Models for the Integration of UAS in the NAS', -- https://ntrs.nasa.gov/citations/20140010078. -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE RebindableSyntax #-} module Main where @@ -14,7 +14,6 @@ import qualified Prelude as P import Data.Foldable (forM_) import qualified Control.Monad as Monad - -- | `dthr` is the horizontal distance threshold. dthr :: Stream Double dthr = extern "dthr" Nothing @@ -33,10 +32,7 @@ tcoathr = extern "tcoathr" Nothing type Vect2 = (Stream Double, Stream Double) - --------------------------------- -- External streams for relative position and velocity. --------------------------------- -- | The relative x velocity between ownship and the intruder. vx :: Stream Double @@ -54,7 +50,6 @@ vz = extern "relative_velocity_z" Nothing v :: (Stream Double, Stream Double) v = (vx, vy) - -- | The relative x position between ownship and the intruder. sx :: Stream Double sx = extern "relative_position_x" Nothing @@ -71,10 +66,7 @@ sz = extern "relative_position_z" Nothing s :: (Stream Double, Stream Double) s = (sx, sy) - ------------------- -- The following section contains basic libraries for working with vectors. ------------------- -- | Multiply two Vectors. (|*|) :: Vect2 -> Vect2 -> Stream Double @@ -101,11 +93,8 @@ a ~= b = (abs (a - b)) < 0.001 neg :: Vect2 -> Vect2 neg (x, y) = (negate x, negate y) - --------------------- -- From here on the algorithm, as described by the paper mentioned on the top -- of this file, is implemented. Please refer to the paper for details. --------------------- tau :: Vect2 -> Vect2 -> Stream Double tau s v = if s |*| v < 0 @@ -134,7 +123,6 @@ delta s v d = (d*d) * (sq v) - ((det s v)*(det s v)) theta :: Vect2 -> Vect2 -> Stream Double -> Stream Double -> Stream Double theta s v d e = (-(s |*| v) + e * (sqrt $ delta s v d)) / (sq v) - tcoa :: Stream Double -> Stream Double -> Stream Double tcoa sz vz = if (sz * vz) < 0 then (-sz) / vz @@ -143,10 +131,7 @@ tcoa sz vz = if (sz * vz) < 0 dcpa :: Vect2 -> Vect2 -> Stream Double dcpa s@(sx, sy) v@(vx, vy) = norm (sx + (tcpa s v) * vx, sy + (tcpa s v) * vy) - --------------------------- -- Well clear Violation -- --------------------------- -- | Determines if the well clear property is violated or not. wcv :: (Vect2 -> Vect2 -> Stream Double) -> @@ -166,9 +151,8 @@ horizontalWCV tvar s v = (((dcpa s v) <= dthr) && (0 <= (tvar s v)) && ((tvar s v) <= tthr)) spec = do - Monad.void $ prop "1a" (forall $ (tau s v) ~= (tau (neg s) (neg v))) - -- Monad.void $ prop "3d" (forall $ (wcv tep s sz v vz) == (wcv tep (neg s) (-sz) (neg v) (-vz))) - + Monad.void $ prop "1a" (forAll $ (tau s v) ~= (tau (neg s) (neg v))) + -- Monad.void $ prop "3d" (forAll $ (wcv tep s sz v vz) == (wcv tep (neg s) (-sz) (neg v) (-vz))) main :: IO () main = do diff --git a/copilot/examples/fpga/HelloWorld/HelloWorld.hs b/copilot/examples/fpga/HelloWorld/HelloWorld.hs new file mode 100644 index 000000000..c694c8f2e --- /dev/null +++ b/copilot/examples/fpga/HelloWorld/HelloWorld.hs @@ -0,0 +1,19 @@ +module Main where + +import Language.Copilot +import Copilot.Compile.Bluespec + +-- Define switches input +sw :: Stream Word8 +sw = extern "sw" Nothing + +-- Define LEDS output +leds :: Stream Word8 +leds = sw + +spec = do + trigger "leds" true [arg leds] + +main = do + spec' <- reify spec + compile "HelloWorld" spec' diff --git a/copilot/examples/fpga/HelloWorld/README.md b/copilot/examples/fpga/HelloWorld/README.md new file mode 100644 index 000000000..78ecd1aa8 --- /dev/null +++ b/copilot/examples/fpga/HelloWorld/README.md @@ -0,0 +1,557 @@ +# Hello World Example on an FPGA Board + +Copilot is a programming language for hard real-time systems. + +This tutorial shows how to use Copilot to control LEDs from hardware switches. +The demonstration serves as an introduction of the complete toolchain needed to +integrate Copilot into hardware projects. The specification is verified via the +onboard LEDs on an Artix-7 XC7A35T FPGA, using AMD/Xilinx Vivado Design Suite. + +This page lists all the necessary applications and auxiliary files required to +run Copilot onto an FPGA. Specifically, this page shows: + +- How to install the necessary dependencies. +- How to create Copilot code that invokes the Bluespec backend. +- How to compile the Bluespec files into Verilog. +- How to run and test the design on an FPGA board. + +## Table of Contents + +- [Installation](#installation) +- [Example](#example) + - [Hello World Code](#hello-world-code) + - [Compiling Copilot into Bluespec](#compiling-copilot-into-bluespec) + - [Compiling Bluespec to Verilog](#compiling-bluespec-to-verilog) +- [Running the Hello World Example on Vivado](#running-the-hello-world-example-on-vivado) +- [Acknowledgements](#acknowledgments) + +# Installation +[(Back to top)](#table-of-contents) + +## Vivado 2025.1 + +Vivado can be installed through terminal as suggested by the following process. +The steps provided are for a Vivado version that is ~50 GB less than the one +directly available on the AMD website. If issues arise, see the official +[Vivado +documentation](https://docs.amd.com/r/en-US/ug910-vivado-getting-started/Installing-the-Vivado-Design-Suite) +for an alternative installation method. + +1. Create an account on the +[AMD](https://www.amd.com/en/registration/create-account.html) website, which +allows downloading the Vivado Design Suite. + +2. Download the [Vivado +Edition 2025.1](https://www.xilinx.com/member/forms/download) +specific for your device and verify the information required by AMD. + +3. Open the command terminal, navigate to the directory containing the + downloaded Vivado installation file, and adjust the permissions of the file + so that it can be executed: + + ```sh + $ chmod a+x FPGAs_AdaptiveSoCs_Unified_SDI_2025.1_0530_0145_.bin + ``` + Replace `` with your operating system. + +4. Run the installation program: + + ```sh + $ ./FPGAs_AdaptiveSoCs_Unified_SDI_2025.1_0530_0145_.bin + ``` + +5. An installation window will pop up. Follow the installation prompt. When + the window *Select Product to Install* is shown, select the product + *Vivado*. Then, select the *Vivado ML Standard* edition from the two + options. In the *Vivado ML Standard* window, in the subcategory *Devices*, + select the FPGA board that you're working with (in our case the *7 Series*). + Hit *install* when prompted. The download should be ~20 GB to 50 GB. + +6. Ensure that the directory where you choose to install Vivado has + read/write permissions. If the candidate installation + directory is highlighted red, it means it has the wrong permissions and/or + owner. If that happens, change the owner into a different user, or try to + run the binary installer as sudo (root) by running the command: + ```sh + $ sudo ./FPGAs_AdaptiveSoCs_Unified_SDI_2025.1_0530_0145_.bin + ``` + + The rest of the instructions assume you have installed Vivado under + `/tools`. Adjust paths accordingly as needed. + +7. Install the drivers with: + + ```sh + $ source /tools/Xilinx/2025.1/Vivado/.settings64-Vivado.sh + $ sudo /tools/Xilinx/2025.1/data/xicom/cable_drivers//install_script/install_drivers/install_drivers + ``` + + The terminal should show a message indicating that the drivers were + installed successfully. A sample output is included below. Note that the + installation path may be different on your computer. + +
Terminal Output (click to expand) + + ``` + INFO: Installing cable drivers. + INFO: Script name = /tools/Xilinx/2025.1/data/xicom/cable_drivers/lin64/install_script/install_drivers/install_drivers + INFO: HostName = iron-B650M-C-V2-Y1 + INFO: RDI_BINROOT= /tools/Xilinx/2025.1/data/xicom/cable_drivers/lin64/install_script/install_drivers + INFO: Current working dir = /home/iron/Downloads + INFO: Kernel version = 6.8.0-60-generic. + INFO: Arch = x86_64. + Successfully installed Digilent Cable Drivers + --File /etc/udev/rules.d/52-xilinx-ftdi-usb.rules does not exist. + --File version of /etc/udev/rules.d/52-xilinx-ftdi-usb.rules = 0000. + --Updating rules file. + --File /etc/udev/rules.d/52-xilinx-pcusb.rules does not exist. + --File version of /etc/udev/rules.d/52-xilinx-pcusb.rules = 0000. + --Updating rules file. + + INFO: Digilent Return code = 0 + INFO: Xilinx Return code = 0 + INFO: Xilinx FTDI Return code = 0 + INFO: Return code = 0 + INFO: Driver installation successful. + CRITICAL WARNING: Cable(s) on the system must be unplugged then plugged back in order for the driver scripts to update the cables. + ``` +
+ +8. Verify that Vivado has been installed on your device by running the + following command and checking that you see version information + being printed: + + ```sh + $ vivado -version + vivado v2025.1 (64-bit) + Tool Version Limit: 2025.05 + SW Build 6140274 on Wed May 21 22:58:25 MDT 2025 + IP Build 6138677 on Thu May 22 03:10:11 MDT 2025 + SharedData Build 6139179 on Tue May 20 17:58:58 MDT 2025 + Copyright 1986-2022 Xilinx, Inc. All Rights Reserved. + Copyright 2022-2025 Advanced Micro Devices, Inc. All Rights Reserved. + ``` + +# Example + +## Hello World Code +[(Back to top)](#table-of-contents) + +This example shows how Copilot can be used to control LEDs using switches. We +use four switches and four LEDs available on the FPGA board. + +The main Copilot specification is created in a file `HelloWorld.hs`. The final +contents of that file is available in the [Copilot +repository](https://github.com/Copilot-Language/copilot/tree/master/copilot/examples/fpga/HelloWorld/HelloWorld.hs). +The same directory contains any auxiliary files needed to run the code onto an +FPGA board. + +The first definition in a Copilot specification is a module declaration, which +should always refer to the module as the `Main` module: + +```haskell +module Main where +``` + +Next, we import the main definitions of the Copilot language, as well as the +Bluespec backend: + +```haskell +import Copilot.Compile.Bluespec +import Language.Copilot +``` + +Copilot normally represents data as infinite successions of values or +*streams*. Streams whose values are provided by input devices are considered +external inputs for this specification or *externs*. Because switches are +inputs to the Copilot logic, we define the current value of the state of the +switches as an extern carrying values of typed 8-bit unsigned integer, or +`Word8`: + +```haskell +sw :: Stream Word8 +sw = extern "sw" Nothing +``` + +The four least-significant bits of the current value of `sw` represent the +current state of each of the four switches on the board, respectively. + +Next, we define the current value of the four LEDs in a similar way. To make +the state of the LEDs match that of the switches, we state that their values +are the same: + +```haskell +leds :: Stream Word8 +leds = sw +``` + +To connect the current values of the LEDs to the actual LEDs on the board, we +must communicate the current values as outputs of the specification which we do +with a *trigger*: + +```haskell +spec = do + trigger "leds" true [arg leds] +``` + +In the above trigger definition, `"leds"` is the name of the output, whereas +`leds` (without double quotes) is a Copilot stream that, at each point in time, +will contain the current values that the LEDs should have. + +We instruct Copilot to compile the file and generate Bluespec when the Copilot +spec is executed: + +```haskell +main = do + spec' <- reify spec + compile "HelloWorld" spec' +``` + +## Compiling Copilot into Bluespec +[(Back to top)](#table-of-contents) + +Copilot and Bluespec compiler must be installed on the device (see +[Copilot](https://github.com/Copilot-Language/copilot) and +[Bluespec](https://github.com/Copilot-Language/copilot-bluespec) for +installation instructions). + +In the terminal, navigate to the directory that has the `HelloWorld.hs` +example. Compile the Copilot specification into Bluespec by running: + +```shell +$ runhaskell HelloWorld.hs +``` + +This command generates three Bluespec files in the same directory: +`HelloWorld.bs`, `HelloWorldIfc.bs` and `HelloWorldTypes.bs`. These files make +up the internal logic and interface in Verilog. For reference, the expected +content of these files is included below. The specific content may change +slightly across versions of Copilot. + +
+Contents of generated Bluespec files (click to expand) + +**`HelloWorld.bs`** + +```bluespec +package HelloWorld where { +import FloatingPoint; + +import Vector; + +import HelloWorldTypes; + +import HelloWorldIfc; + +import BluespecFP; + +mkHelloWorld :: Prelude.Module HelloWorldIfc -> + Prelude.Module Prelude.Empty; +mkHelloWorld ifcMod = + module { + ifc <- ifcMod; + let { leds_0_guard :: Prelude.Bool; + leds_0_guard = Prelude.True; + leds_0_arg0 :: Prelude.UInt 8; + leds_0_arg0 = ifc.sw._read; }; + rules { + + "leds_0": when leds_0_guard ==> ifc.leds leds_0_arg0 + } + }; +} +``` + +**`HelloWorldIfc.bs`** + +```bluespec +package HelloWorldIfc where { +import FloatingPoint; + +import Vector; + +import HelloWorldTypes; + +interface HelloWorldIfc = { + leds :: Prelude.UInt 8 -> Prelude.Action; + sw :: Prelude.Reg (Prelude.UInt 8) +} +} +``` + +**`HelloWorldTypes.bs`** + +```bluespec +package HelloWorldTypes where { +import FloatingPoint; + +import Vector +} +``` +
+ +In the same directory, create a new file named `Top.bs`. This file serves as +top-level Bluespec module, connects the three generated files together and +contains the interface definitions. This file will later be compiled into +Verilog and deployed onto the FPGA. + +We define both the `helloWorldIfc` and `mkTop` modules. When `HelloWorld.bs` is +compiled, it makes `leds` an output, which translates to an *action* method in +Bluespec. Since an *action* method updates state rather than directly driving a +signal, we need a way to hold its value, so we create the register `led_reg`, +which stores the LEDs' value. The *type* of `led_reg` must match the *type* of +`leds` in `HelloWorldIfc.bs`. + +```bluespec +package Top where + + import HelloWorld + import HelloWorldIfc + import HelloWorldTypes + + helloWorldIfc :: Prelude.Module HelloWorldIfc + helloWorldIfc = + module + -- Register that connects the LEDs to values produced by Copilot + led_reg :: Prelude.Reg (Prelude.UInt 8) <- mkReg 0 + interface + leds reg = action + led_reg := reg + + mkTop :: Prelude.Module Empty + mkTop = mkHelloWorld helloWorldIfc +``` +## Compiling Bluespec to Verilog +[(Back to top)](#table-of-contents) + +We use the Bluespec compiler to generate Verilog output using the top-level +module. `mkTop` is a function in the `Top.bs` file that instantiates the +top-level module of the design. In the terminal, we run the following command: + +```shell +$ bsc -verilog -g mkTop -u Top.bs +``` + +This step generates the Verilog code that can be compiled to run onto the FPGA +board. We can ignore the warnings shown in terminal output, but we must ensure +that the file `mkTop.v` is successfully created in the current directory. + +To program the code onto the FPGA, the ports declarations and assignments need +modifications. In the `Top.bs` file, the module that had the register and +interface for the LEDs and switches is defined in `helloWorldIfc`. Due to this, +when compiling into Verilog, the Top level module does not have `sw` and `leds` +defined in its port declaration. This has to be modified manually. + +The following `mkTop.v` lines list the module ports in the `Top.bs` file. These +are the external signals that connect to this module: + +```verilog +module mkTop(CLK, + RST_N); + input CLK; + input RST_N; +``` + +We modify `mkTop` and add the input port `sw` and output port `leds` inside the +module port because these signals will externally connect to the FPGA. The FPGA +is limited to 4 LEDs and 4 switches. Alongside the existing definitions, we +need to *assign* the value of `ifc_led_reg$D_IN`, which is an internal wire +created by the Verilog code to the output `leds`. We *assign* the output `leds` +to the register. This register was defined in our `Top.bs` and appears as an +internal register `ifc_led_reg` and its current contents appears as the value +in `leds`. The value is updated on every rising edge of the `CLK`. + +For reference, the complete contents of the modified `mkTop.v` is included +below. + +
+Contents of modified `mkTop.v` file (click to expand) + +```verilog +// +// Generated by Bluespec Compiler, version 2025.01.1 (build 65e3a87a) +// +// Further modified by Sukhman Kahlon. +// +// On Thu Aug 14 14:52:29 PDT 2025 +// +// +// Ports: +// Name I/O size props +// CLK I 1 clock +// RST_N I 1 reset +// +// No combinational paths from inputs to outputs +// +// + +`ifdef BSV_ASSIGNMENT_DELAY +`else + `define BSV_ASSIGNMENT_DELAY +`endif + +`ifdef BSV_POSITIVE_RESET + `define BSV_RESET_VALUE 1'b1 + `define BSV_RESET_EDGE posedge +`else + `define BSV_RESET_VALUE 1'b0 + `define BSV_RESET_EDGE negedge +`endif + +module mkTop(CLK, + RST_N, + sw, + leds); + input CLK; + input RST_N; + input [3:0] sw; + output [3:0] leds; + + assign leds[3:0] = ifc_led_reg[3:0]; + + // register ifc_led_reg + reg [7 : 0] ifc_led_reg; + wire [7 : 0] ifc_led_reg$D_IN; + wire ifc_led_reg$EN; + + // register ifc_led_reg + assign ifc_led_reg$D_IN = sw[3:0]; + assign ifc_led_reg$EN = 1'd1 ; + + // handling of inlined registers + + always@(posedge CLK) + begin + if (RST_N == `BSV_RESET_VALUE) + begin + ifc_led_reg <= `BSV_ASSIGNMENT_DELAY 8'd0; + end + else + begin + if (ifc_led_reg$EN) + ifc_led_reg <= `BSV_ASSIGNMENT_DELAY ifc_led_reg$D_IN; + end + end + + // synopsys translate_off + `ifdef BSV_NO_INITIAL_BLOCKS + `else // not BSV_NO_INITIAL_BLOCKS + initial + begin + ifc_led_reg = 8'hAA; + end + `endif // BSV_NO_INITIAL_BLOCKS + // synopsys translate_on +endmodule // mkTop +``` +
+ +This code will be copied to Vivado and replace the default empty module created +by Vivado. + +To interface between the FPGA board and the code, a constraints file needs to +be created and is dependent on the type of FPGA board used. Please refer to the +reference manual for your specific FPGA board, to assign pins for LEDs +accordingly. Digilent offers I/O pins for the respective boards on the +[Digilent Github Repository](https://github.com/Digilent/digilent-xdc). + +Ensure the name of the external pins after `get_ports` matches the inputs / +outputs created in the port declaration. In this example, `CLK`, `RST_N`, +`leds`, and `sw` *must* be assigned. For reference, here is the constraints +file assigning LED 4-7 for the Arty 35T CSG324-1 to the output `leds`, and +setting the switches and period accordingly. + +
+Contents of constraints file `new_constraints.xdc` (click to expand) + +```xdc +set_property -dict { PACKAGE_PIN E3 IOSTANDARD LVCMOS33 } [get_ports CLK] +create_clock -add -name sys_clk_pin -period 10.00 -waveform {0 5} [get_ports CLK] + +set_property PACKAGE_PIN C2 [get_ports RST_N] +set_property IOSTANDARD LVCMOS33 [get_ports RST_N] + +# Switches +set_property -dict { PACKAGE_PIN A8 IOSTANDARD LVCMOS33 } [get_ports { sw[0] }]; #IO_L12N_T1_MRCC_16 Sch=sw[0] +set_property -dict { PACKAGE_PIN C11 IOSTANDARD LVCMOS33 } [get_ports { sw[1] }]; #IO_L13P_T2_MRCC_16 Sch=sw[1] +set_property -dict { PACKAGE_PIN C10 IOSTANDARD LVCMOS33 } [get_ports { sw[2] }]; #IO_L13N_T2_MRCC_16 Sch=sw[2] +set_property -dict { PACKAGE_PIN A10 IOSTANDARD LVCMOS33 } [get_ports { sw[3] }]; #IO_L14P_T2_SRCC_16 Sch=sw[3] + +# LEDs +set_property -dict { PACKAGE_PIN H5 IOSTANDARD LVCMOS33 } [get_ports { leds[0] }]; #IO_L24N_T3_35 Sch=led[4] +set_property -dict { PACKAGE_PIN J5 IOSTANDARD LVCMOS33 } [get_ports { leds[1] }]; #IO_25_35 Sch=led[5] +set_property -dict { PACKAGE_PIN T9 IOSTANDARD LVCMOS33 } [get_ports { leds[2] }]; #IO_L24P_T3_A01_D17_14 Sch=led[6] +set_property -dict { PACKAGE_PIN T10 IOSTANDARD LVCMOS33 } [get_ports { leds[3] }]; #IO_L24N_T3_A00_D16_14 Sch=led[7] +``` +
+ +# Running the Hello World Example on Vivado +[(Back to top)](#table-of-contents) + +Once installed, open the Vivado Design Suite. + +1. Click *Create Project* > *Next* > *Project Name:* `HelloWorld` and choose +the desired location. + +2. Select *Create Project Subdirectory* > *Next* > *RTL Project* > *Next*. + +3. Select *Do not specify sources at this time* > *Next*. + +4. Search for the board / chip. In this example, the board used is +`xc7a35tcsg324-1`. The project should be created and initialized. + +6. Once the Vivado workspace opens, under the *Sources* tab, select *+* > *Add +or create design sources* > *Next* > *Create File*. + +7. Introduce the following values: + - *File Type*: `Verilog` + - *File Name*: `mkTop` + - *File Location*: `` + +8. Under the *Sources* tab, select *+* > *Add or create constraints* > *Next* > + *Create File*. + +10. Introduce the following values: + - *File Type*: `XDC` + - *File Name*: `new_constraints` + - *File Location*: `` + +11. From the *Sources* drop down, select *Design Sources* and open the +created design file `mkTop.v`. + +12. Copy the contents of the Verilog code `mkTop.v` as previously modified. + +13. From the *Sources* drop down, select *Constraints* and select the created +constraints file `new_constraints.xdc`. + +14. Copy and modify the constraints file according to the specific FPGA board +that aligns with the project. + +15. To run and compile the code, on the left-hand bar labeled *Flow Navigator*, +under *Project Manager* > *Program and Debug*, Select *Generate Bitstream* to +compile the code. + +16. Once bitsream generation is completed. Navigate under *Hardware Manager* > +*Open Target* > *Plug in your FPGA board via USB* > *Auto Connect* > *Program +Device*. + +The LEDs on your FPGA board should now display the LEDs counting up in +correspondence to its binary value. + +# Acknowledgements +[(Back to top)](#table-of-contents) + +This tutorial has been created by Sukhman Kahlon. + +Special thanks to the following individuals and teams for their guidance and +support throughout this project: + +Pavlo Vlastos – for providing clear and helpful instructions on setting up +Vivado. + +Ryan Scott and the Bluespec team – for their assistance with `copilot-bluespec` +and Bluespec. + +Ivan Perez – for his support with Copilot and set up for this example. + +Kaveh Zare - for sampling the tutorial and providing feedback. diff --git a/copilot/examples/fpga/HelloWorld/Top.bs b/copilot/examples/fpga/HelloWorld/Top.bs new file mode 100644 index 000000000..9e9f00c76 --- /dev/null +++ b/copilot/examples/fpga/HelloWorld/Top.bs @@ -0,0 +1,17 @@ +package Top where + + import HelloWorld + import HelloWorldIfc + import HelloWorldTypes + + helloWorldIfc :: Prelude.Module HelloWorldIfc + helloWorldIfc = + module + -- Register that connects the LEDs to values produced by Copilot + led_reg :: Prelude.Reg (Prelude.UInt 8) <- mkReg 0 + interface + led reg = action + led_reg := reg + + mkTop :: Prelude.Module Prelude.Empty + mkTop = mkHelloWorld helloWorldIfc diff --git a/copilot/examples/fpga/HelloWorld/constraints.xdc b/copilot/examples/fpga/HelloWorld/constraints.xdc new file mode 100644 index 000000000..119f897f3 --- /dev/null +++ b/copilot/examples/fpga/HelloWorld/constraints.xdc @@ -0,0 +1,17 @@ +set_property -dict { PACKAGE_PIN E3 IOSTANDARD LVCMOS33 } [get_ports CLK] +create_clock -add -name sys_clk_pin -period 10.00 -waveform {0 5} [get_ports CLK] + +set_property PACKAGE_PIN C2 [get_ports RST_N] +set_property IOSTANDARD LVCMOS33 [get_ports RST_N] + +# Switches +set_property -dict { PACKAGE_PIN A8 IOSTANDARD LVCMOS33 } [get_ports { sw[0] }]; #IO_L12N_T1_MRCC_16 Sch=sw[0] +set_property -dict { PACKAGE_PIN C11 IOSTANDARD LVCMOS33 } [get_ports { sw[1] }]; #IO_L13P_T2_MRCC_16 Sch=sw[1] +set_property -dict { PACKAGE_PIN C10 IOSTANDARD LVCMOS33 } [get_ports { sw[2] }]; #IO_L13N_T2_MRCC_16 Sch=sw[2] +set_property -dict { PACKAGE_PIN A10 IOSTANDARD LVCMOS33 } [get_ports { sw[3] }]; #IO_L14P_T2_SRCC_16 Sch=sw[3] + +# LEDs +set_property -dict { PACKAGE_PIN H5 IOSTANDARD LVCMOS33 } [get_ports { leds[0] }]; #IO_L24N_T3_35 Sch=led[4] +set_property -dict { PACKAGE_PIN J5 IOSTANDARD LVCMOS33 } [get_ports { leds[1] }]; #IO_25_35 Sch=led[5] +set_property -dict { PACKAGE_PIN T9 IOSTANDARD LVCMOS33 } [get_ports { leds[2] }]; #IO_L24P_T3_A01_D17_14 Sch=led[6] +set_property -dict { PACKAGE_PIN T10 IOSTANDARD LVCMOS33 } [get_ports { leds[3] }]; #IO_L24N_T3_A00_D16_14 Sch=led[7] diff --git a/copilot/examples/fpga/HelloWorld/mkTop.v b/copilot/examples/fpga/HelloWorld/mkTop.v new file mode 100644 index 000000000..23ecef6ab --- /dev/null +++ b/copilot/examples/fpga/HelloWorld/mkTop.v @@ -0,0 +1,75 @@ +// +// Generated by Bluespec Compiler, version 2025.01.1 (build 65e3a87a) +// +// Further modified by Sukhman Kahlon. +// +// On Thu Aug 14 14:52:29 PDT 2025 +// +// +// Ports: +// Name I/O size props +// CLK I 1 clock +// RST_N I 1 reset +// +// No combinational paths from inputs to outputs +// +// + +`ifdef BSV_ASSIGNMENT_DELAY +`else + `define BSV_ASSIGNMENT_DELAY +`endif + +`ifdef BSV_POSITIVE_RESET + `define BSV_RESET_VALUE 1'b1 + `define BSV_RESET_EDGE posedge +`else + `define BSV_RESET_VALUE 1'b0 + `define BSV_RESET_EDGE negedge +`endif + +module mkTop(CLK, + RST_N, + sw, + leds); + input CLK; + input RST_N; + input [3:0] sw; + output [3:0] leds; + + assign leds[3:0] = ifc_led_reg[3:0]; + + // register ifc_led_reg + reg [7 : 0] ifc_led_reg; + wire [7 : 0] ifc_led_reg$D_IN; + wire ifc_led_reg$EN; + + // register ifc_led_reg + assign ifc_led_reg$D_IN = sw[3:0]; + assign ifc_led_reg$EN = 1'd1 ; + + // handling of inlined registers + + always@(posedge CLK) + begin + if (RST_N == `BSV_RESET_VALUE) + begin + ifc_led_reg <= `BSV_ASSIGNMENT_DELAY 8'd0; + end + else + begin + if (ifc_led_reg$EN) + ifc_led_reg <= `BSV_ASSIGNMENT_DELAY ifc_led_reg$D_IN; + end + end + + // synopsys translate_off + `ifdef BSV_NO_INITIAL_BLOCKS + `else // not BSV_NO_INITIAL_BLOCKS + initial + begin + ifc_led_reg = 8'hAA; + end + `endif // BSV_NO_INITIAL_BLOCKS + // synopsys translate_on +endmodule // mkTop diff --git a/copilot/examples/what4/Arithmetic.hs b/copilot/examples/what4/Arithmetic.hs index f9a4aec1a..ed7e0385c 100644 --- a/copilot/examples/what4/Arithmetic.hs +++ b/copilot/examples/what4/Arithmetic.hs @@ -21,23 +21,22 @@ spec = do efloat = extern "efloat" Nothing -- The simplest example involving numbers: equality on constant values. - void $ prop "Example 1" (forall ((constant (1 :: Int8)) == (constant 1))) + void $ prop "Example 1" (forAll ((constant (1 :: Int8)) == (constant 1))) -- Testing "a < a + 1". This should fail, because it isn't true. - void $ prop "Example 2" (forall (eint8 < (eint8 + 1))) + void $ prop "Example 2" (forAll (eint8 < (eint8 + 1))) -- Adding another condition to the above property to make it true. - void $ prop "Example 3" (forall ((eint8 < (eint8 + 1)) || (eint8 == 127))) + void $ prop "Example 3" (forAll ((eint8 < (eint8 + 1)) || (eint8 == 127))) -- Just like the previous example, but with words. - void $ prop "Example 4" (forall ((eword8 < (eword8 + 1)) || (eword8 == 255))) + void $ prop "Example 4" (forAll ((eword8 < (eword8 + 1)) || (eword8 == 255))) -- An example with floats. - void $ prop "Example 5" (forall ((2 * efloat) == (efloat + efloat))) + void $ prop "Example 5" (forAll ((2 * efloat) == (efloat + efloat))) -- Another example with floats. This fails, because it isn't true. - void $ prop "Example 6" (forall ((efloat + 1) /= efloat)) - + void $ prop "Example 6" (forAll ((efloat + 1) /= efloat)) main :: IO () main = do diff --git a/copilot/examples/what4/ArithmeticCounterExamples.hs b/copilot/examples/what4/ArithmeticCounterExamples.hs new file mode 100644 index 000000000..d56f2b7b4 --- /dev/null +++ b/copilot/examples/what4/ArithmeticCounterExamples.hs @@ -0,0 +1,110 @@ +-- | An example showing the usage of the What4 backend in copilot-theorem for +-- simple arithmetic. This example uses the 'proveWithCounterExamples' function +-- to demonstrate counterexamples in the event of invalid properties. + +module Main where + +import qualified Prelude as P +import Control.Monad (void, forM_) +import qualified Data.Map as Map + +import Language.Copilot +import Copilot.Theorem.What4 + +spec :: Spec +spec = do + -- Define some external streams. Their values are not important, so external + -- streams suffice. + let eint8 :: Stream Int8 + eint8 = extern "eint8" Nothing + eword8 :: Stream Word8 + eword8 = extern "eword8" Nothing + efloat :: Stream Float + efloat = extern "efloat" Nothing + + -- The simplest example involving numbers: equality on constant values. + void $ prop "Example 1" (forAll ((constant (1 :: Int8)) == (constant 1))) + + -- Testing "a < a + 1". This should fail, because it isn't true. + void $ prop "Example 2" (forAll (eint8 < (eint8 + 1))) + + -- Adding another condition to the above property to make it true. + void $ prop "Example 3" (forAll ((eint8 < (eint8 + 1)) || (eint8 == 127))) + + -- Just like the previous example, but with words. + void $ prop "Example 4" (forAll ((eword8 < (eword8 + 1)) || (eword8 == 255))) + + -- An example with floats. + void $ prop "Example 5" (forAll ((2 * efloat) == (efloat + efloat))) + + -- Another example with floats. This fails, because it isn't true. + void $ prop "Example 6" (forAll ((efloat + 1) /= efloat)) + +main :: IO () +main = do + spec' <- reify spec + + -- Use Z3 to prove the properties. + results <- proveWithCounterExample Z3 spec' + + -- Print the results. + forM_ results $ \(nm, res) -> do + putStr $ nm <> ": " + case res of + ValidCex -> putStrLn "valid" + InvalidCex cex -> do + putStrLn "invalid" + putStrLn $ ppCounterExample cex + UnknownCex -> putStrLn "unknown" + +-- | Pretty-print a counterexample for user display. +ppCounterExample :: CounterExample -> String +ppCounterExample cex + | any P.not (baseCases cex) + = if Map.null baseCaseVals + then + " All possible extern values during the base case(s) " P.++ + "constitute a counterexample." + else + unlines $ + " The base cases failed with the following extern values:" : + map + (\((name, _), val) -> " " P.++ name P.++ ": " P.++ show val) + (Map.toList baseCaseVals) + + | P.not (inductionStep cex) + = if Map.null inductionStepVals + then + " All possible extern values during the induction step " P.++ + "constitute a counterexample." + else + unlines $ + " The induction step failed with the following extern values:" : + map + (\((name, _), val) -> " " P.++ name P.++ ": " P.++ show val) + (Map.toList inductionStepVals) + + | otherwise + = error $ + "ppCounterExample: " P.++ + "Counterexample without failing base cases or induction step" + where + allExternVals = concreteExternValues cex + + baseCaseVals = + Map.filterWithKey + (\(_, offset) _ -> + case offset of + AbsoluteOffset {} -> True + RelativeOffset {} -> False + ) + allExternVals + + inductionStepVals = + Map.filterWithKey + (\(_, offset) _ -> + case offset of + AbsoluteOffset {} -> False + RelativeOffset {} -> True + ) + allExternVals diff --git a/copilot/examples/what4/Arrays.hs b/copilot/examples/what4/Arrays.hs new file mode 100644 index 000000000..3fd74544a --- /dev/null +++ b/copilot/examples/what4/Arrays.hs @@ -0,0 +1,42 @@ +-- | An example showing the usage of the What4 backend in copilot-theorem for +-- arrays where individual elements are updated. + +{-# LANGUAGE DataKinds #-} + +module Main where + +import qualified Prelude as P +import Control.Monad (void, forM_) + +import Language.Copilot +import Copilot.Theorem.What4 + +spec :: Spec +spec = do + let pair :: Stream (Array 2 Int16) + pair = extern "pair" Nothing + + -- Check equality, indexing into array and modifying the value. Note that + -- this is trivial by equality. + void $ prop "Example 1" $ forAll $ + ((pair !! 0 =$ (+1)) ! 0) == ((pair ! 0) + 1) + + -- Same as previous example, but get a different array index (so should be + -- false). + void $ prop "Example 2" $ forAll $ + ((pair !! 0 =$ (+1)) ! 1) == ((pair ! 0) + 1) + +main :: IO () +main = do + spec' <- reify spec + + -- Use Z3 to prove the properties. + results <- prove Z3 spec' + + -- Print the results. + forM_ results $ \(nm, res) -> do + putStr $ nm <> ": " + case res of + Valid -> putStrLn "valid" + Invalid -> putStrLn "invalid" + Unknown -> putStrLn "unknown" diff --git a/copilot/examples/what4/Propositional.hs b/copilot/examples/what4/Propositional.hs index f27e027ad..4caf669d4 100644 --- a/copilot/examples/what4/Propositional.hs +++ b/copilot/examples/what4/Propositional.hs @@ -11,41 +11,65 @@ import Copilot.Theorem.What4 spec :: Spec spec = do + -- * Non-inductive propositions + -- The constant value true, which is translated as the corresponding SMT - -- boolean literal. - void $ prop "Example 1" (forall true) + -- boolean literal (and is therefore provable). + void $ prop "Example 1" (forAll true) -- The constant value false, which is translated as the corresponding SMT - -- boolean literal. - void $ prop "Example 2" (forall false) + -- boolean literal (and is therefore not provable). + void $ prop "Example 2" (forAll false) + + -- An "a or not a" proposition which does not require any sort of inductive + -- argument (but see examples 5 and 6 below for versions that do require + -- induction to solve). This is easily proven. + let a = [False] ++ b + b = not a + void $ prop "Example 3" (forAll (a || b)) + + -- An "a or not a" proposition using external streams, which is also provable. + let a = extern "a" Nothing + void $ prop "Example 4" (forAll (a || not a)) - -- An inductively defined flavor of true, which requires induction to prove, - -- and hence is found to be invalid by the SMT solver (since no inductive - -- hypothesis is made). + -- * Simple inductive propositions + -- + -- While Copilot.Theorem.What4 is not able to solve all inductive propositions + -- in general (see the "Complex inductive propositions" section below), the + -- following inductive propositions are simple enough that the heuristics in + -- Copilot.Theorem.What4 can solve them without issue. + + -- An inductively defined flavor of true. let a = [True] ++ a - void $ prop "Example 3" (forall a) + void $ prop "Example 5" (forAll a) - -- An inductively defined "a or not a" proposition, which is unprovable by - -- the SMT solver. + -- An inductively defined "a or not a" proposition (i.e., a more complex + -- version of example 3 above). let a = [False] ++ b b = [True] ++ a - void $ prop "Example 4" (forall (a || b)) - - -- A version of "a or not a" proposition which does not require any sort of - -- inductive argument, and hence is provable. - let a = [False] ++ b - b = not a - void $ prop "Example 5" (forall (a || b)) + void $ prop "Example 6" (forAll (a || b)) - -- A bit more convoluted version of Example 5, which is provable. + -- A bit more convoluted version of example 6. let a = [True, False] ++ b b = [False] ++ not (drop 1 a) - void $ prop "Example 6" (forall (a || b)) + void $ prop "Example 7" (forAll (a || b)) - -- An example using external streams. - let a = extern "a" Nothing - void $ prop "Example 7" (forall (a || not a)) + -- * Complex induction propositions + -- + -- The heuristics in Copilot.Theorem.What4 are not able to prove these + -- inductive propositions, so these will be reported as unprovable, even + -- though each proposition is actually provable. + + -- An inductively defined flavor of true (i.e., a more complex version of + -- example 5 above). + let a = [True] ++ ([True] ++ ([True] ++ a)) + void $ prop "Example 8" (forAll a) + -- An inductively defined "a or not a" proposition (i.e., a more complex + -- version of example 6 above). + let a = [False] ++ ([False] ++ ([False] ++ b)) + b = [True] ++ ([True] ++ ([True] ++ a)) + void $ prop "Example 9" (forAll (a || b)) main :: IO () main = do diff --git a/copilot/examples/what4/Structs.hs b/copilot/examples/what4/Structs.hs index 2fc1b254a..cff433c4e 100644 --- a/copilot/examples/what4/Structs.hs +++ b/copilot/examples/what4/Structs.hs @@ -2,53 +2,56 @@ -- structs and arrays. Particular focus is on nested structs. -- For general usage of structs, refer to the general structs example. -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} module Main where import qualified Prelude as P import Control.Monad (void, forM_) +import GHC.Generics (Generic) import Language.Copilot import Copilot.Theorem.What4 - -- | Definition for `Volts`. data Volts = Volts - { numVolts :: Field "numVolts" Word16 - , flag :: Field "flag" Bool - } + { numVolts :: Field "numVolts" Word16 + , flag :: Field "flag" Bool + } + deriving Generic -- | `Struct` instance for `Volts`. instance Struct Volts where - typename _ = "volts" - toValues volts = [ Value Word16 (numVolts volts) - , Value Bool (flag volts) - ] + typeName = typeNameDefault + toValues = toValuesDefault + -- Note that we do not implement `updateField` here. `updateField` is only + -- needed to make updates to structs work in the Copilot interpreter, and we + -- do not use the interpreter in this example. (See + -- `examples/StructsUpdateField.hs` for an example that does implement + -- `updateField`.) -- | `Volts` instance for `Typed`. instance Typed Volts where - typeOf = Struct (Volts (Field 0) (Field False)) + typeOf = typeOfDefault data Battery = Battery - { temp :: Field "temp" Word16 - , volts :: Field "volts" (Array 10 Volts) - , other :: Field "other" (Array 10 (Array 5 Word32)) - } + { temp :: Field "temp" Word16 + , volts :: Field "volts" (Array 10 Volts) + , other :: Field "other" (Array 10 (Array 5 Word32)) + } + deriving Generic -- | `Battery` instance for `Struct`. instance Struct Battery where - typename _ = "battery" - toValues battery = [ Value typeOf (temp battery) - , Value typeOf (volts battery) - , Value typeOf (other battery) - ] - --- | `Battery` instance for `Typed`. Note that `undefined` is used as an --- argument to `Field`. This argument is never used, so `undefined` will never --- throw an error. + typeName = typeNameDefault + toValues = toValuesDefault + -- Note that we do not implement `updateField` here for the same reasons as in + -- the `Struct Volts` instance above. + +-- | `Battery` instance for `Typed`. instance Typed Battery where - typeOf = Struct (Battery (Field 0) (Field undefined) (Field undefined)) + typeOf = typeOfDefault spec :: Spec spec = do @@ -57,14 +60,17 @@ spec = do -- Check equality, indexing into nested structs and arrays. Note that this is -- trivial by equality. - void $ prop "Example 1" $ forall $ - (((battery#volts) .!! 0)#numVolts) == (((battery#volts) .!! 0)#numVolts) + void $ prop "Example 1" $ forAll $ + (((battery#volts) ! 0)#numVolts) == (((battery#volts) ! 0)#numVolts) -- Same as previous example, but get a different array index (so should be -- false). - void $ prop "Example 2" $ forall $ - (((battery#other) .!! 2) .!! 3) == (((battery#other) .!! 2) .!! 4) + void $ prop "Example 2" $ forAll $ + (((battery#other) ! 2) ! 3) == (((battery#other) ! 2) ! 4) + -- Update a struct field, then check it for equality. + void $ prop "Example 3" $ forAll $ + ((battery ## temp =$ (+1))#temp == (battery#temp + 1)) main :: IO () main = do diff --git a/copilot/src/Language/Copilot/Main.hs b/copilot/src/Language/Copilot/Main.hs index d243b4782..cc23524b3 100644 --- a/copilot/src/Language/Copilot/Main.hs +++ b/copilot/src/Language/Copilot/Main.hs @@ -3,9 +3,10 @@ module Language.Copilot.Main ( copilotMain, defaultMain ) where import qualified Copilot.Core as C (Spec) -import Copilot.Language (interpret, prettyPrint) +import Copilot.Language (interpret) import Copilot.Language.Reify (reify) import Copilot.Language (Spec) +import qualified Copilot.PrettyPrint as PP import Options.Applicative import Data.Semigroup ((<>)) @@ -44,7 +45,6 @@ cmdargs = CmdArgs <> metavar "INT" <> showDefault <> help "Interpret specification and write result to output") - -- | Create a main to either compile or interpret a copilot specification. -- -- This function must be provided an auxiliary function capable of compiling @@ -63,18 +63,19 @@ cmdargs = CmdArgs -- * @--interpret/-i NUM@: interpret the specification for a given number -- of steps. copilotMain :: Interpreter -> Printer -> Compiler -> Spec -> IO () -copilotMain interp pretty comp spec = main =<< execParser opts where - opts = info (cmdargs <**> helper) fullDesc +copilotMain interp pretty comp spec = main =<< execParser opts + where + opts = info (cmdargs <**> helper) fullDesc - main :: CmdArgs -> IO () - main args = do - let iters = ainterpret args - when (apretty args) $ pretty spec - when (iters Prelude.> 0) $ interp (fromIntegral iters) spec + main :: CmdArgs -> IO () + main args = do + let iters = ainterpret args + when (apretty args) $ pretty spec + when (iters Prelude.> 0) $ interp (fromIntegral iters) spec - when (not $ acompile args) $ do - spec' <- reify spec - comp (aoutput args) spec' + when (not $ acompile args) $ do + spec' <- reify spec + comp (aoutput args) spec' -- | Create a main function with a default interpreter and pretty printer. -- @@ -86,3 +87,8 @@ copilotMain interp pretty comp spec = main =<< execParser opts where -- command line options. defaultMain :: Compiler -> Spec -> IO () defaultMain = copilotMain interpret prettyPrint + where + -- Transform a high-level Copilot Language specification into a low-level + -- Copilot Core specification and pretty-print it to stdout. + prettyPrint :: Spec -> IO () + prettyPrint e = fmap PP.prettyPrint (reify e) >>= putStr