From 39955b81ca3a2ed84702be73ebb3e67baeb9af06 Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Wed, 28 May 2025 15:14:33 -0400 Subject: [PATCH 01/25] copilot-bluespec: Include in mainline copilot repo. Refs #623. The `copilot-bluespec` package was originally developed in an external repo (https://github.com/Copilot-Language/copilot-bluespec), but there is interest in having all Copilot projects and libraries merged into the main https://github.com/Copilot-Language/copilot repo for ease of management. This commit includes the last state of the old `copilot-bluespec` repo into the main Copilot repo as a new subdirectory, disregarding the commit history. --- copilot-bluespec/.dockerignore | 29 + copilot-bluespec/CHANGELOG | 35 + copilot-bluespec/DESIGN.md | 928 +++++++++++ copilot-bluespec/Dockerfile | 36 + copilot-bluespec/LICENSE | 29 + copilot-bluespec/README.md | 57 + copilot-bluespec/Setup.hs | 2 + copilot-bluespec/copilot-bluespec.cabal | 100 ++ .../src/Copilot/Compile/Bluespec.hs | 12 + .../src/Copilot/Compile/Bluespec/CodeGen.hs | 262 +++ .../src/Copilot/Compile/Bluespec/Compile.hs | 350 ++++ .../src/Copilot/Compile/Bluespec/Error.hs | 20 + .../src/Copilot/Compile/Bluespec/Expr.hs | 671 ++++++++ .../src/Copilot/Compile/Bluespec/External.hs | 57 + .../Copilot/Compile/Bluespec/FloatingPoint.hs | 171 ++ .../src/Copilot/Compile/Bluespec/Name.hs | 95 ++ .../Compile/Bluespec/Representation.hs | 22 + .../src/Copilot/Compile/Bluespec/Settings.hs | 14 + .../src/Copilot/Compile/Bluespec/Type.hs | 95 ++ copilot-bluespec/tests/Main.hs | 18 + .../tests/Test/Copilot/Compile/Bluespec.hs | 1470 +++++++++++++++++ .../Test/Copilot/Compile/Bluespec/External.hs | 63 + 22 files changed, 4536 insertions(+) create mode 100644 copilot-bluespec/.dockerignore create mode 100644 copilot-bluespec/CHANGELOG create mode 100644 copilot-bluespec/DESIGN.md create mode 100644 copilot-bluespec/Dockerfile create mode 100644 copilot-bluespec/LICENSE create mode 100644 copilot-bluespec/README.md create mode 100644 copilot-bluespec/Setup.hs create mode 100644 copilot-bluespec/copilot-bluespec.cabal create mode 100644 copilot-bluespec/src/Copilot/Compile/Bluespec.hs create mode 100644 copilot-bluespec/src/Copilot/Compile/Bluespec/CodeGen.hs create mode 100644 copilot-bluespec/src/Copilot/Compile/Bluespec/Compile.hs create mode 100644 copilot-bluespec/src/Copilot/Compile/Bluespec/Error.hs create mode 100644 copilot-bluespec/src/Copilot/Compile/Bluespec/Expr.hs create mode 100644 copilot-bluespec/src/Copilot/Compile/Bluespec/External.hs create mode 100644 copilot-bluespec/src/Copilot/Compile/Bluespec/FloatingPoint.hs create mode 100644 copilot-bluespec/src/Copilot/Compile/Bluespec/Name.hs create mode 100644 copilot-bluespec/src/Copilot/Compile/Bluespec/Representation.hs create mode 100644 copilot-bluespec/src/Copilot/Compile/Bluespec/Settings.hs create mode 100644 copilot-bluespec/src/Copilot/Compile/Bluespec/Type.hs create mode 100644 copilot-bluespec/tests/Main.hs create mode 100644 copilot-bluespec/tests/Test/Copilot/Compile/Bluespec.hs create mode 100644 copilot-bluespec/tests/Test/Copilot/Compile/Bluespec/External.hs 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..e062468a0 --- /dev/null +++ b/copilot-bluespec/CHANGELOG @@ -0,0 +1,35 @@ +2025-05-08 + * Version bump (4.4). (#43) + +2025-05-05 + * Version bump (4.3.1). (#41) + * Move Copilot.Compile.Bluespec.External out of shared directory. (#36) + * Allow building with filepath-1.5.*. (#39) + +2025-03-10 + * Version bump (4.3). (#34) + +2025-01-20 + * Version bump (4.2). (#31) + * Implement missing floating-point operations. (#28) + * Allow using same trigger name in multiple declarations. (#30) + +2024-11-08 + * Version bump (4.1). (#25) + +2024-09-09 + * Version bump (4.0). (#23) + * Support translating Copilot array updates to Bluespec. (#19) + +2024-08-03 + * Test GHC 9.4 through 9.8. (#20) + +2024-07-11 + * Version bump (3.20). (#11) + * Support translating Copilot struct updates to Bluespec (#10). + * Fix a bug in the translation of the signum function. (#14) + * Fix a bug in the translation of floating-point comparisons. (#15) + +2024-03-08 + * Version bump (3.19). (#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..dffb607ac --- /dev/null +++ b/copilot-bluespec/DESIGN.md @@ -0,0 +1,928 @@ +# 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 five 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. + +* `FibsTypes.bs`: If the Copilot specification contains any structs, then this + file will contain the corresponding Bluespec struct definitions. The + specification 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. Note that the syntax used here is much like in Haskell, with a + notable difference being that Bluespec uses the `package` keyword instead of + `module`. + +* `FibsIfc.bs`: This file defines a _module interface_ `FibsIfc`, whose methods + correspond to the names of the triggers in the Copilot spec: + + ```bluespec + package FibsIfc where + + import FloatingPoint + import Vector + + import FibsTypes + + interface FibsIfc = + even :: UInt 32 -> Action + odd :: UInt 32 -> Action + ``` + + 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. Each method takes a `UInt + 32` (an unsigned 32-bit integer) as an argument and return an `Action`, which + is the Bluespec type for expressions that act on the state of the circuit (at + circuit execution time). Possible `Action`s include reading from and writing + to registers, as well as printing messages. + + We will see an example of how to instantiate `FibsIfc` later. + +* `Fibs.bs`: This file defines a `mkFibs` function, which orchestrates + everything in the generated Bluespec monitor: + + ```bluespec + package Fibs where + + import FloatingPoint + import Vector + + import FibsTypes + import FibsIfc + import BluespecFP + + mkFibs :: Module FibsIfc -> Module Empty + mkFibs ifcMod = + module + ifc <- ifcMod + + 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 + + even_guard :: Bool + even_guard = + (s0_get 0 % 2) == 0 + + odd_guard :: Bool + odd_guard = + not (s0_get 0 % 2 == 0) + + rules + "even": when even_guard ==> + ifc.even (s0_get 0) + + "odd:": when odd_guard ==> + ifc.odd (s0_get 0) + + "step": when True ==> + action + select s0 s0_idx := s0_gen + s0_idx := (s0_idx + 1) % 2 + ``` + + `mkFibs` returns a module, which can be thought of as a generator of hardware + objects. `mkFibs` takes a `FibsIfc` module as an argument and returns another + module, which is parameterized by `Empty`. `Empty` is a standard interface + with no methods, and `Empty` is typically used in top-level modules that act + as program entrypoints. + + Note that the `module` and `action` keywords 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 `Monad` monad describes how to elaborate + the structure of a module, whereas the `ActionValue` monad describes the + behavior of a circuit at execution time. + +* `BluespecFP.bsv`: 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. + +In a larger application, a Copilot user would instantiate `mkFibs` with a +`FibsIfc` module that describes what should happen when the `even` and `odd` +triggers fire. `FibsIfc` contains everything that the user must supply; +everything else is handled within the module that `mkFibs` returns. + +Here is an example of a larger application might look like: + +```bluespec +package Top where + +import Fibs +import FibsIfc +import FibsTypes + +fibsIfc :: Module FibsIfc +fibsIfc = + module + interface + even x = + $display "Even Fibonacci number: %0d" x + + odd x = + $display "Odd Fibonacci number: %0d" x + +mkTop :: Module Empty +mkTop = mkFibs fibsIfc +``` + +`mkTop` is the top-level module that we will use as a program entrypoint. The +only interesting thing that it does is instantiate `mkFibs` with a custom +`FibsIfc`, where `even` and `odd` are defined to display a custom message +whenever an even or odd Fibonacci number is encountered, respectively. + +We can run `mkTop` by using Bluespec's simulator like so: + +``` +$ bsc -sim -g mkTop -u Top.bs +checking package dependencies +compiling Top.bs +code generation for mkTop starts +Elaborated module file created: mkTop.ba +All packages are up to date. + +$ bsc -sim -e mkTop -o mkTop.exe bs_fp.c +Bluesim object created: mkTop.{h,o} +Bluesim object created: model_mkTop.{h,o} +Simulation shared library created: mkTop.exe.so +Simulation executable created: mkTop.exe + +$ ./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. + +## 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.hs` example: + +```bluespec + rules + "even": when even_guard ==> + ifc.even (s0_get 0) + + "odd:": when odd_guard ==> + ifc.odd (s0_get 0) + + "step": when True ==> do + select s0 s0_idx := s0_gen + s0_idx := (s0_idx + 1) % 2 +``` + +Each rule consists of three parts: + +1. A label (e.g., `"even"`) 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 (e.g., `ifc.even (s0_get 0)`), 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` +or `odd` method of `FibsIfcs`, respectively. The definitions of `even_guard` +and `odd_guard` are: + +```bluespec + even_guard :: Bool + even_guard = + (s0_get 0 % 2) == 0 + + odd_guard :: Bool + odd_guard = + not (s0_get 0 % 2 == 0) +``` + +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 + rules + "even": when even_guard ==> + ifc.even (s0_get 0) + + "odd:": when odd_guard ==> + ifc.odd (s0_get 0) + + "step": when True ==> do + select s0 s0_idx := s0_gen + s0_idx := (s0_idx + 1) % 2 +``` + +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 behavior of +`s0_get` (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. To see what happens when a specification uses an +external stream, let's make one small change to the example: + +```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 two notable changes worth commenting on. The first change is in +`FibsIfc.bs`: + +```bluespec +package FibsIfc where + +import FloatingPoint +import Vector + +import FibsTypes + +interface FibsIfc = + even :: UInt 32 -> Action + odd :: UInt 32 -> Action + fibs :: Reg (UInt 32) +``` + +This time, the `FibsIfc` interface has an additional `fibs` method of type `Reg +(UInt 32)`. This register corresponds to the external stream that we just +defined, and it is the responsibility of the application which instantiates +`FibsIfc` to dictate what values should be written to the register. + +The second change is in `Fibs.bs`: + +```bluespec +package Fibs where + +import FloatingPoint +import Vector + +import FibsTypes +import FibsIfc + +mkFibs :: Module FibsIfc -> Module Empty +mkFibs ifcMod = + module + ifc <- ifcMod + + let even_guard :: Bool + even_guard = + (ifc.fibs._read % 2) == 0 + + odd_guard :: Bool + odd_guard = + not (ifc.fibs._read % 2 == 0) + + rules + "even": when even_guard ==> + ifc.even ifc.fibs._read + + "odd:": when odd_guard ==> + ifc.odd ifc.fibs._read +``` + +This time, the only stream that is referenced is `ifc.fibs`. As a consequence, +the `s0` stream, the `s0_idx` index, and the `"step"` rule are no longer +necessary, making the code considerably simpler. + +The flip side to having the generated code be simpler is that the application +which uses `mkFibs` must now do additional work to specify what the value of +`ifc.fibs` is. For example, we can port the behavior of the previous version +of the program like so: + +```bluespec +package Top where + +import Vector + +import Fibs +import FibsIfc +import FibsTypes + +fibsIfc :: Module FibsIfc +fibsIfc = + 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 + + fibs_impl :: Reg (UInt 32) <- mkReg 1 + + interface + even x = + $display "Even Fibonacci number: %0d" x + + odd x = + $display "Odd Fibonacci number: %0d" x + + fibs = fibs_impl + + rules + "fibs": when True ==> + fibs_impl := s0_get 1 + + "step": when True ==> + action + select s0 s0_idx := s0_gen + s0_idx := (s0_idx + 1) % 2 + +mkTop :: Module Empty +mkTop = mkFibs fibsIfc +``` + +The code involving `s0`, `s0_idx`, and the `"step"` rule is exactly as before. +The only notable difference is that we create an additional `fibs_impl` +register, declare `fibs = fibs_impl` when instantiating the `FibsIfc` +interface, and declare an additional `"fibs"` rule to update the value of +`fibs_impl` on each clock cycle. Note that we always set the value of +`fibs_impl` to be `s0_get 1`, which corresponds to the most recently computed +Fibonacci number. If we set `fibs_impl` to be `s0_get 0` instead, then +`fibs_impl` would lag behind by one cycle. (Try it.) + +# 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..6509e7e2a --- /dev/null +++ b/copilot-bluespec/copilot-bluespec.cabal @@ -0,0 +1,100 @@ +cabal-version : >= 1.10 +name : copilot-bluespec +version : 4.4 +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 + +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 + , pretty >= 1.1.2 && < 1.2 + + , copilot-core >= 4.4 && < 4.5 + , 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 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..6d9fde04d --- /dev/null +++ b/copilot-bluespec/src/Copilot/Compile/Bluespec/CodeGen.hs @@ -0,0 +1,262 @@ +{-# 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 + + -- * Monitor processing + , mkStepRule + , mkTriggerRule + + -- * Module interface specifications + , mkSpecIfcFields + ) 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 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 :: [Trigger] -> [External] -> [BS.CField] +mkSpecIfcFields triggers exts = + map mkTriggerField triggers ++ map mkExtField exts + where + -- trigger :: args_1 -> ... -> args_n -> Action + mkTriggerField :: Trigger -> BS.CField + mkTriggerField (Trigger name _ args) = + mkField name $ + foldr + (\(UExpr arg _) res -> BS.tArrow `BS.TAp` transType arg `BS.TAp` res) + BS.tAction + args + + -- ext :: Reg ty + mkExtField :: External -> BS.CField + mkExtField (External name ty) = + mkField name $ tReg `BS.TAp` transType ty + +-- | Define a rule for a trigger function. +mkTriggerRule :: UniqueTrigger -> BS.CRule +mkTriggerRule (UniqueTrigger uniqueName (Trigger name _ args)) = + BS.CRule + [] + (Just $ cLit $ BS.LString uniqueName) + [ BS.CQFilter $ + BS.CVar $ BS.mkId BS.NoPos $ + fromString $ guardName uniqueName + ] + (BS.CApply nameExpr args') + where + ifcArgId = BS.mkId BS.NoPos $ fromString ifcArgName + -- Note that we use 'name' here instead of 'uniqueName', as 'name' is the + -- name of the actual external function. + nameId = BS.mkId BS.NoPos $ fromString $ lowercaseName name + nameExpr = BS.CSelect (BS.CVar ifcArgId) nameId + + args' = take (length args) (map argCall (argNames uniqueName)) + argCall = BS.CVar . 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 type. +mkField :: String -> BS.CType -> BS.CField +mkField name ty = + BS.CField + { BS.cf_name = BS.mkId BS.NoPos $ fromString $ lowercaseName name + , BS.cf_pragmas = Nothing + , 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] + } 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..c4701eaf7 --- /dev/null +++ b/copilot-bluespec/src/Copilot/Compile/Bluespec/Compile.hs @@ -0,0 +1,350 @@ +{-# 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 + ifcBsFile = render $ pPrint $ compileIfcBS 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 specIfcPkgName prefix ++ ".bs") ifcBsFile + 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. +-- +-- The generated Bluespec file will import a handful of files from the standard +-- library, as well as the following generated files: +-- +-- * @Ifc.bs@, which defines the interface containing the trigger +-- functions and external variables. +-- +-- * @Types.bs@, which defines any structs used in the 'Spec'. +-- +-- It will also generate a @mk :: Module Ifc -> Module Empty@ +-- function, which defines the module structure for this 'Spec'. The +-- @mk@ function has the following structure: +-- +-- * First, bind the argument of type @Module Ifc@ so that trigger +-- functions can be invoked and external variables can be used. +-- +-- * Next, declare stream buffers and indices. +-- +-- * Next, declare generator functions for streams, accessor functions for +-- streams, and guard functions for triggers. +-- +-- * Next, declare rules for each trigger function. +-- +-- * Finally, declare a single rule that updates the stream buffers and +-- indices. +compileBS :: BluespecSettings -> String -> Spec -> BS.CPackage +compileBS _bsSettings prefix spec = + BS.CPackage + (BS.mkId BS.NoPos (fromString prefix)) + (Right []) + (stdLibImports ++ genImports) + [] + [moduleDef] + [] + where + -- import Types + -- import Ifc + genImports :: [BS.CImport] + genImports = + [ BS.CImpId False $ BS.mkId BS.NoPos $ fromString + $ specTypesPkgName prefix + , BS.CImpId False $ BS.mkId BS.NoPos $ fromString + $ specIfcPkgName prefix + , BS.CImpId False $ BS.mkId BS.NoPos "BluespecFP" + ] + + moduleDef :: BS.CDefn + moduleDef = BS.CValueSign $ + BS.CDef + (BS.mkId BS.NoPos $ fromString $ "mk" ++ prefix) + -- :: Module Ifc -> Module Empty + (BS.CQType + [] + (BS.tArrow + `BS.TAp` (BS.tModule `BS.TAp` ifcTy) + `BS.TAp` (BS.tModule `BS.TAp` emptyTy))) + [ BS.CClause [BS.CPVar ifcModId] [] $ + BS.Cmodule BS.NoPos $ + BS.CMStmt + (BS.CSBind (BS.CPVar ifcArgId) Nothing [] (BS.CVar ifcModId)) + : map BS.CMStmt mkGlobals ++ + [ BS.CMStmt $ BS.CSletrec genFuns + , BS.CMrules $ BS.Crules [] rules + ] + ] + + ifcArgId = BS.mkId BS.NoPos $ fromString ifcArgName + ifcModId = BS.mkId BS.NoPos "ifcMod" + + rules :: [BS.CRule] + rules = map mkTriggerRule uniqueTriggers ++ maybeToList (mkStepRule streams) + + streams = specStreams spec + triggers = specTriggers spec + uniqueTriggers = mkUniqueTriggers triggers + exts = gatherExts streams triggers + + ifcId = BS.mkId BS.NoPos $ fromString $ specIfcName prefix + ifcFields = mkSpecIfcFields triggers 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) + }) + + emptyTy = BS.TCon (BS.TyCon + { BS.tcon_name = BS.idEmpty + , BS.tcon_kind = Just BS.KStar + , BS.tcon_sort = BS.TIstruct (BS.SInterface []) [] + }) + + -- 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, including trigger arguments. + genFuns :: [BS.CDefl] + genFuns = map accessDecln streams + ++ map streamGen streams + ++ concatMap triggerGen uniqueTriggers + 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 + + triggerGen :: UniqueTrigger -> [BS.CDefl] + triggerGen (UniqueTrigger uniqueName (Trigger _name guard args)) = + guardDef : argDefs + where + 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 @Ifc.bs@ file from a 'Spec'. This contains the +-- definition of the @Ifc@ interface, which declares the types of all +-- trigger functions and external variables. This is put in a separate file so +-- that larger applications can use it separately. +compileIfcBS :: BluespecSettings -> String -> Spec -> BS.CPackage +compileIfcBS _bsSettings prefix spec = + BS.CPackage + ifcPkgId + (Right []) + (stdLibImports ++ genImports) + [] + [ifcDef] + [] + where + -- import Types + genImports :: [BS.CImport] + genImports = + [ BS.CImpId False $ BS.mkId BS.NoPos $ fromString + $ specTypesPkgName prefix + ] + + ifcId = BS.mkId BS.NoPos $ fromString $ specIfcName prefix + ifcPkgId = BS.mkId BS.NoPos $ fromString $ specIfcPkgName prefix + ifcFields = mkSpecIfcFields triggers exts + + streams = specStreams spec + exts = gatherExts streams triggers + + -- Remove duplicates due to multiple guards for the same trigger. + triggers = nubBy compareTrigger (specTriggers spec) + + ifcDef :: BS.CDefn + ifcDef = BS.Cstruct + True + (BS.SInterface []) + (BS.IdK ifcId) + [] -- No type variables + ifcFields + [] -- No derived instances + +-- | 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..c4978aef5 --- /dev/null +++ b/copilot-bluespec/src/Copilot/Compile/Bluespec/Expr.hs @@ -0,0 +1,671 @@ +{-# 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 + +-- 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 _) = + let ifcArgId = BS.mkId BS.NoPos $ fromString ifcArgName in + BS.CSelect + (BS.CSelect + (BS.CVar ifcArgId) + (BS.mkId BS.NoPos $ fromString $ lowercaseName 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 . realToFrac + 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)) + +-- | 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 intentionally does not support negative literal syntax (e.g., + -- -42.5), so we must create negative floating-point literals using the + -- `negate` function. + | d >= 0 = withTypeAnnotation ty $ cLit $ BS.LReal d + | otherwise = withTypeAnnotation ty $ + BS.CApply + (BS.CVar $ BS.idNegateAt BS.NoPos) + [cLit $ BS.LReal $ negate d] + +-- | 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..dbc714a3b --- /dev/null +++ b/copilot-bluespec/src/Copilot/Compile/Bluespec/Name.hs @@ -0,0 +1,95 @@ +-- | Naming of variables and functions in Bluespec. +module Copilot.Compile.Bluespec.Name + ( argNames + , generatorName + , guardName + , ifcArgName + , indexName + , lowercaseName + , specIfcName + , specIfcPkgName + , specTypesPkgName + , streamAccessorName + , streamElemName + , streamName + , uppercaseName + ) 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 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 the variable of type @Ifc@. This is used to select +-- trigger functions and external variables. +ifcArgName :: String +ifcArgName = "ifc" + +-- | 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 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..ee99c6e75 --- /dev/null +++ b/copilot-bluespec/tests/Test/Copilot/Compile/Bluespec.hs @@ -0,0 +1,1470 @@ +{-# 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 CopilotTestIfc" + , "import CopilotTestTypes" + , "" + , "copilotTestIfc :: Module CopilotTestIfc" + , "copilotTestIfc =" + , " module" + , " interface" + , " nop :: Action" + , " nop = return ()" + , "" + , "mkTop :: Module Empty" + , "mkTop = mkCopilotTest copilotTestIfc" + ] + + 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 = "input" + +-- | 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 = "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 + { 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 CopilotTestIfc" + , "import CopilotTestTypes" + , "" + ] + ++ inputVecDecls ++ + [ "" + , "copilotTestIfc :: Module CopilotTestIfc" + , "copilotTestIfc =" + , " module" + ] + ++ inputRegs ++ + [ " i :: Reg (Bit 64) <- mkReg 0" + , " ready :: Reg Bool <- mkReg False" + , " interface" + , " printBack :: " ++ outputType ++ " -> Action" + , " printBack output = $display " ++ printBackDisplayArgs + , " when ready" + , "" + ] + ++ inputMethods ++ + [ "" + , " rules" + , " \"inputs\": when True ==> do" + ] + ++ inputUpdates ++ + [ " i := i + 1" + , " ready := True" + , "" + , "mkTop :: Module Empty" + , "mkTop = mkCopilotTest copilotTestIfc" + ] + 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 = + concatMap + (\(bluespecType, varName, regName, _inputVecName, _inputVals) -> + [ " " ++ varName ++ " :: Reg (" ++ bluespecType ++ ")" + , " " ++ varName ++ " = " ++ 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) From 54674815ef416b4ad660199f31e4abec27632175 Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Tue, 3 Jun 2025 11:12:14 -0400 Subject: [PATCH 02/25] copilot-bluespec: Adjust issue numbers in changelog. Refs #623. The `copilot-bluespec` package was originally developed in an external repo (https://github.com/Copilot-Language/copilot-bluespec), but there is interest in having all Copilot projects and libraries merged into the main https://github.com/Copilot-Language/copilot repo for ease of management. Now that the `copilot-bluespec` package lives in the `copilot` repo, this adjusts the issue numbers in the `copilot-bluespec` changelog to refer to the old repo so that they will not be confused with issues in the `copilot` repo. --- copilot-bluespec/CHANGELOG | 40 ++++++++++++++++++++++---------------- 1 file changed, 23 insertions(+), 17 deletions(-) diff --git a/copilot-bluespec/CHANGELOG b/copilot-bluespec/CHANGELOG index e062468a0..d1ba77494 100644 --- a/copilot-bluespec/CHANGELOG +++ b/copilot-bluespec/CHANGELOG @@ -1,35 +1,41 @@ 2025-05-08 - * Version bump (4.4). (#43) + * Version bump (4.4). (copilot-bluespec#43) 2025-05-05 - * Version bump (4.3.1). (#41) - * Move Copilot.Compile.Bluespec.External out of shared directory. (#36) - * Allow building with filepath-1.5.*. (#39) + * 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). (#34) + * Version bump (4.3). (copilot-bluespec#34) 2025-01-20 - * Version bump (4.2). (#31) - * Implement missing floating-point operations. (#28) - * Allow using same trigger name in multiple declarations. (#30) + * 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). (#25) + * Version bump (4.1). (copilot-bluespec#25) 2024-09-09 - * Version bump (4.0). (#23) - * Support translating Copilot array updates to Bluespec. (#19) + * 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. (#20) + * Test GHC 9.4 through 9.8. (copilot-bluespec#20) 2024-07-11 - * Version bump (3.20). (#11) - * Support translating Copilot struct updates to Bluespec (#10). - * Fix a bug in the translation of the signum function. (#14) - * Fix a bug in the translation of floating-point comparisons. (#15) + * 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). (#5) + * Version bump (3.19). (copilot-bluespec#5) * Create new library for Bluespec backend. From 7433ba32d87727f947357f78293bd8b900bba0f6 Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Wed, 28 May 2025 15:15:36 -0400 Subject: [PATCH 03/25] copilot-bluespec: Document changes in CHANGELOG. Refs #623. --- copilot-bluespec/CHANGELOG | 3 +++ 1 file changed, 3 insertions(+) diff --git a/copilot-bluespec/CHANGELOG b/copilot-bluespec/CHANGELOG index d1ba77494..10f4486ec 100644 --- a/copilot-bluespec/CHANGELOG +++ b/copilot-bluespec/CHANGELOG @@ -1,3 +1,6 @@ +2025-05-18 + * Include `copilot-bluespec` in mainline `copilot` repo. (#623) + 2025-05-08 * Version bump (4.4). (copilot-bluespec#43) From fd769d4645f8c8e5cf6e457b719fc5fa7f93979e Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Fri, 20 Jun 2025 10:44:36 -0400 Subject: [PATCH 04/25] Explicitly list .cabal files in cabal.project. Refs #622. The `copilot-verifier` package was originally developed in an external repo (https://github.com/Copilot-Language/copilot-verifier), but there is interest in having all Copilot projects and libraries merged into the main https://github.com/Copilot-Language/copilot repo for ease of management. For now, we wish not to add `copilot-verifier` to the `cabal.project` file, as its version bounds are tighter than the range of GHC versions that `copilot` currently supports. As such, this commit explicitly lists the `.cabal` files of packages that we do want to include in the `cabal.project`, i.e., all of the `.cabal` files except for `copilot-verifier.cabal`. --- cabal.project | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) 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 From c8f422175ce480bc6655c0bb6207d122b42ccf71 Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Fri, 20 Jun 2025 10:03:13 -0400 Subject: [PATCH 05/25] copilot-verifier: Include in mainline copilot repo. Refs #622. The `copilot-verifier` package was originally developed in an external repo (https://github.com/Copilot-Language/copilot-verifier), but there is interest in having all Copilot projects and libraries merged into the main https://github.com/Copilot-Language/copilot repo for ease of management. This commit includes the last state of the old `copilot-verified` repo into the main Copilot repo as a new subdirectory, disregarding the commit history. --- copilot-verifier/CHANGELOG | 40 + copilot-verifier/LICENSE | 30 + copilot-verifier/README.md | 351 ++++ copilot-verifier/copilot-verifier.cabal | 152 ++ .../examples/Copilot/Verifier/Examples.hs | 97 + .../Examples/ShouldFail/Partial/AbsIntMin.hs | 28 + .../ShouldFail/Partial/AddSignedWrap.hs | 27 + .../Examples/ShouldFail/Partial/DivByZero.hs | 27 + .../ShouldFail/Partial/IndexOutOfBounds.hs | 31 + .../Examples/ShouldFail/Partial/ModByZero.hs | 27 + .../ShouldFail/Partial/MulSignedWrap.hs | 31 + .../ShouldFail/Partial/ShiftLTooLarge.hs | 32 + .../ShouldFail/Partial/ShiftRTooLarge.hs | 32 + .../ShouldFail/Partial/SubSignedWrap.hs | 27 + .../Verifier/Examples/ShouldPass/Arith.hs | 52 + .../Verifier/Examples/ShouldPass/Array.hs | 40 + .../Verifier/Examples/ShouldPass/ArrayGen.hs | 21 + .../Examples/ShouldPass/ArrayOfStructs.hs | 29 + .../ShouldPass/ArrayTriggerArgument.hs | 23 + .../Verifier/Examples/ShouldPass/Clock.hs | 46 + .../Verifier/Examples/ShouldPass/Counter.hs | 56 + .../Verifier/Examples/ShouldPass/Engine.hs | 44 + .../Examples/ShouldPass/FPNegation.hs | 62 + .../Verifier/Examples/ShouldPass/FPOps.hs | 88 + .../Verifier/Examples/ShouldPass/Heater.hs | 60 + .../Verifier/Examples/ShouldPass/IntOps.hs | 64 + .../Examples/ShouldPass/Partial/AbsIntMin.hs | 19 + .../ShouldPass/Partial/AddSignedWrap.hs | 19 + .../Examples/ShouldPass/Partial/DivByZero.hs | 19 + .../ShouldPass/Partial/IndexOutOfBounds.hs | 19 + .../Examples/ShouldPass/Partial/ModByZero.hs | 19 + .../ShouldPass/Partial/MulSignedWrap.hs | 19 + .../ShouldPass/Partial/ShiftLTooLarge.hs | 19 + .../ShouldPass/Partial/ShiftRTooLarge.hs | 19 + .../ShouldPass/Partial/SubSignedWrap.hs | 19 + .../Verifier/Examples/ShouldPass/Structs.hs | 92 + .../Examples/ShouldPass/UpdateArray.hs | 32 + .../Examples/ShouldPass/UpdateStruct.hs | 62 + .../Verifier/Examples/ShouldPass/Voting.hs | 64 + .../Verifier/Examples/ShouldPass/WCV.hs | 189 ++ copilot-verifier/exe/VerifyExamples.hs | 53 + copilot-verifier/src/Copilot/Verifier.hs | 1607 +++++++++++++++++ .../src/Copilot/Verifier/FloatMode.hs | 56 + copilot-verifier/src/Copilot/Verifier/Log.hs | 834 +++++++++ .../src/Copilot/Verifier/Solver.hs | 25 + copilot-verifier/test/Test.hs | 32 + 46 files changed, 4734 insertions(+) create mode 100644 copilot-verifier/CHANGELOG create mode 100644 copilot-verifier/LICENSE create mode 100644 copilot-verifier/README.md create mode 100644 copilot-verifier/copilot-verifier.cabal create mode 100644 copilot-verifier/examples/Copilot/Verifier/Examples.hs create mode 100644 copilot-verifier/examples/Copilot/Verifier/Examples/ShouldFail/Partial/AbsIntMin.hs create mode 100644 copilot-verifier/examples/Copilot/Verifier/Examples/ShouldFail/Partial/AddSignedWrap.hs create mode 100644 copilot-verifier/examples/Copilot/Verifier/Examples/ShouldFail/Partial/DivByZero.hs create mode 100644 copilot-verifier/examples/Copilot/Verifier/Examples/ShouldFail/Partial/IndexOutOfBounds.hs create mode 100644 copilot-verifier/examples/Copilot/Verifier/Examples/ShouldFail/Partial/ModByZero.hs create mode 100644 copilot-verifier/examples/Copilot/Verifier/Examples/ShouldFail/Partial/MulSignedWrap.hs create mode 100644 copilot-verifier/examples/Copilot/Verifier/Examples/ShouldFail/Partial/ShiftLTooLarge.hs create mode 100644 copilot-verifier/examples/Copilot/Verifier/Examples/ShouldFail/Partial/ShiftRTooLarge.hs create mode 100644 copilot-verifier/examples/Copilot/Verifier/Examples/ShouldFail/Partial/SubSignedWrap.hs create mode 100644 copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/Arith.hs create mode 100644 copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/Array.hs create mode 100644 copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/ArrayGen.hs create mode 100644 copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/ArrayOfStructs.hs create mode 100644 copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/ArrayTriggerArgument.hs create mode 100644 copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/Clock.hs create mode 100644 copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/Counter.hs create mode 100644 copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/Engine.hs create mode 100644 copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/FPNegation.hs create mode 100644 copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/FPOps.hs create mode 100644 copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/Heater.hs create mode 100644 copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/IntOps.hs create mode 100644 copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/Partial/AbsIntMin.hs create mode 100644 copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/Partial/AddSignedWrap.hs create mode 100644 copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/Partial/DivByZero.hs create mode 100644 copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/Partial/IndexOutOfBounds.hs create mode 100644 copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/Partial/ModByZero.hs create mode 100644 copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/Partial/MulSignedWrap.hs create mode 100644 copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/Partial/ShiftLTooLarge.hs create mode 100644 copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/Partial/ShiftRTooLarge.hs create mode 100644 copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/Partial/SubSignedWrap.hs create mode 100644 copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/Structs.hs create mode 100644 copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/UpdateArray.hs create mode 100644 copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/UpdateStruct.hs create mode 100644 copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/Voting.hs create mode 100644 copilot-verifier/examples/Copilot/Verifier/Examples/ShouldPass/WCV.hs create mode 100644 copilot-verifier/exe/VerifyExamples.hs create mode 100644 copilot-verifier/src/Copilot/Verifier.hs create mode 100644 copilot-verifier/src/Copilot/Verifier/FloatMode.hs create mode 100644 copilot-verifier/src/Copilot/Verifier/Log.hs create mode 100644 copilot-verifier/src/Copilot/Verifier/Solver.hs create mode 100644 copilot-verifier/test/Test.hs diff --git a/copilot-verifier/CHANGELOG b/copilot-verifier/CHANGELOG new file mode 100644 index 000000000..2923ff5ed --- /dev/null +++ b/copilot-verifier/CHANGELOG @@ -0,0 +1,40 @@ +2025-05-08 + * Version bump (4.4). (#85) + +2025-03-10 + * Version bump (4.3). (#82) + * Add `smtSolver` option to `VerifierOptions`. (#78) + * Add `smtFloatMode` option to `VerifierOptions`. (#79) + +2025-01-20 + * Version bump (4.2). (#76) + * Reject specs that use multiple triggers with the same name. (#74) + +2024-11-08 + * Version bump (4.1). (#72) + +2024-09-09 + * Version bump (4.0). (#69) + * Support verifying programs that use array updates. (#63) + * Support verifying programs that use struct updates. (#57) + +2024-08-03 + * Support building with `crucible-llvm-0.7` and `crux-llvm-0.9`. (#64) + * Support GHC 9.4 through 9.8. (#65) + +2024-07-30 + * When using `Noisy` verbosity, always log proof goals related to the + core correspondence proof, even if the goals are trivial. (#51) + * When using `Noisy` verbosity, log more information about which proof + goals arise before or after calling the `step()` function. (#52) + +2024-07-11 + * Version bump (3.20). (#58) + +2024-03-08 + * Version bump (3.19). (#53) + * Provide more detailed feedback upon a successful run of the verifier. + * Make the examples build with Copilot 3.19. (#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..f7151dfeb --- /dev/null +++ b/copilot-verifier/copilot-verifier.cabal @@ -0,0 +1,152 @@ +Cabal-version: 2.2 +Name: copilot-verifier +Version: 4.4 +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.4 && < 4.5, + copilot-core >= 4.4 && < 4.5, + copilot-theorem >= 4.4 && < 4.5, + 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.7 + +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.4 && < 4.5, + copilot-language >= 4.4 && < 4.5, + copilot-libraries >= 4.4 && < 4.5, + copilot-prettyprinter >= 4.4 && < 4.5, + 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)) + ] From 1d299905a6c7b5885bc459ed4ab925c7c66145a1 Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Fri, 20 Jun 2025 10:05:21 -0400 Subject: [PATCH 06/25] copilot-verifier: Adjust issue numbers in changelog. Refs #622. The `copilot-verifier` package was originally developed in an external repo (https://github.com/Copilot-Language/copilot-verifier), but there is interest in having all Copilot projects and libraries merged into the main https://github.com/Copilot-Language/copilot repo for ease of management. Now that the `copilot-verifier` package lives in the `copilot` repo, this adjusts the issue numbers in the `copilot-verifier` changelog to refer to the old repo so that they will not be confused with issues in the `copilot` repo. --- copilot-verifier/CHANGELOG | 40 ++++++++++++++++++++++---------------- 1 file changed, 23 insertions(+), 17 deletions(-) diff --git a/copilot-verifier/CHANGELOG b/copilot-verifier/CHANGELOG index 2923ff5ed..4d3f2eacc 100644 --- a/copilot-verifier/CHANGELOG +++ b/copilot-verifier/CHANGELOG @@ -1,40 +1,46 @@ 2025-05-08 - * Version bump (4.4). (#85) + * Version bump (4.4). (copilot-verifier#85) 2025-03-10 - * Version bump (4.3). (#82) - * Add `smtSolver` option to `VerifierOptions`. (#78) - * Add `smtFloatMode` option to `VerifierOptions`. (#79) + * 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). (#76) - * Reject specs that use multiple triggers with the same name. (#74) + * 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). (#72) + * Version bump (4.1). (copilot-verifier#72) 2024-09-09 - * Version bump (4.0). (#69) - * Support verifying programs that use array updates. (#63) - * Support verifying programs that use struct updates. (#57) + * 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`. (#64) - * Support GHC 9.4 through 9.8. (#65) + * 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. (#51) + 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. (#52) + goals arise before or after calling the `step()` function. + (copilot-verifier#52) 2024-07-11 - * Version bump (3.20). (#58) + * Version bump (3.20). (copilot-verifier#58) 2024-03-08 - * Version bump (3.19). (#53) + * 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. (#53) + * Make the examples build with Copilot 3.19. (copilot-verifier#53) 2024-02-06 * Initial release of `copilot-verifier`. From 9e0dcac323f523277b1bdcb74869d823b6ad5324 Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Fri, 20 Jun 2025 10:06:43 -0400 Subject: [PATCH 07/25] copilot-verifier: Document changes in CHANGELOG. Refs #622. --- copilot-verifier/CHANGELOG | 3 +++ 1 file changed, 3 insertions(+) diff --git a/copilot-verifier/CHANGELOG b/copilot-verifier/CHANGELOG index 4d3f2eacc..03bd15246 100644 --- a/copilot-verifier/CHANGELOG +++ b/copilot-verifier/CHANGELOG @@ -1,3 +1,6 @@ +2025-06-20 + * Include `copilot-verifier` in mainline `copilot` repo. (#622) + 2025-05-08 * Version bump (4.4). (copilot-verifier#85) From 2230f35b0e258fe3088c7019959606b96d95cd88 Mon Sep 17 00:00:00 2001 From: Ivan Perez Date: Fri, 27 Jun 2025 13:23:58 +0000 Subject: [PATCH 08/25] copilot-visualizer: Include in mainline. Refs #624. The copilot-visualizer package was developed outside of this repo, but there's interest in having all Copilot projects and libraries merged into a main repo for ease of management. This commit adds version 4.4 of copilot-visualizer as a subdirectory of the main repository. All files are added "as is". --- copilot-visualizer/.gitignore | 25 + copilot-visualizer/CHANGELOG | 3 + copilot-visualizer/LICENSE | 29 ++ copilot-visualizer/README.md | 34 ++ copilot-visualizer/Setup.hs | 2 + copilot-visualizer/copilot-visualizer.cabal | 130 +++++ .../data/static_html/index.html | 255 +++++++++ copilot-visualizer/data/tikz/tikz.tex | 37 ++ copilot-visualizer/examples/gui/Main.hs | 20 + copilot-visualizer/examples/gui/copilot.css | 50 ++ copilot-visualizer/examples/gui/copilot.js | 489 ++++++++++++++++++ copilot-visualizer/examples/gui/main.html | 67 +++ copilot-visualizer/examples/tikz/Heater.hs | 37 ++ .../src/Copilot/Visualize/Dynamic.hs | 253 +++++++++ .../src/Copilot/Visualize/Live.hs | 162 ++++++ .../src/Copilot/Visualize/Static.hs | 36 ++ .../src/Copilot/Visualize/TypedTrace.hs | 158 ++++++ .../src/Copilot/Visualize/UntypedTrace.hs | 176 +++++++ 18 files changed, 1963 insertions(+) create mode 100644 copilot-visualizer/.gitignore create mode 100644 copilot-visualizer/CHANGELOG create mode 100644 copilot-visualizer/LICENSE create mode 100644 copilot-visualizer/README.md create mode 100644 copilot-visualizer/Setup.hs create mode 100644 copilot-visualizer/copilot-visualizer.cabal create mode 100644 copilot-visualizer/data/static_html/index.html create mode 100644 copilot-visualizer/data/tikz/tikz.tex create mode 100644 copilot-visualizer/examples/gui/Main.hs create mode 100644 copilot-visualizer/examples/gui/copilot.css create mode 100644 copilot-visualizer/examples/gui/copilot.js create mode 100644 copilot-visualizer/examples/gui/main.html create mode 100644 copilot-visualizer/examples/tikz/Heater.hs create mode 100644 copilot-visualizer/src/Copilot/Visualize/Dynamic.hs create mode 100644 copilot-visualizer/src/Copilot/Visualize/Live.hs create mode 100644 copilot-visualizer/src/Copilot/Visualize/Static.hs create mode 100644 copilot-visualizer/src/Copilot/Visualize/TypedTrace.hs create mode 100644 copilot-visualizer/src/Copilot/Visualize/UntypedTrace.hs diff --git a/copilot-visualizer/.gitignore b/copilot-visualizer/.gitignore new file mode 100644 index 000000000..f94ebc47b --- /dev/null +++ b/copilot-visualizer/.gitignore @@ -0,0 +1,25 @@ +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 diff --git a/copilot-visualizer/CHANGELOG b/copilot-visualizer/CHANGELOG new file mode 100644 index 000000000..44cb9f05e --- /dev/null +++ b/copilot-visualizer/CHANGELOG @@ -0,0 +1,3 @@ +2025-06-26 + * Release 4.4. (#5) + * Initial version. (#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..e57efd780 --- /dev/null +++ b/copilot-visualizer/copilot-visualizer.cabal @@ -0,0 +1,130 @@ +cabal-version: >= 1.10 +name: copilot-visualizer +version: 4.4 +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.7, + text >= 1.2.3.1 && < 2.2, + websockets >= 0.12.7 && < 0.14, + + copilot >= 4.4 && < 4.5, + copilot-core >= 4.4 && < 4.5, + copilot-interpreter >= 4.4 && < 4.5, + copilot-language >= 4.4 && < 4.5 + + 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.4 && < 4.5, + 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 From 93df3925b06c4ba0c60ae58c6b67becfeacc9ca6 Mon Sep 17 00:00:00 2001 From: Ivan Perez Date: Fri, 27 Jun 2025 13:26:16 +0000 Subject: [PATCH 09/25] copilot-visualizer: Remove duplicate .gitignore. Refs #624. The copilot-visualizer package was developed outside of this repo, but there's interest in having all Copilot projects and libraries merged into a main repo for ease of management. A prior commit add the copilot-visualizer library as a subdirectory of the main repository. The library included a .gitignore file, which is a duplicate of the one already present at the top level of the repository. This commit removes the duplicate file to have all ignored files governed by the .gitignore file at the top level. --- copilot-visualizer/.gitignore | 25 ------------------------- 1 file changed, 25 deletions(-) delete mode 100644 copilot-visualizer/.gitignore diff --git a/copilot-visualizer/.gitignore b/copilot-visualizer/.gitignore deleted file mode 100644 index f94ebc47b..000000000 --- a/copilot-visualizer/.gitignore +++ /dev/null @@ -1,25 +0,0 @@ -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 From 398f75d4643f97c4b7aa1f5ade8473de96723838 Mon Sep 17 00:00:00 2001 From: Ivan Perez Date: Fri, 27 Jun 2025 13:29:31 +0000 Subject: [PATCH 10/25] copilot-visualizer: Adjust issue numbers in CHANGELOG. Refs #624. The copilot-visualizer package was originally developed in an external repo, but there is interest in having all Copilot projects and libraries merged into the main repo for ease of management. A prior commit added the copilot-visualizer library as a subdirectory of the main copilot repo. However the CHANGELOG included with that library lists issue numbers that refer to issues in the original repo, not the main Copilot repo, which can cause confusion. This commit adjusts old issue numbers in the copilot-visualizer CHANGELOG to include the package name, to make it clear that they refer to the old repo. --- copilot-visualizer/CHANGELOG | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/copilot-visualizer/CHANGELOG b/copilot-visualizer/CHANGELOG index 44cb9f05e..0c219f99d 100644 --- a/copilot-visualizer/CHANGELOG +++ b/copilot-visualizer/CHANGELOG @@ -1,3 +1,3 @@ 2025-06-26 - * Release 4.4. (#5) - * Initial version. (#4) + * Release 4.4. (copilot-visualizer#5) + * Initial version. (copilot-visualizer#4) From b38f158b8a9ff437bd8458e3f6981ab59b69cf78 Mon Sep 17 00:00:00 2001 From: Ivan Perez Date: Fri, 27 Jun 2025 13:38:11 +0000 Subject: [PATCH 11/25] copilot-visualizer: Document changes in CHANGELOG. Refs #624. --- copilot-visualizer/CHANGELOG | 3 +++ 1 file changed, 3 insertions(+) diff --git a/copilot-visualizer/CHANGELOG b/copilot-visualizer/CHANGELOG index 0c219f99d..b2058f089 100644 --- a/copilot-visualizer/CHANGELOG +++ b/copilot-visualizer/CHANGELOG @@ -1,3 +1,6 @@ +2025-06-27 + * Include in mainline. (#624) + 2025-06-26 * Release 4.4. (copilot-visualizer#5) * Initial version. (copilot-visualizer#4) From 1e24c308af55b0f01bb33af2334e74faba337918 Mon Sep 17 00:00:00 2001 From: Ivan Perez Date: Sat, 28 Jun 2025 14:01:04 +0000 Subject: [PATCH 12/25] copilot-core: Remove deprecated fields of Copilot.Core.Expr.UExpr. Refs #636. The record fields uExprExpr and uExprType, part of Copilot.Core.Expr, are never really used within the module or in any other part of Copilot or, as far as we know, by any user of Copilot. The record fields were deprecated in Copilot 4.2 and no messages have been received requesting that they be kept in this library. As per our internal policy of waiting 3 versions from deprecation until a public interface declaration can be removed, these definitions can now be removed. This commit removes the fields uExprType and uExprExpr from the definition of Copilot.Core.Expr.UExpr, making the type no longer a record. --- copilot-core/src/Copilot/Core/Expr.hs | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/copilot-core/src/Copilot/Core/Expr.hs b/copilot-core/src/Copilot/Core/Expr.hs index 277e919d1..b65126a04 100644 --- a/copilot-core/src/Copilot/Core/Expr.hs +++ b/copilot-core/src/Copilot/Core/Expr.hs @@ -67,8 +67,4 @@ data Expr a where -- | 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 - } -{-# DEPRECATED uExprType, uExprExpr "These fields are deprecated in Copilot 4.2. Use pattern matching instead." #-} +data UExpr = forall a . Typeable a => UExpr (Type a) (Expr a) From 2f4cc73a5f6db04fdd3bbabca6e52d35d011836e Mon Sep 17 00:00:00 2001 From: Ivan Perez Date: Sat, 28 Jun 2025 14:05:52 +0000 Subject: [PATCH 13/25] copilot-core: Document changes in CHANGELOG. Refs #636. --- copilot-core/CHANGELOG | 3 +++ 1 file changed, 3 insertions(+) diff --git a/copilot-core/CHANGELOG b/copilot-core/CHANGELOG index 4a0902c21..edd45681e 100644 --- a/copilot-core/CHANGELOG +++ b/copilot-core/CHANGELOG @@ -1,3 +1,6 @@ +2025-06-28 + * Remove deprecated fields of Copilot.Core.Expr.UExpr. (#636) + 2025-05-07 * Version bump (4.4). (#618) * Remove deprecated Copilot.Core.Type.uTypeType. (#615) From 282a78fe127040aa77d042b01fa21b868e8dc7e4 Mon Sep 17 00:00:00 2001 From: carte731 Date: Thu, 29 May 2025 07:01:55 -0700 Subject: [PATCH 14/25] copilot-theorem: Remove 'GeneralizedNewtypeDeriving' unused pragma from 'what4.hs'. Refs #613. The code of copilot-theorem contains unused language pragmas. To comply with our coding style, which required unused code not to be included in the codebase, those pragmas should be removed. This commit removes an unused pragma from Copilot.Theorem.What4. --- copilot-theorem/src/Copilot/Theorem/What4.hs | 29 ++++++++++---------- 1 file changed, 14 insertions(+), 15 deletions(-) diff --git a/copilot-theorem/src/Copilot/Theorem/What4.hs b/copilot-theorem/src/Copilot/Theorem/What4.hs index 818ac9b3a..c2c7eb01b 100644 --- a/copilot-theorem/src/Copilot/Theorem/What4.hs +++ b/copilot-theorem/src/Copilot/Theorem/What4.hs @@ -1,18 +1,17 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} -- | -- Module : Copilot.Theorem.What4 From ad38ba44ee3e45ce0a196e5f4e78d981b3943236 Mon Sep 17 00:00:00 2001 From: carte731 Date: Thu, 29 May 2025 07:04:04 -0700 Subject: [PATCH 15/25] copilot-theorem: Remove 'MultiWayIf' unused pragma from 'what4.hs'. Refs #613. The code of copilot-theorem contains unused language pragmas. To comply with our coding style, which required unused code not to be included in the codebase, those pragmas should be removed. This commit removes an unused pragma from Copilot.Theorem.What4. --- copilot-theorem/src/Copilot/Theorem/What4.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/copilot-theorem/src/Copilot/Theorem/What4.hs b/copilot-theorem/src/Copilot/Theorem/What4.hs index c2c7eb01b..7c7e84233 100644 --- a/copilot-theorem/src/Copilot/Theorem/What4.hs +++ b/copilot-theorem/src/Copilot/Theorem/What4.hs @@ -3,7 +3,6 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} From 4f5f09adc31500cfd30950d31de3d7a6d4180f76 Mon Sep 17 00:00:00 2001 From: carte731 Date: Thu, 29 May 2025 07:05:14 -0700 Subject: [PATCH 16/25] copilot-theorem: Remove 'StandaloneDeriving' unused pragma from 'what4.hs'. Refs #613. The code of copilot-theorem contains unused language pragmas. To comply with our coding style, which required unused code not to be included in the codebase, those pragmas should be removed. This commit removes an unused pragma from Copilot.Theorem.What4. --- copilot-theorem/src/Copilot/Theorem/What4.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/copilot-theorem/src/Copilot/Theorem/What4.hs b/copilot-theorem/src/Copilot/Theorem/What4.hs index 7c7e84233..8610571c0 100644 --- a/copilot-theorem/src/Copilot/Theorem/What4.hs +++ b/copilot-theorem/src/Copilot/Theorem/What4.hs @@ -6,7 +6,6 @@ {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} From 61fa0b46cfd7fec8964b328fc9625243e6fa412e Mon Sep 17 00:00:00 2001 From: carte731 Date: Thu, 29 May 2025 07:07:14 -0700 Subject: [PATCH 17/25] copilot-theorem: Remove 'TemplateHaskell' unused pragma from 'what4.hs'. Refs #613. The code of copilot-theorem contains unused language pragmas. To comply with our coding style, which required unused code not to be included in the codebase, those pragmas should be removed. This commit removes an unused pragma from Copilot.Theorem.What4. --- copilot-theorem/src/Copilot/Theorem/What4.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/copilot-theorem/src/Copilot/Theorem/What4.hs b/copilot-theorem/src/Copilot/Theorem/What4.hs index 8610571c0..c9da7fe8b 100644 --- a/copilot-theorem/src/Copilot/Theorem/What4.hs +++ b/copilot-theorem/src/Copilot/Theorem/What4.hs @@ -6,7 +6,6 @@ {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} From 3088023b5e781b65afb8f4c96d93085c4a17b7fd Mon Sep 17 00:00:00 2001 From: carte731 Date: Thu, 29 May 2025 07:08:44 -0700 Subject: [PATCH 18/25] copilot-theorem: Remove 'TupleSections' unused pragma from 'what4.hs'. Refs #613. The code of copilot-theorem contains unused language pragmas. To comply with our coding style, which required unused code not to be included in the codebase, those pragmas should be removed. This commit removes an unused pragma from Copilot.Theorem.What4. --- copilot-theorem/src/Copilot/Theorem/What4.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/copilot-theorem/src/Copilot/Theorem/What4.hs b/copilot-theorem/src/Copilot/Theorem/What4.hs index c9da7fe8b..51ed6e8ff 100644 --- a/copilot-theorem/src/Copilot/Theorem/What4.hs +++ b/copilot-theorem/src/Copilot/Theorem/What4.hs @@ -6,7 +6,6 @@ {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} From bbb90b6c8fa777dc2cb088900a5ba5456bac8a49 Mon Sep 17 00:00:00 2001 From: carte731 Date: Thu, 29 May 2025 07:10:00 -0700 Subject: [PATCH 19/25] copilot-theorem: Remove 'LambdaCase' unused pragma from 'Prover.hs'. Refs #613. The code of copilot-theorem contains unused language pragmas. To comply with our coding style, which required unused code not to be included in the codebase, those pragmas should be removed. This commit removes an unused pragma from Copilot.Theorem.Kind2.Prover. --- copilot-theorem/src/Copilot/Theorem/Kind2/Prover.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/copilot-theorem/src/Copilot/Theorem/Kind2/Prover.hs b/copilot-theorem/src/Copilot/Theorem/Kind2/Prover.hs index 66db2c346..4bb52322e 100644 --- a/copilot-theorem/src/Copilot/Theorem/Kind2/Prover.hs +++ b/copilot-theorem/src/Copilot/Theorem/Kind2/Prover.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE Trustworthy #-} -- | A prover backend based on Kind2. From 2d101a7398ae1cc86d4d00f66b4ad0b96f702b84 Mon Sep 17 00:00:00 2001 From: carte731 Date: Thu, 29 May 2025 07:11:08 -0700 Subject: [PATCH 20/25] copilot-theorem: Remove 'LambdaCase' unused pragma from 'SMTIO.hs'. Refs #613. The code of copilot-theorem contains unused language pragmas. To comply with our coding style, which required unused code not to be included in the codebase, those pragmas should be removed. This commit removes an unused pragma from Copilot.Theorem.Prover.SMTIO. --- copilot-theorem/src/Copilot/Theorem/Prover/SMTIO.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/copilot-theorem/src/Copilot/Theorem/Prover/SMTIO.hs b/copilot-theorem/src/Copilot/Theorem/Prover/SMTIO.hs index 2ce606b31..3035f718e 100644 --- a/copilot-theorem/src/Copilot/Theorem/Prover/SMTIO.hs +++ b/copilot-theorem/src/Copilot/Theorem/Prover/SMTIO.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE Safe #-} From c9954d663f2988b2db9bd8ce65f9f14e71512195 Mon Sep 17 00:00:00 2001 From: carte731 Date: Thu, 29 May 2025 09:24:36 -0700 Subject: [PATCH 21/25] copilot-theorem: Document changes in CHANGELOG. Refs #613. --- copilot-theorem/CHANGELOG | 3 +++ 1 file changed, 3 insertions(+) diff --git a/copilot-theorem/CHANGELOG b/copilot-theorem/CHANGELOG index f221aec44..d28cc3041 100644 --- a/copilot-theorem/CHANGELOG +++ b/copilot-theorem/CHANGELOG @@ -1,3 +1,6 @@ +2025-05-29 + * Removed unused pragmas. (#613) + 2025-05-07 * Version bump (4.4). (#618) * Translate quantifiers correctly in Kind2 backend. (#594) From 1152a8f4dea8a7afd6b6cca09e71f5c7e11b238f Mon Sep 17 00:00:00 2001 From: Ivan Perez Date: Sun, 6 Jul 2025 01:25:41 +0000 Subject: [PATCH 22/25] copilot-theorem: Relax version constraint on `what4`. Refs #611. what4 has seen a new release 1.7, but copilot-theorem needs versions strictly lower than 1.7. This version is API-compatible for all features used by copilot-theorem. --- copilot-theorem/copilot-theorem.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/copilot-theorem/copilot-theorem.cabal b/copilot-theorem/copilot-theorem.cabal index ad7ab8699..50f777f49 100644 --- a/copilot-theorem/copilot-theorem.cabal +++ b/copilot-theorem/copilot-theorem.cabal @@ -61,7 +61,7 @@ library , random >= 1.1 && < 1.3 , transformers >= 0.5 && < 0.7 , xml >= 1.3 && < 1.4 - , what4 >= 1.3 && < 1.7 + , what4 >= 1.3 && < 1.8 , copilot-core >= 4.4 && < 4.5 , copilot-prettyprinter >= 4.4 && < 4.5 From 1f68f7e9d5f09a2a0e6cdd902cfd20d637c30fef Mon Sep 17 00:00:00 2001 From: Ivan Perez Date: Sun, 6 Jul 2025 01:28:06 +0000 Subject: [PATCH 23/25] copilot-theorem: Document changes in CHANGELOG. Refs #611. --- copilot-theorem/CHANGELOG | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/copilot-theorem/CHANGELOG b/copilot-theorem/CHANGELOG index d28cc3041..c0a0a02bd 100644 --- a/copilot-theorem/CHANGELOG +++ b/copilot-theorem/CHANGELOG @@ -1,5 +1,6 @@ -2025-05-29 +2025-07-05 * Removed unused pragmas. (#613) + * Relax version constraint on what4. (#611) 2025-05-07 * Version bump (4.4). (#618) From a9545d72df7839a5bbb999a500278c52d8d19a86 Mon Sep 17 00:00:00 2001 From: Ivan Perez Date: Tue, 8 Jul 2025 06:39:31 +0000 Subject: [PATCH 24/25] Bump versions and constraints. Refs #642. --- copilot-bluespec/copilot-bluespec.cabal | 4 ++-- copilot-c99/copilot-c99.cabal | 4 ++-- copilot-core/copilot-core.cabal | 2 +- copilot-interpreter/copilot-interpreter.cabal | 4 ++-- copilot-language/copilot-language.cabal | 8 ++++---- copilot-libraries/copilot-libraries.cabal | 4 ++-- .../copilot-prettyprinter.cabal | 4 ++-- copilot-theorem/copilot-theorem.cabal | 6 +++--- copilot-verifier/copilot-verifier.cabal | 16 ++++++++-------- copilot-visualizer/copilot-visualizer.cabal | 12 ++++++------ copilot/copilot.cabal | 14 +++++++------- 11 files changed, 39 insertions(+), 39 deletions(-) diff --git a/copilot-bluespec/copilot-bluespec.cabal b/copilot-bluespec/copilot-bluespec.cabal index 6509e7e2a..90d9f89d1 100644 --- a/copilot-bluespec/copilot-bluespec.cabal +++ b/copilot-bluespec/copilot-bluespec.cabal @@ -1,6 +1,6 @@ cabal-version : >= 1.10 name : copilot-bluespec -version : 4.4 +version : 4.5 synopsis : A compiler for Copilot targeting FPGAs. description : This package is a back-end from Copilot to FPGAs in Bluespec. @@ -44,7 +44,7 @@ library , filepath >= 1.4 && < 1.6 , pretty >= 1.1.2 && < 1.2 - , copilot-core >= 4.4 && < 4.5 + , copilot-core >= 4.5 && < 4.6 , language-bluespec >= 0.1 && < 0.2 exposed-modules : Copilot.Compile.Bluespec diff --git a/copilot-c99/copilot-c99.cabal b/copilot-c99/copilot-c99.cabal index dabf04bf0..17ec0d950 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 : 4.4 +version : 4.5 synopsis : A compiler for Copilot targeting C99. description : This package is a back-end from Copilot to C. @@ -45,7 +45,7 @@ library , mtl >= 2.2 && < 2.4 , pretty >= 1.1 && < 1.2 - , copilot-core >= 4.4 && < 4.5 + , copilot-core >= 4.5 && < 4.6 , language-c99 >= 0.2.0 && < 0.3 , language-c99-simple >= 0.3 && < 0.4 diff --git a/copilot-core/copilot-core.cabal b/copilot-core/copilot-core.cabal index daab8383b..ffd4031a9 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: 4.4 +version: 4.5 synopsis: An intermediate representation for Copilot. description: Intermediate representation for Copilot. diff --git a/copilot-interpreter/copilot-interpreter.cabal b/copilot-interpreter/copilot-interpreter.cabal index d5b679829..4bcfb3138 100644 --- a/copilot-interpreter/copilot-interpreter.cabal +++ b/copilot-interpreter/copilot-interpreter.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: copilot-interpreter -version: 4.4 +version: 4.5 synopsis: Interpreter for Copilot. description: Interpreter for Copilot. @@ -44,7 +44,7 @@ library base >= 4.9 && < 5, pretty >= 1.0 && < 1.2, - copilot-core >= 4.4 && < 4.5 + copilot-core >= 4.5 && < 4.6 exposed-modules: diff --git a/copilot-language/copilot-language.cabal b/copilot-language/copilot-language.cabal index 87d54101d..e9d4de9a9 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: 4.4 +version: 4.5 synopsis: A Haskell-embedded DSL for monitoring hard real-time distributed systems. description: @@ -42,9 +42,9 @@ library , data-reify >= 0.6 && < 0.7 , mtl >= 2.0 && < 3 - , copilot-core >= 4.4 && < 4.5 - , copilot-interpreter >= 4.4 && < 4.5 - , copilot-theorem >= 4.4 && < 4.5 + , copilot-core >= 4.5 && < 4.6 + , copilot-interpreter >= 4.5 && < 4.6 + , copilot-theorem >= 4.5 && < 4.6 exposed-modules: Copilot.Language , Copilot.Language.Operators.BitWise diff --git a/copilot-libraries/copilot-libraries.cabal b/copilot-libraries/copilot-libraries.cabal index 078d009fd..214fe7dc4 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: 4.4 +version: 4.5 synopsis: Libraries for the Copilot language. description: Libraries for the Copilot language. @@ -41,7 +41,7 @@ library , containers >= 0.4 && < 0.8 , mtl >= 2.0 && < 2.4 , parsec >= 2.0 && < 3.2 - , copilot-language >= 4.4 && < 4.5 + , copilot-language >= 4.5 && < 4.6 exposed-modules: Copilot.Library.Libraries diff --git a/copilot-prettyprinter/copilot-prettyprinter.cabal b/copilot-prettyprinter/copilot-prettyprinter.cabal index 2a4a9578f..2953cfef6 100644 --- a/copilot-prettyprinter/copilot-prettyprinter.cabal +++ b/copilot-prettyprinter/copilot-prettyprinter.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: copilot-prettyprinter -version: 4.4 +version: 4.5 synopsis: A prettyprinter of Copilot Specifications. description: A prettyprinter of Copilot specifications. @@ -45,7 +45,7 @@ library base >= 4.9 && < 5, pretty >= 1.0 && < 1.2, - copilot-core >= 4.4 && < 4.5 + copilot-core >= 4.5 && < 4.6 exposed-modules: diff --git a/copilot-theorem/copilot-theorem.cabal b/copilot-theorem/copilot-theorem.cabal index 50f777f49..47cd076b0 100644 --- a/copilot-theorem/copilot-theorem.cabal +++ b/copilot-theorem/copilot-theorem.cabal @@ -14,7 +14,7 @@ description: . -version : 4.4 +version : 4.5 license : BSD3 license-file : LICENSE maintainer : Ivan Perez @@ -63,8 +63,8 @@ library , xml >= 1.3 && < 1.4 , what4 >= 1.3 && < 1.8 - , copilot-core >= 4.4 && < 4.5 - , copilot-prettyprinter >= 4.4 && < 4.5 + , copilot-core >= 4.5 && < 4.6 + , copilot-prettyprinter >= 4.5 && < 4.6 exposed-modules : Copilot.Theorem , Copilot.Theorem.Prove diff --git a/copilot-verifier/copilot-verifier.cabal b/copilot-verifier/copilot-verifier.cabal index f7151dfeb..8b915e154 100644 --- a/copilot-verifier/copilot-verifier.cabal +++ b/copilot-verifier/copilot-verifier.cabal @@ -1,6 +1,6 @@ Cabal-version: 2.2 Name: copilot-verifier -Version: 4.4 +Version: 4.5 Author: Galois Inc. Maintainer: rscott@galois.com Copyright: (c) Galois, Inc 2021-2024 @@ -45,9 +45,9 @@ common bldflags bv-sized >= 1.0.0 && < 1.1, bytestring, containers >= 0.5.9.0, - copilot-c99 >= 4.4 && < 4.5, - copilot-core >= 4.4 && < 4.5, - copilot-theorem >= 4.4 && < 4.5, + copilot-c99 >= 4.5 && < 4.6, + copilot-core >= 4.5 && < 4.6, + copilot-theorem >= 4.5 && < 4.6, crucible >= 0.7.1 && < 0.8, crucible-llvm >= 0.7 && < 0.8, crux >= 0.7.1 && < 0.8, @@ -80,10 +80,10 @@ library copilot-verifier-examples hs-source-dirs: examples build-depends: case-insensitive, - copilot >= 4.4 && < 4.5, - copilot-language >= 4.4 && < 4.5, - copilot-libraries >= 4.4 && < 4.5, - copilot-prettyprinter >= 4.4 && < 4.5, + copilot >= 4.5 && < 4.6, + copilot-language >= 4.5 && < 4.6, + copilot-libraries >= 4.5 && < 4.6, + copilot-prettyprinter >= 4.5 && < 4.6, copilot-verifier exposed-modules: Copilot.Verifier.Examples diff --git a/copilot-visualizer/copilot-visualizer.cabal b/copilot-visualizer/copilot-visualizer.cabal index e57efd780..f0f59c93d 100644 --- a/copilot-visualizer/copilot-visualizer.cabal +++ b/copilot-visualizer/copilot-visualizer.cabal @@ -1,6 +1,6 @@ cabal-version: >= 1.10 name: copilot-visualizer -version: 4.4 +version: 4.5 synopsis: Visualizer for Copilot. description: Visualizer for Copilot. @@ -65,10 +65,10 @@ library text >= 1.2.3.1 && < 2.2, websockets >= 0.12.7 && < 0.14, - copilot >= 4.4 && < 4.5, - copilot-core >= 4.4 && < 4.5, - copilot-interpreter >= 4.4 && < 4.5, - copilot-language >= 4.4 && < 4.5 + copilot >= 4.5 && < 4.6, + copilot-core >= 4.5 && < 4.6, + copilot-interpreter >= 4.5 && < 4.6, + copilot-language >= 4.5 && < 4.6 exposed-modules: @@ -121,7 +121,7 @@ executable tikz-example build-depends: base >= 4.9 && < 5, - copilot >= 4.4 && < 4.5, + copilot >= 4.5 && < 4.6, copilot-visualizer if flag(examples) diff --git a/copilot/copilot.cabal b/copilot/copilot.cabal index 6401ef883..6d9570b19 100644 --- a/copilot/copilot.cabal +++ b/copilot/copilot.cabal @@ -1,5 +1,5 @@ name: copilot -version: 4.4 +version: 4.5 cabal-version: >= 1.10 license: BSD3 license-file: LICENSE @@ -52,12 +52,12 @@ library , directory >= 1.3 && < 1.4 , filepath >= 1.4 && < 1.6 - , copilot-core >= 4.4 && < 4.5 - , copilot-theorem >= 4.4 && < 4.5 - , copilot-language >= 4.4 && < 4.5 - , copilot-libraries >= 4.4 && < 4.5 - , copilot-c99 >= 4.4 && < 4.5 - , copilot-prettyprinter >= 4.4 && < 4.5 + , copilot-core >= 4.5 && < 4.6 + , copilot-theorem >= 4.5 && < 4.6 + , copilot-language >= 4.5 && < 4.6 + , copilot-libraries >= 4.5 && < 4.6 + , copilot-c99 >= 4.5 && < 4.6 + , copilot-prettyprinter >= 4.5 && < 4.6 exposed-modules: Language.Copilot, Language.Copilot.Main From 3d8674a71e97dcededf6fcc21f2402f4cbc5098d Mon Sep 17 00:00:00 2001 From: Ivan Perez Date: Tue, 8 Jul 2025 06:49:34 +0000 Subject: [PATCH 25/25] Document changes in CHANGELOG. Refs #642. --- copilot-bluespec/CHANGELOG | 3 ++- copilot-c99/CHANGELOG | 3 +++ copilot-core/CHANGELOG | 3 ++- copilot-interpreter/CHANGELOG | 3 +++ copilot-language/CHANGELOG | 3 +++ copilot-libraries/CHANGELOG | 3 +++ copilot-prettyprinter/CHANGELOG | 3 +++ copilot-theorem/CHANGELOG | 3 ++- copilot-verifier/CHANGELOG | 3 ++- copilot-visualizer/CHANGELOG | 3 ++- copilot/CHANGELOG | 3 +++ 11 files changed, 28 insertions(+), 5 deletions(-) diff --git a/copilot-bluespec/CHANGELOG b/copilot-bluespec/CHANGELOG index 10f4486ec..ccfaad8ab 100644 --- a/copilot-bluespec/CHANGELOG +++ b/copilot-bluespec/CHANGELOG @@ -1,4 +1,5 @@ -2025-05-18 +2025-07-07 + * Version bump (4.5). (#642) * Include `copilot-bluespec` in mainline `copilot` repo. (#623) 2025-05-08 diff --git a/copilot-c99/CHANGELOG b/copilot-c99/CHANGELOG index 00f705df8..7b7d3aeb6 100644 --- a/copilot-c99/CHANGELOG +++ b/copilot-c99/CHANGELOG @@ -1,3 +1,6 @@ +2025-07-07 + * Version bump (4.5). (#642) + 2025-05-07 * Version bump (4.4). (#618) diff --git a/copilot-core/CHANGELOG b/copilot-core/CHANGELOG index edd45681e..810d39b24 100644 --- a/copilot-core/CHANGELOG +++ b/copilot-core/CHANGELOG @@ -1,4 +1,5 @@ -2025-06-28 +2025-07-07 + * Version bump (4.5). (#642) * Remove deprecated fields of Copilot.Core.Expr.UExpr. (#636) 2025-05-07 diff --git a/copilot-interpreter/CHANGELOG b/copilot-interpreter/CHANGELOG index c5f4894c8..cd1e6b431 100644 --- a/copilot-interpreter/CHANGELOG +++ b/copilot-interpreter/CHANGELOG @@ -1,3 +1,6 @@ +2025-07-07 + * Version bump (4.5). (#642) + 2025-05-07 * Version bump (4.4). (#618) diff --git a/copilot-language/CHANGELOG b/copilot-language/CHANGELOG index fc28f01f1..60112d6f8 100644 --- a/copilot-language/CHANGELOG +++ b/copilot-language/CHANGELOG @@ -1,3 +1,6 @@ +2025-07-07 + * Version bump (4.5). (#642) + 2025-05-07 * Version bump (4.4). (#618) diff --git a/copilot-libraries/CHANGELOG b/copilot-libraries/CHANGELOG index a0c598f54..c724f29b5 100644 --- a/copilot-libraries/CHANGELOG +++ b/copilot-libraries/CHANGELOG @@ -1,3 +1,6 @@ +2025-07-07 + * Version bump (4.5). (#642) + 2025-05-07 * Version bump (4.4). (#618) diff --git a/copilot-prettyprinter/CHANGELOG b/copilot-prettyprinter/CHANGELOG index 360d2e9a0..8f94d9fa6 100644 --- a/copilot-prettyprinter/CHANGELOG +++ b/copilot-prettyprinter/CHANGELOG @@ -1,3 +1,6 @@ +2025-07-07 + * Version bump (4.5). (#642) + 2025-05-07 * Version bump (4.4). (#618) diff --git a/copilot-theorem/CHANGELOG b/copilot-theorem/CHANGELOG index c0a0a02bd..da078ea43 100644 --- a/copilot-theorem/CHANGELOG +++ b/copilot-theorem/CHANGELOG @@ -1,4 +1,5 @@ -2025-07-05 +2025-07-07 + * Version bump (4.5). (#642) * Removed unused pragmas. (#613) * Relax version constraint on what4. (#611) diff --git a/copilot-verifier/CHANGELOG b/copilot-verifier/CHANGELOG index 03bd15246..59ac57d9a 100644 --- a/copilot-verifier/CHANGELOG +++ b/copilot-verifier/CHANGELOG @@ -1,4 +1,5 @@ -2025-06-20 +2025-07-07 + * Version bump (4.5). (#642) * Include `copilot-verifier` in mainline `copilot` repo. (#622) 2025-05-08 diff --git a/copilot-visualizer/CHANGELOG b/copilot-visualizer/CHANGELOG index b2058f089..91c4b41fd 100644 --- a/copilot-visualizer/CHANGELOG +++ b/copilot-visualizer/CHANGELOG @@ -1,4 +1,5 @@ -2025-06-27 +2025-07-07 + * Version bump (4.5). (#642) * Include in mainline. (#624) 2025-06-26 diff --git a/copilot/CHANGELOG b/copilot/CHANGELOG index b38dd2c3d..e92d2fe91 100644 --- a/copilot/CHANGELOG +++ b/copilot/CHANGELOG @@ -1,3 +1,6 @@ +2025-07-07 + * Version bump (4.5). (#642) + 2025-05-07 * Version bump (4.4). (#618) * Update build status badge URL. (#612)