diff --git a/.github/workflows/saw-core-coq-check-coq-files.yml b/.github/workflows/saw-core-coq-check-coq-files.yml new file mode 100644 index 0000000000..8a7756eed1 --- /dev/null +++ b/.github/workflows/saw-core-coq-check-coq-files.yml @@ -0,0 +1,61 @@ +name: Type-check handwritten and generated Coq files +on: + push: + branches: [master] + pull_request: + branches: [master] + workflow_dispatch: + branches: [master] + +jobs: + build: + strategy: + fail-fast: false + matrix: + # coq-bits does not support coq >= 8.13 yet + coq: [8.12.2, 8.11.2, 8.10.2] + os: [ubuntu-latest] + runs-on: ${{ matrix.os }} + name: saw-core-coq - ${{ matrix.os }} - coq-${{ matrix.coq }} + env: + COQ_VERSION: ${{ matrix.coq }} + # coq-bits claims to support < 4.10 only + OCAML_VERSION: 4.09.1 + COQBITS_VERSION: 1.0.0 + steps: + + - uses: actions/checkout@v2 + + - name: Cache ~/.opam + uses: actions/cache@v2 + with: + path: ~/.opam + key: opam-${{ runner.os }}-${{ env.OCAML_VERSION }}-${{ env.COQ_VERSION }}-${{ env.COQBITS_VERSION }} + + # NOTE: this action is marked as experimental by their author, but it is + # much faster than avsm@setup-ocaml@v1. However, if this one ever becomes + # problematic, it should suffice to switch back to that version. + - name: Set up ocaml and opam + uses: actions-ml/setup-ocaml@df8c831c6c1e49804621d6e09c4ab9235da31fb5 + with: + ocaml-version: ${{ env.OCAML_VERSION }} + + - name: Install coq + shell: bash + run: | + opam pin add coq ${{ env.COQ_VERSION }} + opam install --unlock-base -y coq + + - name: Install coq-bits + shell: bash + run: | + opam repo add coq-released https://coq.inria.fr/opam/released + opam install --unlock-base -y "coq-bits=$COQBITS_VERSION" + + - name: Build saw-core-coq/coq + shell: bash + working-directory: saw-core-coq/coq + run: | + eval $(opam env) + coq_makefile -f _CoqProject -o Makefile.coq + make -j2 diff --git a/.gitmodules b/.gitmodules index 8fcd35aed1..c0547eb793 100644 --- a/.gitmodules +++ b/.gitmodules @@ -22,9 +22,6 @@ [submodule "deps/parameterized-utils"] path = deps/parameterized-utils url = https://github.com/GaloisInc/parameterized-utils.git -[submodule "deps/saw-core"] - path = deps/saw-core - url = https://github.com/GaloisInc/saw-core.git [submodule "deps/flexdis86"] path = deps/flexdis86 url = https://github.com/GaloisInc/flexdis86.git diff --git a/README.md b/README.md index 0ce5a1b4d9..d8478c9635 100644 --- a/README.md +++ b/README.md @@ -89,7 +89,6 @@ downloaded dependencies include: * `deps/abcBridge/`: [Haskell bindings for ABC](https://github.com/GaloisInc/abcBridge) * `deps/crucible/`: [Crucible symbolic execution engine](https://github.com/GaloisInc/crucible) * `deps/cryptol/`: [Cryptol](https://github.com/GaloisInc/cryptol) -* `deps/saw-core/`: [SAWCore intermediate language](https://github.com/GaloisInc/saw-core), used by CSS, JSS, and SAWScript ## For SAW developers diff --git a/cabal.project b/cabal.project index 136bb65ed1..49f92332a1 100644 --- a/cabal.project +++ b/cabal.project @@ -2,19 +2,19 @@ packages: saw-script.cabal saw-remote-api crux-mir-comp + cryptol-saw-core + rme + saw-core + saw-core-aig + saw-core-sbv + saw-core-what4 + saw-core-coq deps/llvm-pretty deps/llvm-pretty-bc-parser deps/jvm-parser deps/aig deps/abcBridge deps/cryptol - deps/saw-core/cryptol-saw-core - deps/saw-core/rme - deps/saw-core/saw-core - deps/saw-core/saw-core-aig - deps/saw-core/saw-core-sbv - deps/saw-core/saw-core-what4 - deps/saw-core/saw-core-coq deps/what4/what4 deps/crucible/crucible deps/crucible/crucible-jvm diff --git a/cryptol-saw-core/LICENSE b/cryptol-saw-core/LICENSE new file mode 100644 index 0000000000..a695b0c38b --- /dev/null +++ b/cryptol-saw-core/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2014, 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 names of the authors nor the names of other + 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/cryptol-saw-core/README.md b/cryptol-saw-core/README.md new file mode 100644 index 0000000000..2a792224cc --- /dev/null +++ b/cryptol-saw-core/README.md @@ -0,0 +1,5 @@ +This repository contains the code for the Cryptol Symbolic Simulator +(CSS). It is currently used primarily as a library from SAWScript, but +also produces a stand-alone executable, `css`. This executable has +only limited functionality: it can translate a single Cryptol function +to an And-Inverter Graph (AIG). diff --git a/cryptol-saw-core/Setup.hs b/cryptol-saw-core/Setup.hs new file mode 100644 index 0000000000..9a994af677 --- /dev/null +++ b/cryptol-saw-core/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cryptol-saw-core/cryptol-saw-core.cabal b/cryptol-saw-core/cryptol-saw-core.cabal new file mode 100644 index 0000000000..6094d15b89 --- /dev/null +++ b/cryptol-saw-core/cryptol-saw-core.cabal @@ -0,0 +1,94 @@ +Name: cryptol-saw-core +Version: 0.1 +Author: Galois, Inc. +License: BSD3 +License-file: LICENSE +Maintainer: huffman@galois.com +Copyright: (c) 2014 Galois Inc. +Build-type: Simple +cabal-version: >= 1.10 +Category: Formal Methods +Synopsis: Representing Cryptol in SAWCore +Description: + Translate Cryptol syntax into SAWCore terms, which can then + be analysed by various backend proof systems. + +extra-source-files: + saw/Cryptol.sawcore + +flag build-css + description: Build the css executable + default: True + +library + build-depends: + aig, + array, + base, + base-compat, + bytestring, + containers, + cryptol >= 2.3.0, + data-inttrie >= 0.1.4, + integer-gmp, + modern-uri, + panic, + saw-core, + saw-core-aig, + saw-core-sbv, + saw-core-what4, + what4, + sbv, + vector, + text, + executable-path, + filepath + hs-source-dirs: src + exposed-modules: + Verifier.SAW.Cryptol + Verifier.SAW.Cryptol.Panic + Verifier.SAW.Cryptol.Prelude + Verifier.SAW.Cryptol.Simpset + Verifier.SAW.CryptolEnv + Verifier.SAW.TypedTerm + GHC-options: -Wall -Werror + +executable css + if !flag(build-css) + buildable: False + + other-modules: + Paths_cryptol_saw_core + + build-depends: + array, + abcBridge, + base, + bytestring, + containers, + cryptol, + saw-core, + saw-core-aig, + text, + cryptol-saw-core + + hs-source-dirs : css + main-is : Main.hs + GHC-options: -Wall -O2 -rtsopts -pgmlc++ + extra-libraries: stdc++ + +test-suite cryptol-saw-core-tc-test + type: exitcode-stdio-1.0 + default-language: Haskell2010 + + hs-source-dirs: test + main-is: CryptolVerifierTC.hs + + build-depends: + base, + bytestring, + containers, + cryptol, + cryptol-saw-core, + heredoc >= 0.2, + saw-core diff --git a/cryptol-saw-core/css/Main.hs b/cryptol-saw-core/css/Main.hs new file mode 100644 index 0000000000..7dec5cc44d --- /dev/null +++ b/cryptol-saw-core/css/Main.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE RankNTypes #-} + +module Main where + +import System.Environment( getArgs ) +import System.Exit( exitFailure ) +import System.Console.GetOpt +import System.IO +import qualified Data.ByteString as BS +import Data.Text ( pack ) +import Data.Version + +import qualified Cryptol.Eval as E +import qualified Cryptol.TypeCheck.AST as T +import qualified Cryptol.ModuleSystem as CM +import qualified Cryptol.ModuleSystem.Env as CME +import qualified Cryptol.Parser as P +import qualified Cryptol.TypeCheck.Solver.SMT as SMT +import Cryptol.Utils.PP +import Cryptol.Utils.Logger (quietLogger) + +import qualified Verifier.SAW.Cryptol as C +import Verifier.SAW.SharedTerm +import qualified Verifier.SAW.Cryptol.Prelude as C +import Verifier.SAW.CryptolEnv (schemaNoUser) + + +import qualified Data.ABC as ABC +import qualified Verifier.SAW.Simulator.BitBlast as BBSim + +import qualified Paths_cryptol_saw_core as Paths + +data CSS = CSS + { output :: FilePath + , cssMode :: CmdMode + } deriving (Show) + +data CmdMode + = NormalMode + | HelpMode + | VersionMode + deriving (Show, Eq) + +emptyCSS :: CSS +emptyCSS = + CSS + { output = "" + , cssMode = NormalMode + } + +options :: [OptDescr (CSS -> CSS)] +options = + [ Option ['o'] ["output"] + (ReqArg (\x css -> css{ output = x }) "FILE") + "output file" + , Option ['h'] ["help"] + (NoArg (\css -> css{ cssMode = HelpMode })) + "display help" + , Option ['v'] ["version"] + (NoArg (\css -> css{ cssMode = VersionMode })) + "version" + ] + +version_string :: String +version_string = unlines + [ "Cryptol Symbolic Simulator (css) version "++showVersion Paths.version + , "Copyright 2014 Galois, Inc. All rights reserved." + ] + +header :: String +header = "css [options] " + +main :: IO () +main = do + args <- getArgs + case getOpt RequireOrder options args of + (flags,optArgs,[]) -> cssMain (foldr ($) emptyCSS flags) optArgs + + (_,_,errs) -> do + hPutStr stderr (concat errs ++ usageInfo header options) + exitFailure + +defaultEvalOpts :: E.EvalOpts +defaultEvalOpts = E.EvalOpts quietLogger E.defaultPPOpts + +cssMain :: CSS -> [String] -> IO () +cssMain css [inputModule,name] | cssMode css == NormalMode = do + let out = if null (output css) + then name++".aig" + else (output css) + + modEnv <- CM.initialModuleEnv + let minp = CM.ModuleInput True (pure defaultEvalOpts) BS.readFile modEnv + (e,warn) <- + SMT.withSolver (CME.meSolverConfig modEnv) $ \s -> + CM.loadModuleByPath inputModule (minp s) + mapM_ (print . pp) warn + case e of + Left msg -> print msg >> exitFailure + Right (_,menv) -> processModule menv out name + +cssMain css _ | cssMode css == VersionMode = do + hPutStr stdout version_string + +cssMain css _ | cssMode css == HelpMode = do + hPutStr stdout (usageInfo header options) + +cssMain _ _ = do + hPutStr stdout (usageInfo header options) + exitFailure + + +processModule :: CM.ModuleEnv -> FilePath -> String -> IO () +processModule menv fout funcName = do + sc <- mkSharedContext + C.scLoadPreludeModule sc + C.scLoadCryptolModule sc + tm <- extractCryptol sc menv funcName + writeAIG sc fout tm + +writeAIG :: SharedContext -> FilePath -> Term -> IO () +writeAIG sc f t = do + BBSim.withBitBlastedTerm ABC.giaNetwork sc mempty t $ \be ls -> do + ABC.writeAiger f (ABC.Network be (ABC.bvToList ls)) + +extractCryptol :: SharedContext -> CM.ModuleEnv -> String -> IO Term +extractCryptol sc modEnv input = do + let declGroups = concatMap T.mDecls (CME.loadedModules modEnv) + env <- C.importDeclGroups sc C.emptyEnv declGroups + pexpr <- + case P.parseExpr (pack input) of + Left err -> fail (show (P.ppError err)) + Right x -> return x + let minp = CM.ModuleInput True (pure defaultEvalOpts) BS.readFile modEnv + (exprResult, exprWarnings) <- + SMT.withSolver (CME.meSolverConfig modEnv) $ \s -> + CM.checkExpr pexpr (minp s) + mapM_ (print . pp) exprWarnings + ((_, expr, schema), _modEnv') <- + case exprResult of + Left err -> fail (show (pp err)) + Right x -> return x + putStrLn $ "Extracting expression of type " ++ show (pp (schemaNoUser schema)) + C.importExpr sc env expr + diff --git a/cryptol-saw-core/saw/Cryptol.sawcore b/cryptol-saw-core/saw/Cryptol.sawcore new file mode 100644 index 0000000000..6a1487d8c2 --- /dev/null +++ b/cryptol-saw-core/saw/Cryptol.sawcore @@ -0,0 +1,1661 @@ +------------------------------------------------------------------------------- +-- Cryptol primitives for SAWCore + +module Cryptol where + +import Prelude; + +-------------------------------------------------------------------------------- +-- Additional operations on Prelude types + +const : (a b : sort 0) -> a -> b -> a; +const a b x y = x; + +compose : (a b c : sort 0) -> (b -> c) -> (a -> b) -> (a -> c); +compose _ _ _ f g x = f (g x); + +bvExp : (n : Nat) -> Vec n Bool -> Vec n Bool -> Vec n Bool; +bvExp n x y = foldr Bool (Vec n Bool) n + (\ (b : Bool) -> \ (a : Vec n Bool) -> + ite (Vec n Bool) b (bvMul n x (bvMul n a a)) (bvMul n a a)) + (bvNat n 1) + (reverse n Bool y); + +updFst : (a b : sort 0) -> (a -> a) -> (a * b) -> (a * b); +updFst a b f x = (f x.(1), x.(2)); + +updSnd : (a b : sort 0) -> (b -> b) -> (a * b) -> (a * b); +updSnd a b f x = (x.(1), f x.(2)); + +-------------------------------------------------------------------------------- +-- Extended natural numbers + +data Num : sort 0 where { + TCNum : Nat -> Num; + TCInf : Num; + } + +Num_rec : (p: Num -> sort 1) -> ((n:Nat) -> p (TCNum n)) -> p TCInf -> + (n:Num) -> p n; +Num_rec p f1 f2 n = Num#rec p f1 f2 n; + +-- Helper function: take a Num that we expect to be finite, and extract its Nat, +-- raising an error if that Num is not finite +getFinNat : (n:Num) -> Nat; +getFinNat n = + Num#rec (\ (n:Num) -> Nat) (\ (n:Nat) -> n) + (error Nat "Unexpected Fin constraint violation!") n; + +-- Helper function: destruct a Num that we expect to be finite +finNumRec : (p: Num -> sort 1) -> ((n:Nat) -> p (TCNum n)) -> + (n:Num) -> p n; +finNumRec p f n = + Num#rec p f (error (p TCInf) "Unexpected Fin constraint violation!") n; + +-- Helper function: destruct two Nums that we expect to be finite +finNumRec2 : (p: Num -> Num -> sort 1) -> + ((m n:Nat) -> p (TCNum m) (TCNum n)) -> + (m n:Num) -> p m n; +finNumRec2 p f = + finNumRec + (\ (m:Num) -> (n:Num) -> p m n) + (\ (m:Nat) -> finNumRec (p (TCNum m)) (f m)); + +-- Build a binary function on Nums by lifting a binary function on Nats (the +-- first argument) and using additional cases for: when the first argument is a +-- Nat and the second is infinite; when the second is a Nat and the first is +-- infinite; and when both are infinite +binaryNumFun : (Nat -> Nat -> Nat) -> (Nat -> Num) -> (Nat -> Num) -> Num -> + Num -> Num -> Num; +binaryNumFun f1 f2 f3 f4 num1 num2 = + Num#rec (\ (num1':Num) -> Num) + (\ (n1:Nat) -> + Num#rec (\ (num2':Num) -> Num) + (\ (n2:Nat) -> TCNum (f1 n1 n2)) + (f2 n1) num2) + (Num#rec (\ (num2':Num) -> Num) f3 f4 num2) + num1; + +-- Build a ternary function on Nums by lifting a ternary function on Nats, with +-- a single default case if any of the Nums is infinite +ternaryNumFun : (Nat -> Nat -> Nat -> Nat) -> Num -> + Num -> Num -> Num -> Num; +ternaryNumFun f1 f2 num1 num2 num3 = + Num#rec + (\ (num1':Num) -> Num) + (\ (n1:Nat) -> + Num#rec + (\ (num2':Num) -> Num) + (\ (n2:Nat) -> + Num#rec + (\ (num3':Num) -> Num) + (\ (n3:Nat) -> TCNum (f1 n1 n2 n3)) + f2 num3) + f2 num2) + f2 num1; + + + +tcWidth : Num -> Num; +tcWidth n = Num#rec (\ (n:Num) -> Num) + (\ (x:Nat) -> TCNum (widthNat x)) TCInf n; + +tcAdd : Num -> Num -> Num; +tcAdd = + binaryNumFun addNat (\ (x:Nat) -> TCInf) (\ (y:Nat) -> TCInf) TCInf; + +tcSub : Num -> Num -> Num; +tcSub = + binaryNumFun subNat + -- x - infinity = 0 + (\ (x:Nat) -> TCNum 0) + -- infinity - y = infinity + (\ (y:Nat) -> TCInf) + -- infinity - infinity = 0 + (TCNum 0); + +tcMul : Num -> Num -> Num; +tcMul = + binaryNumFun mulNat + (\ (x:Nat) -> if0Nat Num x (TCNum 0) TCInf) + (\ (y:Nat) -> if0Nat Num y (TCNum 0) TCInf) + TCInf; + +tcDiv : Num -> Num -> Num; +tcDiv = + binaryNumFun (\ (x:Nat) -> \ (y:Nat) -> divNat x y) + (\ (x:Nat) -> TCNum 0) + (\ (y:Nat) -> TCInf) + -- infinity / infinity = 1 + (TCNum 1); + +tcMod : Num -> Num -> Num; +tcMod = + binaryNumFun (\ (x:Nat) -> \ (y:Nat) -> modNat x y) + (\ (x:Nat) -> TCNum 0) + -- infinity % y = 0, since y*infinity + 0 = infinity + (\ (y:Nat) -> TCNum 0) + -- infinity % infinity = 0 + (TCNum 0); + +tcExp : Num -> Num -> Num; +tcExp = + binaryNumFun expNat + (\ (x:Nat) -> + natCase + (\ (_:Nat) -> Num) (TCNum 0) + (\ (x_minus_1:Nat) -> + if0Nat Num x_minus_1 (TCNum 1) TCInf) + x) + (\ (y:Nat) -> if0Nat Num y (TCNum 1) TCInf) + TCInf; + +tcMin : Num -> Num -> Num; +tcMin = + binaryNumFun minNat (\ (x:Nat) -> TCNum x) (\ (y:Nat) -> TCNum y) TCInf; + +tcMax : Num -> Num -> Num; +tcMax = + binaryNumFun maxNat (\ (x:Nat) -> TCInf) (\ (y:Nat) -> TCInf) TCInf; + +ceilDivNat : Nat -> Nat -> Nat; +ceilDivNat x y = divNat (addNat x (subNat y 1)) y; + +ceilModNat : Nat -> Nat -> Nat; +ceilModNat x y = subNat (mulNat (ceilDivNat x y) y) x; + +tcCeilDiv : Num -> Num -> Num; +tcCeilDiv = + binaryNumFun ceilDivNat (\ (x:Nat) -> TCNum 0) (\ (y:Nat) -> TCInf) TCInf; + +tcCeilMod : Num -> Num -> Num; +tcCeilMod = + binaryNumFun ceilModNat (\ (x:Nat) -> TCNum 0) (\ (y:Nat) -> TCInf) TCInf; + +tcLenFromThenTo_Nat : Nat -> Nat -> Nat -> Nat; +tcLenFromThenTo_Nat x y z = + ite Nat (ltNat x y) + (ite Nat (ltNat z x) 0 + (addNat (divNat (subNat z x) (subNat y x)) 1)) -- increasing + (ite Nat (ltNat x z) 0 + (addNat (divNat (subNat x z) (subNat x y)) 1)); -- decreasing + +tcLenFromThenTo : Num -> Num -> Num -> Num; +tcLenFromThenTo = ternaryNumFun tcLenFromThenTo_Nat TCInf; + + +-------------------------------------------------------------------------------- +-- Possibly infinite sequences + +seq : Num -> sort 0 -> sort 0; +seq num a = + Num#rec (\ (num:Num) -> sort 0) (\ (n:Nat) -> Vec n a) (Stream a) num; + +-- FIXME: this rule should be derived by scDefRewriteRules +seq_TCNum : (n:Nat) -> (a:sort 0) -> Eq (sort 0) (seq (TCNum n) a) (Vec n a); +seq_TCNum n a = Refl (sort 0) (Vec n a); +seq_TCInf : (a:sort 0) -> Eq (sort 0) (seq TCInf a) (Stream a); +seq_TCInf a = Refl (sort 0) (Stream a); + +seqMap : (a b : sort 0) -> (n : Num) -> (a -> b) -> seq n a -> seq n b; +seqMap a b num f = + Num#rec (\ (n:Num) -> seq n a -> seq n b) (map a b f) (streamMap a b f) num; + +seqConst : (n : Num) -> (a : sort 0) -> a -> seq n a; +seqConst n = + Num#rec (\ (n:Num) -> (a : sort 0) -> a -> seq n a) replicate streamConst n; + +-------------------------------------------------------------------------------- +-- Integers mod n + +IntModNum : (num : Num) -> sort 0; +IntModNum num = + Num#rec (\ (n : Num) -> sort 0) IntMod Integer num; + +------------------------------------------------------------------------------- +-- Rationals (TODO) + +Rational : sort 0; +Rational = #(); + +ecRatio : Integer -> Integer -> Rational; +ecRatio x y = (); + +eqRational : Rational -> Rational -> Bool; +eqRational x y = error Bool "Unimplemented: (==) Rational"; + +ltRational : Rational -> Rational -> Bool; +ltRational x y = error Bool "Unimplemented: (<) Rational"; + +addRational : Rational -> Rational -> Rational; +addRational x y = error Rational "Unimplemented: (+) Rational"; + +subRational : Rational -> Rational -> Rational; +subRational x y = error Rational "Unimplemented: (-) Rational"; + +mulRational : Rational -> Rational -> Rational; +mulRational x y = error Rational "Unimplemented: (*) Rational"; + +negRational : Rational -> Rational; +negRational x = error Rational "Unimplemented: negate Rational"; + +integerToRational : Integer -> Rational; +integerToRational x = error Rational "Unimplemented: fromInteger Rational"; + +-------------------------------------------------------------------------------- +-- Type coercions + +seq_cong : (m : Num) -> (n : Num) -> (a : sort 0) -> (b : sort 0) -> + Eq Num m n -> Eq (sort 0) a b -> Eq (sort 0) (seq m a) (seq n b); +seq_cong m n a b eq_mn eq_ab = + trans + (sort 0) (seq m a) (seq n a) (seq n b) + (eq_cong Num m n eq_mn (sort 0) (\ (x:Num) -> seq x a)) + (eq_cong (sort 0) a b eq_ab (sort 0) (\ (x:sort 0) -> seq n x)); + +seq_cong1 : (m : Num) -> (n : Num) -> (a : sort 0) -> + Eq Num m n -> Eq (sort 0) (seq m a) (seq n a); +seq_cong1 m n a eq_mn = + eq_cong Num m n eq_mn (sort 0) (\ (x:Num) -> seq x a); + +IntModNum_cong : + (m : Num) -> (n : Num) -> Eq Num m n -> Eq (sort 0) (IntModNum m) (IntModNum n); +IntModNum_cong m n eq_mn = + eq_cong Num m n eq_mn (sort 0) IntModNum; + +fun_cong : (a : sort 0) -> (b : sort 0) -> (c : sort 0) -> (d : sort 0) -> + Eq (sort 0) a b -> Eq (sort 0) c d -> Eq (sort 0) (a -> c) (b -> d); +fun_cong a b c d eq_ab eq_cd = + trans + (sort 0) (a -> c) (b -> c) (b -> d) + (eq_cong (sort 0) a b eq_ab (sort 0) (\ (x:sort 0) -> (x -> c))) + (eq_cong (sort 0) c d eq_cd (sort 0) (\ (x:sort 0) -> (b -> x))); + +pair_cong : (a : sort 0) -> (a' : sort 0) -> (b : sort 0) -> (b' : sort 0) -> + Eq (sort 0) a a' -> Eq (sort 0) b b' -> Eq (sort 0) (a * b) (a' * b'); +pair_cong a a' b b' eq_a eq_b = + trans + (sort 0) (a * b) (a' * b) (a' * b') + (eq_cong (sort 0) a a' eq_a (sort 0) (\ (x:sort 0) -> (x * b))) + (eq_cong (sort 0) b b' eq_b (sort 0) (\ (x:sort 0) -> (a' * x))); + +pair_cong1 : (a : sort 0) -> (a' : sort 0) -> (b : sort 0) -> + Eq (sort 0) a a' -> Eq (sort 0) (a * b) (a' * b); +pair_cong1 a a' b eq_a = + (eq_cong (sort 0) a a' eq_a (sort 0) (\ (x:sort 0) -> (x * b))); + +pair_cong2 : (a : sort 0) -> (b : sort 0) -> (b' : sort 0) -> + Eq (sort 0) b b' -> Eq (sort 0) (a * b) (a * b'); +pair_cong2 a b b' eq_b = + (eq_cong (sort 0) b b' eq_b (sort 0) (\ (x:sort 0) -> (a * x))); + +axiom unsafeAssert_same_Num : + (n : Num) -> Eq (Eq Num n n) (unsafeAssert Num n n) (Refl Num n); + +-------------------------------------------------------------------------------- +-- Auxiliary functions + +eListSel : (a : sort 0) -> (n : Num) -> seq n a -> Nat -> a; +eListSel a n = + Num#rec (\ (num:Num) -> seq num a -> Nat -> a) + (\ (n:Nat) -> at n a) (streamGet a) n; + + +-------------------------------------------------------------------------------- +-- List comprehensions + +from : (a b : sort 0) -> (m n : Num) -> seq m a -> (a -> seq n b) -> + seq (tcMul m n) (a * b); +from a b m n = + Num#rec + (\ (m:Num) -> seq m a -> (a -> seq n b) -> seq (tcMul m n) (a * b)) + (\ (m:Nat) -> + Num#rec + (\ (n:Num) -> Vec m a -> (a -> seq n b) -> + seq (tcMul (TCNum m) n) (a * b)) + -- Case 1: (TCNum m, TCNum n) + (\ (n:Nat) -> + \ (xs : Vec m a) -> + \ (k : a -> Vec n b) -> + join m n (a * b) + (map a (Vec n (a * b)) + (\ (x : a) -> + map b (a * b) (\ (y : b) -> (x, y)) n (k x)) + m xs)) + -- Case 2: n = (TCNum m, TCInf) + (natCase + (\ (m':Nat) -> (Vec m' a -> (a -> Stream b) -> + seq (if0Nat Num m' (TCNum 0) TCInf) (a * b))) + (\ (xs : Vec 0 a) -> + \ (k : a -> Stream b) -> EmptyVec (a * b)) + (\ (m' : Nat) -> + \ (xs : Vec (Succ m') a) -> + \ (k : a -> Stream b) -> + (\ (x : a) -> streamMap b (a * b) (\ (y:b) -> (x, y)) (k x)) + (at (Succ m') a xs 0)) + m) + n) + (Num#rec + (\ (n:Num) -> Stream a -> (a -> seq n b) -> seq (tcMul TCInf n) (a * b)) + -- Case 3: (TCInf, TCNum n) + (\ (n:Nat) -> + natCase + (\ (n':Nat) -> (Stream a -> (a -> Vec n' b) -> + seq (if0Nat Num n' (TCNum 0) TCInf) (a * b))) + (\ (xs : Stream a) -> + \ (k : a -> Vec 0 b) -> EmptyVec (a * b)) + (\ (n' : Nat) -> + \ (xs : Stream a) -> + \ (k : a -> Vec (Succ n') b) -> + streamJoin + (a * b) n' + (streamMap + a (Vec (Succ n') (a * b)) + (\ (x:a) -> + map b (a * b) (\ (y:b) -> (x, y)) (Succ n') (k x)) + xs)) + n) + -- Case 4: (TCInf, TCInf) + (\ (xs : Stream a) -> + \ (k : a -> Stream b) -> + (\ (x : a) -> streamMap b (a * b) (\ (y : b) -> (x, y)) (k x)) + (streamGet a xs 0)) + n) + m; + + +mlet : (a b : sort 0) -> (n : Num) -> a -> (a -> seq n b) -> seq n (a * b); +mlet a b n = + Num#rec + (\ (n:Num) -> a -> (a -> seq n b) -> seq n (a * b)) + (\ (n:Nat) -> \ (x:a) -> \ (f:a -> Vec n b) -> + map b (a * b) (\ (y : b) -> (x, y)) n (f x)) + (\ (x:a) -> \ (f:a -> Stream b) -> + streamMap b (a * b) (\ (y : b) -> (x, y)) (f x)) + n; + +seqZip : (a b : sort 0) -> (m n : Num) -> seq m a -> seq n b -> + seq (tcMin m n) (a * b); +seqZip a b m n = + Num#rec + (\ (m:Num) -> seq m a -> seq n b -> seq (tcMin m n) (a * b)) + (\ (m : Nat) -> + Num#rec + (\ (n:Num) -> Vec m a -> seq n b -> seq (tcMin (TCNum m) n) (a * b)) + (\ (n:Nat) -> zip a b m n) + (\ (xs:Vec m a) -> \ (ys:Stream b) -> + gen m (a * b) (\ (i : Nat) -> (at m a xs i, streamGet b ys i))) + n) + (Num#rec + (\ (n:Num) -> Stream a -> seq n b -> seq (tcMin TCInf n) (a * b)) + (\ (n:Nat) -> + \ (xs:Stream a) -> \ (ys:Vec n b) -> + gen n (a * b) (\ (i : Nat) -> (streamGet a xs i, at n b ys i))) + (streamMap2 a b (a * b) (\ (x:a) -> \ (y:b) -> (x, y))) + n) + m; + + +-------------------------------------------------------------------------------- +-- Ring and Logic functions + +seqBinary : (n : Num) -> (a : sort 0) -> (a -> a -> a) -> + seq n a -> seq n a -> seq n a; +seqBinary num a f = + Num#rec + (\ (n:Num) -> seq n a -> seq n a -> seq n a) + (\ (n:Nat) -> zipWith a a a f n) + (streamMap2 a a a f) + num; + +unitUnary : #() -> #(); +unitUnary _ = (); + +unitBinary : #() -> #() -> #(); +unitBinary _ _ = (); + +pairUnary : (a b : sort 0) -> (a -> a) -> (b -> b) -> (a * b) -> (a * b); +pairUnary a b f g xy = (f (fst a b xy), g (snd a b xy)); + +pairBinary : (a b : sort 0) -> (a -> a -> a) -> (b -> b -> b) + -> (a * b) -> (a * b) -> (a * b); +pairBinary a b f g x12 y12 = (f (fst a b x12) (fst a b y12), + g (snd a b x12) (snd a b y12)); + +funBinary : (a b : sort 0) -> (b -> b -> b) -> (a -> b) -> (a -> b) -> (a -> b); +funBinary a b op f g x = op (f x) (g x); + +errorUnary : (s : String) -> (a : sort 0) -> a -> a; +errorUnary s a _ = error a s; + +errorBinary : (s : String) -> (a : sort 0) -> a -> a -> a; +errorBinary s a _ _ = error a s; + +-------------------------------------------------------------------------------- +-- Comparisons + +boolCmp : Bool -> Bool -> Bool -> Bool; +boolCmp x y k = ite Bool x (and y k) (or y k); + +integerCmp : Integer -> Integer -> Bool -> Bool; +integerCmp x y k = or (intLt x y) (and (intEq x y) k); + +rationalCmp : Rational -> Rational -> Bool -> Bool; +rationalCmp x y k = or (ltRational x y) (and (eqRational x y) k); + +bvCmp : (n : Nat) -> Vec n Bool -> Vec n Bool -> Bool -> Bool; +bvCmp n x y k = or (bvult n x y) (and (bvEq n x y) k); + +bvSCmp : (n : Nat) -> Vec n Bool -> Vec n Bool -> Bool -> Bool; +bvSCmp n x y k = or (bvslt n x y) (and (bvEq n x y) k); + +vecCmp : (n : Nat) -> (a : sort 0) -> (a -> a -> Bool -> Bool) + -> (Vec n a -> Vec n a -> Bool -> Bool); +vecCmp n a f xs ys k = + foldr (Bool -> Bool) Bool n (\ (f : Bool -> Bool) -> f) k + (zipWith a a (Bool -> Bool) f n xs ys); + +unitCmp : #() -> #() -> Bool -> Bool; +unitCmp _ _ _ = False; + +pairCmp : (a b : sort 0) -> (a -> a -> Bool -> Bool) -> (b -> b -> Bool -> Bool) + -> a * b -> a * b -> Bool -> Bool; +pairCmp a b f g x12 y12 k = + f (fst a b x12) (fst a b y12) (g (snd a b x12) (snd a b y12) k); + +-------------------------------------------------------------------------------- +-- Dictionaries and overloading + +-- Eq class + +PEq : sort 0 -> sort 1; +PEq a = #{ eq : a -> a -> Bool }; + +PEqBit : PEq Bool; +PEqBit = { eq = boolEq }; + +PEqInteger : PEq Integer; +PEqInteger = { eq = intEq }; + +PEqRational : PEq Rational; +PEqRational = { eq = eqRational }; + +PEqIntMod : (n : Nat) -> PEq (IntMod n); +PEqIntMod n = { eq = intModEq n }; + +PEqIntModNum : (num : Num) -> PEq (IntModNum num); +PEqIntModNum num = + Num#rec (\ (n : Num) -> PEq (IntModNum n)) PEqIntMod PEqInteger num; + +PEqVec : (n : Nat) -> (a : sort 0) -> PEq a -> PEq (Vec n a); +PEqVec n a pa = { eq = vecEq n a pa.eq }; + +PEqSeq : (n : Num) -> (a : sort 0) -> PEq a -> PEq (seq n a); +PEqSeq n = + Num#rec (\ (n:Num) -> (a : sort 0) -> PEq a -> PEq (seq n a)) + (\ (n:Nat) -> PEqVec n) + (\ (a:sort 0) (pa : PEq a) -> error (PEq (Stream a)) "invalid Eq instance") + n; + +PEqWord : (n : Nat) -> PEq (Vec n Bool); +PEqWord n = { eq = bvEq n }; + +PEqSeqBool : (n : Num) -> PEq (seq n Bool); +PEqSeqBool n = + Num#rec (\ (n : Num) -> PEq (seq n Bool)) + (\ (n:Nat) -> PEqWord n) + (error (PEq (Stream Bool)) "invalid Eq instance") + n; + +PEqUnit : PEq #(); +PEqUnit = { eq = \ (x y : #()) -> True }; + +PEqPair : (a b : sort 0) -> PEq a -> PEq b -> PEq (a * b); +PEqPair a b pa pb = { eq = pairEq a b pa.eq pb.eq }; + + +-- Cmp class + +PCmp : sort 0 -> sort 1; +PCmp a = + #{ cmpEq : PEq a + , cmp : a -> a -> Bool -> Bool + }; + +PCmpBit : PCmp Bool; +PCmpBit = { cmpEq = PEqBit, cmp = boolCmp }; + +PCmpInteger : PCmp Integer; +PCmpInteger = { cmpEq = PEqInteger, cmp = integerCmp }; + +PCmpRational : PCmp Rational; +PCmpRational = { cmpEq = PEqRational, cmp = rationalCmp }; + +PCmpVec : (n : Nat) -> (a : sort 0) -> PCmp a -> PCmp (Vec n a); +PCmpVec n a pa = { cmpEq = PEqVec n a pa.cmpEq, cmp = vecCmp n a pa.cmp }; + +PCmpSeq : (n : Num) -> (a : sort 0) -> PCmp a -> PCmp (seq n a); +PCmpSeq n = + Num#rec (\ (n:Num) -> (a : sort 0) -> PCmp a -> PCmp (seq n a)) + (\ (n:Nat) -> PCmpVec n) + (\ (a:sort 0) (pa : PCmp a) -> error (PCmp (Stream a)) "invalid Cmp instance") + n; + +PCmpWord : (n : Nat) -> PCmp (Vec n Bool); +PCmpWord n = { cmpEq = PEqWord n, cmp = bvCmp n }; + +PCmpSeqBool : (n : Num) -> PCmp (seq n Bool); +PCmpSeqBool n = + Num#rec (\ (n : Num) -> PCmp (seq n Bool)) + (\ (n:Nat) -> PCmpWord n) + (error (PCmp (Stream Bool)) "invalid Cmp instance") + n; + +PCmpUnit : PCmp #(); +PCmpUnit = { cmpEq = PEqUnit, cmp = unitCmp }; + +PCmpPair : (a b : sort 0) -> PCmp a -> PCmp b -> PCmp (a * b); +PCmpPair a b pa pb = + { cmpEq = PEqPair a b pa.cmpEq pb.cmpEq + , cmp = pairCmp a b pa.cmp pb.cmp + }; + +-- SignedCmp class + +PSignedCmp : sort 0 -> sort 1; +PSignedCmp a = + #{ signedCmpEq : PEq a + , scmp : a -> a -> Bool -> Bool + }; + +PSignedCmpVec : (n : Nat) -> (a : sort 0) -> PSignedCmp a -> PSignedCmp (Vec n a); +PSignedCmpVec n a pa = + { signedCmpEq = PEqVec n a pa.signedCmpEq + , scmp = vecCmp n a pa.scmp + }; + +PSignedCmpSeq : (n : Num) -> (a : sort 0) -> PSignedCmp a -> PSignedCmp (seq n a); +PSignedCmpSeq n = + Num#rec (\ (n:Num) -> (a : sort 0) -> PSignedCmp a -> PSignedCmp (seq n a)) + (\ (n:Nat) -> PSignedCmpVec n) + (\ (a:sort 0) (pa : PSignedCmp a) -> error (PSignedCmp (Stream a)) "invalid SignedCmp instance") + n; + +PSignedCmpWord : (n : Nat) -> PSignedCmp (Vec n Bool); +PSignedCmpWord n = { signedCmpEq = PEqWord n, scmp = bvSCmp n }; + +PSignedCmpSeqBool : (n : Num) -> PSignedCmp (seq n Bool); +PSignedCmpSeqBool n = + Num#rec (\ (n : Num) -> PSignedCmp (seq n Bool)) + (\ (n:Nat) -> PSignedCmpWord n) + (error (PSignedCmp (Stream Bool)) "invalid SignedCmp instance") + n; + +PSignedCmpUnit : PSignedCmp #(); +PSignedCmpUnit = { signedCmpEq = PEqUnit, scmp = unitCmp }; + +PSignedCmpPair : (a b : sort 0) -> PSignedCmp a -> PSignedCmp b -> PSignedCmp (a * b); +PSignedCmpPair a b pa pb = + { signedCmpEq = PEqPair a b pa.signedCmpEq pb.signedCmpEq + , scmp = pairCmp a b pa.scmp pb.scmp + }; + + +-- Zero class + +PZero : sort 0 -> sort 0; +PZero a = a; + +PZeroBit : PZero Bool; +PZeroBit = False; + +PZeroInteger : PZero Integer; +PZeroInteger = natToInt 0; + +PZeroIntMod : (n : Nat) -> PZero (IntMod n); +PZeroIntMod n = toIntMod n (natToInt 0); + +PZeroRational : PZero Rational; +PZeroRational = integerToRational (natToInt 0); + +PZeroIntModNum : (num : Num) -> PZero (IntModNum num); +PZeroIntModNum num = Num#rec (\ (n : Num) -> PZero (IntModNum n)) PZeroIntMod PZeroInteger num; + +PZeroSeq : (n : Num) -> (a : sort 0) -> PZero a -> PZero (seq n a); +PZeroSeq n a pa = seqConst n a pa; + +PZeroSeqBool : (n : Num) -> PZero (seq n Bool); +PZeroSeqBool n = + Num#rec (\ (n:Num) -> PZero (seq n Bool)) + (\ (n:Nat) -> bvNat n 0) + (streamConst Bool False) + n; + +PZeroFun : (a b : sort 0) -> PZero b -> PZero (a -> b); +PZeroFun a b pb = (\(_ : a) -> pb); + +-- Logic class + +PLogic : sort 0 -> sort 1; +PLogic a = + #{ logicZero : PZero a + , and : a -> a -> a + , or : a -> a -> a + , xor : a -> a -> a + , not : a -> a + }; + +PLogicBit : PLogic Bool; +PLogicBit = + { logicZero = PZeroBit + , and = and + , or = or + , xor = xor + , not = not + }; + +PLogicVec : (n : Nat) -> (a : sort 0) -> PLogic a -> PLogic (Vec n a); +PLogicVec n a pa = + { logicZero = replicate n a pa.logicZero + , and = zipWith a a a pa.and n + , or = zipWith a a a pa.or n + , xor = zipWith a a a pa.xor n + , not = map a a pa.not n + }; + +PLogicStream : (a : sort 0) -> PLogic a -> PLogic (Stream a); +PLogicStream a pa = + { logicZero = streamConst a pa.logicZero + , and = streamMap2 a a a pa.and + , or = streamMap2 a a a pa.or + , xor = streamMap2 a a a pa.xor + , not = streamMap a a pa.not + }; + +PLogicSeq : (n : Num) -> (a : sort 0) -> PLogic a -> PLogic (seq n a); +PLogicSeq n = + Num#rec (\ (n:Num) -> (a:sort 0) -> PLogic a -> PLogic (seq n a)) + (\ (n:Nat) -> PLogicVec n) PLogicStream n; + +PLogicWord : (n : Nat) -> PLogic (Vec n Bool); +PLogicWord n = + { logicZero = bvNat n 0 + , and = bvAnd n + , or = bvOr n + , xor = bvXor n + , not = bvNot n + }; + +PLogicSeqBool : (n : Num) -> PLogic (seq n Bool); +PLogicSeqBool n = + Num#rec (\ (n:Num) -> PLogic (seq n Bool)) + (\ (n:Nat) -> PLogicWord n) (PLogicStream Bool PLogicBit) n; + +PLogicFun : (a b : sort 0) -> PLogic b -> PLogic (a -> b); +PLogicFun a b pb = + { logicZero = PZeroFun a b pb.logicZero + , and = funBinary a b pb.and + , or = funBinary a b pb.or + , xor = funBinary a b pb.xor + , not = compose a b b pb.not + }; + +PLogicUnit : PLogic #(); +PLogicUnit = + { logicZero = () + , and = unitBinary + , or = unitBinary + , xor = unitBinary + , not = unitUnary + }; + +PLogicPair : (a b : sort 0) -> PLogic a -> PLogic b -> PLogic (a * b); +PLogicPair a b pa pb = + { logicZero = (pa.logicZero, pb.logicZero) + , and = pairBinary a b pa.and pb.and + , or = pairBinary a b pa.or pb.or + , xor = pairBinary a b pa.xor pb.xor + , not = pairUnary a b pa.not pb.not + }; + +-- Ring class + +PRing : sort 0 -> sort 1; +PRing a = + #{ ringZero : PZero a + , add : a -> a -> a + , sub : a -> a -> a + , mul : a -> a -> a + , neg : a -> a + , int : Integer -> a + }; + +PRingInteger : PRing Integer; +PRingInteger = + { ringZero = PZeroInteger + , add = intAdd + , sub = intSub + , mul = intMul + , neg = intNeg + , int = \ (i : Integer) -> i + }; + +PRingIntMod : (n : Nat) -> PRing (IntMod n); +PRingIntMod n = + { ringZero = PZeroIntMod n + , add = intModAdd n + , sub = intModSub n + , mul = intModMul n + , neg = intModNeg n + , int = toIntMod n + }; + +PRingIntModNum : (num : Num) -> PRing (IntModNum num); +PRingIntModNum num = + Num#rec (\ (n : Num) -> PRing (IntModNum n)) PRingIntMod PRingInteger num; + +PRingRational : PRing Rational; +PRingRational = + { ringZero = PZeroRational + , add = addRational + , sub = subRational + , mul = mulRational + , neg = negRational + , int = integerToRational + }; + +PRingVec : (n : Nat) -> (a : sort 0) -> PRing a -> PRing (Vec n a); +PRingVec n a pa = + { ringZero = replicate n a pa.ringZero + , add = zipWith a a a pa.add n + , sub = zipWith a a a pa.sub n + , mul = zipWith a a a pa.mul n + , neg = map a a pa.neg n + , int = \ (i : Integer) -> replicate n a (pa.int i) + }; + +PRingStream : (a : sort 0) -> PRing a -> PRing (Stream a); +PRingStream a pa = + { ringZero = streamConst a pa.ringZero + , add = streamMap2 a a a pa.add + , sub = streamMap2 a a a pa.sub + , mul = streamMap2 a a a pa.mul + , neg = streamMap a a pa.neg + , int = \ (i : Integer) -> streamConst a (pa.int i) + }; + +PRingSeq : (n : Num) -> (a : sort 0) -> PRing a -> PRing (seq n a); +PRingSeq n = + Num#rec (\ (n : Num) -> (a : sort 0) -> PRing a -> PRing (seq n a)) + (\ (n:Nat) -> PRingVec n) + PRingStream + n; + +PRingWord : (n : Nat) -> PRing (Vec n Bool); +PRingWord n = + { ringZero = bvNat n 0 + , add = bvAdd n + , sub = bvSub n + , mul = bvMul n + , neg = bvNeg n + , int = intToBv n + }; + +PRingSeqBool : (n : Num) -> PRing (seq n Bool); +PRingSeqBool n = + Num#rec (\ (n:Num) -> PRing (seq n Bool)) + (\ (n:Nat) -> PRingWord n) + (error (PRing (Stream Bool)) "PRingSeqBool: no instance for streams") + n; + +PRingFun : (a b : sort 0) -> PRing b -> PRing (a -> b); +PRingFun a b pb = + { ringZero = PZeroFun a b pb.ringZero + , add = funBinary a b pb.add + , sub = funBinary a b pb.sub + , mul = funBinary a b pb.mul + , neg = compose a b b pb.neg + , int = \ (i : Integer) -> \ (_ : a) -> pb.int i + }; + +PRingUnit : PRing #(); +PRingUnit = + { ringZero = () + , add = unitBinary + , sub = unitBinary + , mul = unitBinary + , neg = unitUnary + , int = \ (i : Integer) -> () + }; + +PRingPair : (a b : sort 0) -> PRing a -> PRing b -> PRing (a * b); +PRingPair a b pa pb = + { ringZero = (pa.ringZero, pb.ringZero) + , add = pairBinary a b pa.add pb.add + , sub = pairBinary a b pa.sub pb.sub + , mul = pairBinary a b pa.mul pb.mul + , neg = pairUnary a b pa.neg pb.neg + , int = \ (i : Integer) -> (pa.int i, pb.int i) + }; + +-- Integral class + +PIntegral : sort 0 -> sort 1; +PIntegral a = + #{ integralRing : PRing a + , div : a -> a -> a + , mod : a -> a -> a + , toInt : a -> Integer + , posNegCases : + (r : sort 0) -> + (Nat -> r) -> + (Nat -> r) -> + a -> r + }; + +PIntegralInteger : PIntegral Integer; +PIntegralInteger = + { integralRing = PRingInteger + , div = intDiv + , mod = intMod + , toInt = \(i:Integer) -> i + , posNegCases = \ (r:sort 0) -> \ (pos neg:Nat -> r) -> \ (i:Integer) -> + ite r (intLe (natToInt 0) i) (pos (intToNat i)) (neg (intToNat (intNeg i))) + }; + +PIntegralWord : (n : Nat) -> PIntegral (Vec n Bool); +PIntegralWord n = + { integralRing = PRingWord n + , div = bvUDiv n + , mod = bvURem n + , toInt = bvToInt n + + -- words are always considered non-negative + , posNegCases = \ (r:sort 0) -> \ (pos neg:Nat -> r) -> \(i:Vec n Bool) -> pos (bvToNat n i) + }; + +PIntegralSeqBool : (n : Num) -> PIntegral (seq n Bool); +PIntegralSeqBool n = + Num#rec (\ (n:Num) -> PIntegral (seq n Bool)) + (\ (n:Nat) -> PIntegralWord n) + (error (PIntegral (Stream Bool)) "PIntegralSeqBool: no instance for streams") + n; + + +-- Field class + +PField : sort 0 -> sort 1; +PField a = + #{ fieldRing : PRing a + , recip : a -> a + , fieldDiv : a -> a -> a + }; + +PFieldRational : PField Rational; +PFieldRational = + { fieldRing = PRingRational + , recip = \(x : Rational) -> error Rational "Unimplemented: recip Rational" + , fieldDiv = \(x y : Rational) -> error Rational "Unimplemented: (/.) Rational" + }; + + +PFieldIntMod : (n : Nat) -> PField (IntMod n); +PFieldIntMod n = + { fieldRing = PRingIntMod n + , recip = \(x : IntMod n) -> error (IntMod n) "Unimplemented: recip IntMod" + , fieldDiv = \(x y : IntMod n) -> error (IntMod n) "Unimplemented: (/.) IntMod" + }; + +PFieldIntModNum : (n : Num) -> PField (IntModNum n); +PFieldIntModNum num = + Num#rec (\ (n : Num) -> PField (IntModNum n)) + PFieldIntMod + (error (PField (IntModNum TCInf)) "PFieldIntModNum: no instance for inf") + num; + +-- Round class + +PRound : sort 0 -> sort 1; +PRound a = + #{ roundField : PField a + , roundCmp : PCmp a + , floor : a -> Integer + , ceiling : a -> Integer + , trunc : a -> Integer + , roundAway : a -> Integer + , roundToEven : a -> Integer + }; + +PRoundRational : PRound Rational; +PRoundRational = + { roundField = PFieldRational + , roundCmp = PCmpRational + , floor = \(x : Rational) -> error Integer "Unimplemented: floor Rational" + , ceiling = \(x : Rational) -> error Integer "Unimplemented: ceiling Rational" + , trunc = \(x : Rational) -> error Integer "Unimplemented: trunc Rational" + , roundAway = \(x : Rational) -> error Integer "Unimplemented: roundAway Rational" + , roundToEven = \(x : Rational) -> error Integer "Unimplemented: roundToEven Rational" + }; + + +-- Literal class + +-- Compared to Cryptol class 'Literal val a', we omit the 'val' parameter here. +-- As 'PLiteral' and 'PLiteralLessThan' are definitionally equal in saw-core, +-- the same dictionary constructors do double duty for both type classes. + +PLiteral : (a : sort 0) -> sort 0; +PLiteral a = Nat -> a; + +PLiteralLessThan : (a : sort 0) -> sort 0; +PLiteralLessThan a = Nat -> a; + +PLiteralSeqBool : (n : Num) -> PLiteral (seq n Bool); +PLiteralSeqBool n = + Num#rec (\ (n : Num) -> PLiteral (seq n Bool)) bvNat + (error (PLiteral (Stream Bool)) "PLiteralSeqBool: no instance for streams") n; + +PLiteralBit : PLiteral Bool; +PLiteralBit = Nat_cases Bool False (\ (n:Nat) -> \ (b:Bool) -> True); + +PLiteralInteger : PLiteral Integer; +PLiteralInteger = natToInt; + +PLiteralIntMod : (n : Nat) -> PLiteral (IntMod n); +PLiteralIntMod n = \ (x : Nat) -> toIntMod n (natToInt x); + +PLiteralIntModNum : (num : Num) -> PLiteral (IntModNum num); +PLiteralIntModNum num = + Num#rec (\ (n : Num) -> PLiteral (IntModNum n)) PLiteralIntMod PLiteralInteger num; + +PLiteralRational : PLiteral Rational; +PLiteralRational = \ (x : Nat) -> error Rational "Unimplemented: Literal Rational"; + +-- TODO: FLiteral class + + +-------------------------------------------------------------------------------- +-- Primitive Cryptol functions + +ecNumber : (val : Num) -> (a : sort 0) -> PLiteral a -> a; +ecNumber val a pa = + Num#rec (\ (_ : Num) -> a) pa (pa 0) val; + -- Dummy case: treat `inf as `0 (this never happens anyway) + +ecFromZ : (n : Num) -> IntModNum n -> Integer; +ecFromZ n = + Num#rec (\ (n : Num) -> IntModNum n -> Integer) + fromIntMod + (\ (x : Integer) -> x) + n; + +-- Ring +ecFromInteger : (a : sort 0) -> PRing a -> Integer -> a; +ecFromInteger a pa = pa.int; + +ecPlus : (a : sort 0) -> PRing a -> a -> a -> a; +ecPlus a pa = pa.add; + +ecMinus : (a : sort 0) -> PRing a -> a -> a -> a; +ecMinus a pa = pa.sub; + +ecMul : (a : sort 0) -> PRing a -> a -> a -> a; +ecMul a pa = pa.mul; + +ecNeg : (a : sort 0) -> PRing a -> a -> a; +ecNeg a pa = pa.neg; + +-- Integral +ecToInteger : (a : sort 0) -> PIntegral a -> a -> Integer; +ecToInteger a pa = pa.toInt; + +ecDiv : (a : sort 0) -> PIntegral a -> a -> a -> a; +ecDiv a pi = pi.div; + +ecMod : (a : sort 0) -> PIntegral a -> a -> a -> a; +ecMod a pi = pi.mod; + +ecExp : (a b: sort 0) -> PRing a -> PIntegral b -> a -> b -> a; +ecExp a b pa pi x = + pi.posNegCases a + (expByNat a (pa.int (natToInt 1)) pa.mul x) + (\ (_:Nat) -> pa.int (natToInt 1)); + -- (error (Nat -> a) "ecExp : negative exponent"); + +-- Field + +ecRecip : (a: sort 0) -> PField a -> a -> a; +ecRecip a pf = pf.recip; + +ecFieldDiv : (a: sort 0) -> PField a -> a -> a -> a; +ecFieldDiv a pf = pf.fieldDiv; + +-- Round + +ecCeiling : (a: sort 0) -> PRound a -> a -> Integer; +ecCeiling a pr = pr.ceiling; + +ecFloor : (a: sort 0) -> PRound a -> a -> Integer; +ecFloor a pr = pr.floor; + +ecTruncate : (a: sort 0) -> PRound a -> a -> Integer; +ecTruncate a pr = pr.trunc; + +ecRoundAway : (a: sort 0) -> PRound a -> a -> Integer; +ecRoundAway a pr = pr.roundAway; + +ecRoundToEven : (a: sort 0) -> PRound a -> a -> Integer; +ecRoundToEven a pr = pr.roundToEven; + +-- Bitvector ops + +ecLg2 : (n : Num) -> seq n Bool -> seq n Bool; +ecLg2 n = + Num#rec (\ (n:Num) -> seq n Bool -> seq n Bool) + bvLg2 + (error (Stream Bool -> Stream Bool) "ecLg2: expected finite word") + n; + +ecSDiv : (n : Num) -> seq n Bool -> seq n Bool -> seq n Bool; +ecSDiv n = + Num#rec (\ (n:Num) -> seq n Bool -> seq n Bool -> seq n Bool) + (Nat__rec (\ (n:Nat) -> Vec n Bool -> Vec n Bool -> Vec n Bool) + (error (Vec 0 Bool -> Vec 0 Bool -> Vec 0 Bool) "ecSDiv: illegal 0-width word") + (\ (n':Nat) -> \ (_:Vec n' Bool -> Vec n' Bool -> Vec n' Bool) -> bvSDiv n')) + (error (Stream Bool -> Stream Bool -> Stream Bool) "ecSDiv: expected finite word") + n; + +ecSMod : (n : Num) -> seq n Bool -> seq n Bool -> seq n Bool; +ecSMod n = + Num#rec (\ (n:Num) -> seq n Bool -> seq n Bool -> seq n Bool) + (Nat__rec (\ (n:Nat) -> Vec n Bool -> Vec n Bool -> Vec n Bool) + (error (Vec 0 Bool -> Vec 0 Bool -> Vec 0 Bool) "ecSMod: illegal 0-width word") + (\ (n':Nat) -> \ (_:Vec n' Bool -> Vec n' Bool -> Vec n' Bool) -> bvSRem n')) + (error (Stream Bool -> Stream Bool -> Stream Bool) "ecSMod: expected finite word") + n; + + +-- Eq +ecEq : (a : sort 0) -> PEq a -> a -> a -> Bool; +ecEq a pa = pa.eq; + +ecNotEq : (a : sort 0) -> PEq a -> a -> a -> Bool; +ecNotEq a pa x y = not (ecEq a pa x y); + +-- Cmp +ecLt : (a : sort 0) -> PCmp a -> a -> a -> Bool; +ecLt a pa x y = pa.cmp x y False; + +ecGt : (a : sort 0) -> PCmp a -> a -> a -> Bool; +ecGt a pa x y = ecLt a pa y x; + +ecLtEq : (a : sort 0) -> PCmp a -> a -> a -> Bool; +ecLtEq a pa x y = not (ecLt a pa y x); + +ecGtEq : (a : sort 0) -> PCmp a -> a -> a -> Bool; +ecGtEq a pa x y = not (ecLt a pa x y); + +-- SignedCmp +ecSLt : (a : sort 0) -> PSignedCmp a -> a -> a -> Bool; +ecSLt a pa x y = pa.scmp x y False; + +-- Logic +ecAnd : (a : sort 0) -> PLogic a -> a -> a -> a; +ecAnd a pa = pa.and; + +ecOr : (a : sort 0) -> PLogic a -> a -> a -> a; +ecOr a pa = pa.or; + +ecXor : (a : sort 0) -> PLogic a -> a -> a -> a; +ecXor a pa = pa.xor; + +ecCompl : (a : sort 0) -> PLogic a -> a -> a; +ecCompl a pa = pa.not; + +ecZero : (a : sort 0) -> PZero a -> a; +ecZero a pa = pa; + +-- FLiteral + +ecFraction : (a : sort 0) -> a; +ecFraction a = error a "Unimplemented: fraction"; + + +-- Sequences +ecShiftL : (m : Num) -> (ix a : sort 0) -> PIntegral ix -> PZero a -> + seq m a -> ix -> seq m a; +ecShiftL m = + Num#rec + (\ (m:Num) -> (ix a : sort 0) -> PIntegral ix -> PZero a -> seq m a -> ix -> seq m a) + + -- Case for (TCNum m) + (\ (m:Nat) -> \ (ix:sort 0) -> \ (a:sort 0) -> \ (pix : PIntegral ix) -> \ (pz:PZero a) -> \ (xs:Vec m a) -> + pix.posNegCases (Vec m a) + (shiftL m a (ecZero a pz) xs) + (shiftR m a (ecZero a pz) xs)) + + -- Case for (infinity) + (\ (ix:sort 0) -> \ (a:sort 0) -> \ (pix : PIntegral ix) -> \ (pz:PZero a) -> + \ (xs:Stream a) -> + pix.posNegCases (Stream a) + (streamShiftL a xs) + (streamShiftR a pz xs)) + m; + +ecShiftR : (m : Num) -> (ix a : sort 0) -> PIntegral ix -> PZero a -> + seq m a -> ix -> seq m a; +ecShiftR m = + Num#rec + (\ (m : Num) -> (ix a : sort 0) -> PIntegral ix -> PZero a -> seq m a -> ix -> seq m a) + + -- Case for (TCNum m) + (\ (m:Nat) -> \ (ix:sort 0) -> \ (a:sort 0) -> \ (pix : PIntegral ix) -> \ (pz:PZero a) -> \ (xs:Vec m a) -> + pix.posNegCases (Vec m a) + (shiftR m a (ecZero a pz) xs) + (shiftL m a (ecZero a pz) xs)) + + -- Case for (infinity) + (\ (ix:sort 0) -> \ (a:sort 0) -> \ (pix : PIntegral ix) -> \ (pz:PZero a) -> \ (xs:Stream a) -> + pix.posNegCases (Stream a) + (streamShiftR a pz xs) + (streamShiftL a xs)) + m; + +ecSShiftR : (n : Num) -> (ix : sort 0) -> PIntegral ix -> seq n Bool -> ix -> seq n Bool; +ecSShiftR = + finNumRec + (\ (n:Num) -> (ix : sort 0) -> PIntegral ix -> seq n Bool -> ix -> seq n Bool) + (\ (n:Nat) -> + (\ (ix : sort 0) -> \ (pix : PIntegral ix) -> + natCase + (\ (w : Nat) -> Vec w Bool -> ix -> Vec w Bool) + (\ (xs : Vec 0 Bool) -> \ (_ : ix) -> xs) + (\ (w : Nat) -> \ (xs : Vec (Succ w) Bool) -> + pix.posNegCases (Vec (Succ w) Bool) + (bvSShr w xs) + (bvShl (Succ w) xs)) + n)); + +ecRotL : (m : Num) -> (ix a : sort 0) -> PIntegral ix -> seq m a -> ix -> seq m a; +ecRotL = + finNumRec + (\ (m:Num) -> (ix a : sort 0) -> PIntegral ix -> seq m a -> ix -> seq m a) + (\ (m:Nat) -> \ (ix:sort 0) -> \ (a:sort 0) -> \ (pix:PIntegral ix) -> \ (xs:Vec m a) -> + pix.posNegCases (Vec m a) + (rotateL m a xs) + (rotateR m a xs)); + +ecRotR : (m : Num) -> (ix a : sort 0) -> PIntegral ix -> seq m a -> ix -> seq m a; +ecRotR = + finNumRec + (\ (m:Num) -> (ix a : sort 0) -> PIntegral ix -> seq m a -> ix -> seq m a) + (\ (m:Nat) -> \ (ix:sort 0) -> \ (a:sort 0) -> \ (pix:PIntegral ix) -> \ (xs:Vec m a) -> + pix.posNegCases (Vec m a) + (rotateR m a xs) + (rotateL m a xs)); + +ecCat : (m n : Num) -> (a : sort 0) -> seq m a -> seq n a -> seq (tcAdd m n) a; +ecCat = + finNumRec + (\ (m:Num) -> (n:Num) -> (a:sort 0) -> seq m a -> seq n a -> + seq (tcAdd m n) a) + (\ (m:Nat) -> + Num_rec + (\ (n:Num) -> (a:sort 0) -> Vec m a -> seq n a -> + seq (tcAdd (TCNum m) n) a) + -- Case for (TCNum m, TCNum n) + (\ (n:Nat) -> \ (a:sort 0) -> append m n a) + -- Case for (TCNum m, TCInf) + (\ (a:sort 0) -> streamAppend a m)); + +ecSplitAt : (m n : Num) -> (a : sort 0) -> seq (tcAdd m n) a -> + #(seq m a, seq n a); +ecSplitAt = + finNumRec + (\ (m:Num) -> (n:Num) -> (a:sort 0) -> seq (tcAdd m n) a -> + #(seq m a, seq n a)) + (\ (m:Nat) -> + Num_rec + (\ (n:Num) -> (a:sort 0) -> seq (tcAdd (TCNum m) n) a -> + #(Vec m a, seq n a)) + -- The case (TCNum n, TCNum m) + (\ (n:Nat) -> \ (a:sort 0) -> \ (xs: Vec (addNat m n) a) -> + (take a m n xs, drop a m n xs)) + -- The case (TCNum m, infinity) + (\ (a:sort 0) -> \ (xs: Stream a) -> + (streamTake a m xs, streamDrop a m xs))); + +ecJoin : (m n : Num) -> (a : sort 0) -> seq m (seq n a) -> seq (tcMul m n) a; +ecJoin m = + Num#rec + (\ (m:Num) -> (n:Num) -> (a:sort 0) -> seq m (seq n a) -> + seq (tcMul m n) a) + (\ (m:Nat) -> + finNumRec + (\ (n:Num) -> (a:sort 0) -> Vec m (seq n a) -> + seq (tcMul (TCNum m) n) a) + -- Case for (TCNum m, TCNum n) + (\ (n:Nat) -> \ (a:sort 0) -> join m n a) + -- No case for (TCNum m, TCInf) + ) + (finNumRec + (\ (n:Num) -> (a:sort 0) -> Stream (seq n a) -> + seq (tcMul TCInf n) a) + -- Case for (TCInf, TCNum n) + (\ (n:Nat) -> \ (a:sort 0) -> + natCase + (\ (n':Nat) -> Stream (Vec n' a) -> + seq (if0Nat Num n' (TCNum 0) TCInf) a) + (\ (s:Stream (Vec 0 a)) -> EmptyVec a) + (\ (n':Nat) -> \ (s:Stream (Vec (Succ n') a)) -> + streamJoin a n' s) + n) + -- No case for (TCInf, TCInf) + ) + m; + +ecSplit : (m n : Num) -> (a : sort 0) -> seq (tcMul m n) a -> + seq m (seq n a); +ecSplit m = + Num#rec + (\ (m:Num) -> (n:Num) -> (a:sort 0) -> seq (tcMul m n) a -> + seq m (seq n a)) + (\ (m:Nat) -> + finNumRec + (\ (n:Num) -> (a:sort 0) -> seq (tcMul (TCNum m) n) a -> + Vec m (seq n a)) + -- Case for (TCNum m, TCNum n) + (\ (n:Nat) -> \ (a:sort 0) -> split m n a) + -- No case for (TCNum m, TCInf) + ) + (finNumRec + (\ (n:Num) -> (a:sort 0) -> seq (tcMul TCInf n) a -> Stream (seq n a)) + -- Case for (TCInf, TCNum n) + (\ (n:Nat) -> \ (a:sort 0) -> + natCase + (\ (n':Nat) -> + seq (if0Nat Num n' (TCNum 0) TCInf) a -> + Stream (Vec n' a)) + (streamConst (Vec 0 a)) + (\ (n':Nat) -> streamSplit a (Succ n')) + n)) + m; + +ecReverse : (n : Num) -> (a : sort 0) -> seq n a -> seq n a; +ecReverse = + finNumRec + (\ (n:Num) -> (a:sort 0) -> seq n a -> seq n a) reverse; + +ecTranspose : (m n : Num) -> (a : sort 0) -> seq m (seq n a) -> + seq n (seq m a); +ecTranspose m n a = + Num#rec + (\ (m : Num) -> seq m (seq n a) -> seq n (seq m a)) + (\ (m : Nat) -> + Num#rec + (\ (n : Num) -> Vec m (seq n a) -> seq n (Vec m a)) + (\ (n : Nat) -> transpose m n a) + (\ (xss : Vec m (Stream a)) -> + MkStream (Vec m a) (\ (i : Nat) -> + gen m a (\ (j : Nat) -> + streamGet a (at m (Stream a) xss j) i))) + n + ) + ( Num#rec + (\ (n : Num) -> Stream (seq n a) -> seq n (Stream a)) + (\ (n : Nat) -> \ (xss : Stream (Vec n a)) -> + gen n (Stream a) (\ (i : Nat) -> + MkStream a (\ (j : Nat) -> + at n a (streamGet (Vec n a) xss j) i))) + (\ (xss : Stream (Stream a)) -> + MkStream (Stream a) (\ (i : Nat) -> + MkStream a (\ (j : Nat) -> + streamGet a (streamGet (Stream a) xss j) i))) + n + ) + m; + +ecAt : (n : Num) -> (a ix: sort 0) -> PIntegral ix -> seq n a -> ix -> a; +ecAt n = + Num#rec + (\ (n:Num) -> (a ix: sort 0) -> PIntegral ix -> seq n a -> ix -> a) + (\ (n:Nat) -> \ (a:sort 0) -> \ (ix:sort 0) -> \ (pix:PIntegral ix) -> \ (xs:Vec n a) -> + pix.posNegCases a + (at n a xs) + (\ (_:Nat) -> at n a xs 0)) + -- (error (Nat -> a) "ecAt : negative index")) + (\ (a:sort 0) -> \ (ix:sort 0) -> \ (pix:PIntegral ix) -> \ (xs:Stream a) -> + pix.posNegCases a + (streamGet a xs) + (\ (_:Nat) -> streamGet a xs 0)) +-- (error (Nat -> a) "ecAt : negative index")) + n; + +ecAtBack : (n : Num) -> (a ix : sort 0) -> PIntegral ix -> seq n a -> ix -> a; +ecAtBack n a ix pix xs = ecAt n a ix pix (ecReverse n a xs); + +ecFromTo : (first last : Num) -> (a : sort 0) -> PLiteral a -> PLiteral a -> + seq (tcAdd (TCNum 1) (tcSub last first)) a; +ecFromTo = + finNumRec + (\ (first:Num) -> (last:Num) -> (a : sort 0) -> PLiteral a -> PLiteral a -> + seq (tcAdd (TCNum 1) (tcSub last first)) a) + (\ (first:Nat) -> + finNumRec + (\ (last:Num) -> (a : sort 0) -> PLiteral a -> PLiteral a -> + seq (tcAdd (TCNum 1) (tcSub last (TCNum first))) a) + (\ (last:Nat) -> \ (a : sort 0) -> \ (pa : PLiteral a) -> \ (_ : PLiteral a) -> + gen (addNat 1 (subNat last first)) a + (\ (i : Nat) -> pa (addNat i first)))); + +ecFromToLessThan : + (first bound : Num) -> (a : sort 0) -> PLiteralLessThan a -> seq (tcSub bound first) a; +ecFromToLessThan first bound a = + finNumRec + (\ (first:Num) -> PLiteralLessThan a -> + seq (tcSub bound first) a) + (\ (first:Nat) -> + Num#rec + (\ (bound:Num) -> PLiteralLessThan a -> + seq (tcSub bound (TCNum first)) a) + (\ (bound:Nat) -> \ (pa : PLiteralLessThan a) -> + gen (subNat bound first) a + (\ (i : Nat) -> pa (addNat i first))) + (\ (pa : PLiteralLessThan a) -> + MkStream a (\ (i : Nat) -> pa (addNat i first))) + bound) + first; + +ecFromThenTo : + (first next last : Num) -> (a : sort 0) -> (len : Num) -> + PLiteral a -> PLiteral a -> PLiteral a -> seq len a; +ecFromThenTo first next _ a = + finNumRec + (\ (len:Num) -> PLiteral a -> PLiteral a -> PLiteral a -> seq len a) + (\ (len:Nat) -> \ (pa : PLiteral a) -> \ (_ : PLiteral a) -> \ (_ : PLiteral a) -> + gen len a + (\ (i : Nat) -> + pa (subNat (addNat (getFinNat first) + (mulNat i (getFinNat next))) + (mulNat i (getFinNat first))))); + +-- Infinite word sequences +ecInfFrom : (a : sort 0) -> PIntegral a -> a -> seq TCInf a; +ecInfFrom a pa x = + MkStream a (\ (i : Nat) -> pa.integralRing.add x (pa.integralRing.int (natToInt i))); + +ecInfFromThen : (a : sort 0) -> PIntegral a -> a -> a -> seq TCInf a; +ecInfFromThen a pa x y = + MkStream a (\ (i : Nat) -> + pa.integralRing.add x (pa.integralRing.mul (pa.integralRing.sub y x) (pa.integralRing.int (natToInt i)))); + + +-- Run-time error +ecError : (a : sort 0) -> (len : Num) -> seq len (Vec 8 Bool) -> a; +ecError a len msg = error a "encountered call to the Cryptol 'error' function"; -- FIXME: don't throw away message +{- +primitive cryError : (a : sort 0) -> (n : Nat) -> Vec n (Vec 8 Bool) -> a; + +ecError : (a : sort 0) -> (len : Num) -> seq len (Vec 8 Bool) -> a; +ecError a = + finNumRec + (\ (len:Num) -> seq len (Vec 8 Bool) -> a) + (\ (len:Nat) -> cryError a len); +-} + +-- Random values +ecRandom : (a : sort 0) -> Vec 32 Bool -> a; +ecRandom a _ = error a "Cryptol.random"; + +-- Trace function; simply return the final argument +ecTrace : (n : Num) -> (a b : sort 0) -> seq n (Vec 8 Bool) -> a -> b -> b; +ecTrace _ _ _ _ _ x = x; + + +-------------------------------------------------------------------------------- +-- Strict evaluation primitives (Experimental) +-- +-- These are implemented here as ordinary functions without special evaluation +-- behavior: parmap is ordinary map, and foldl' is ordinary foldl. + +-- deepseq : {a, b} (Eq a) => a -> b -> b +ecDeepseq : (a : sort 0) -> (b : sort 0) -> PEq a -> a -> b -> b; +ecDeepseq a b pa x y = y; + +-- parmap : {a, b, n} (Eq b, fin n) => (a -> b) -> [n]a -> [n]b +ecParmap : (a:sort 0) -> (b:sort 0) -> (n: Num) -> PEq b -> (a -> b) -> seq n a -> seq n b; +ecParmap a b n pb = + Num#rec (\ (n:Num) -> (a -> b) -> seq n a -> seq n b) + ( \ (n:Nat) -> \ (f: a -> b) -> \ (xs: Vec n a) -> map a b f n xs ) + ( \ (f: a -> b) -> \ (xs:Stream a) -> error (Stream b) "Unexpected infinite stream in parmap" ) + n; + +-- foldl : {n, a, b} (fin n) => (a -> b -> a) -> a -> [n]b -> a +ecFoldl : (n : Num) -> (a : sort 0) -> (b : sort 0) -> (a -> b -> a) -> a -> seq n b -> a; +ecFoldl n a b f z = + Num#rec (\ (n : Num) -> seq n b -> a) + (\ (n : Nat) -> \ (xs : Vec n b) -> foldr b a n (\ (y : b) -> \ (x : a) -> f x y) z (reverse n b xs)) + (\ (xs : Stream b) -> error a "Unexpected infinite stream in foldl" ) + n; + +-- foldl' : {n, a, b} (fin n, Eq a) => (a -> b -> a) -> a -> [n]b -> a +ecFoldlPrime : + (n : Num) -> (a : sort 0) -> (b : sort 0) -> PEq a -> (a -> b -> a) -> a -> seq n b -> a; +ecFoldlPrime n a b pa = ecFoldl n a b; + +-------------------------------------------------------------------------------- +-- Floating point primitives (TODO) + +TCFloat : Num -> Num -> sort 0; +TCFloat _ _ = #(); + +PEqFloat : (e p : Num) -> PEq (TCFloat e p); +PEqFloat e p = { eq = \(x y : TCFloat e p) -> error Bool "Unimplemented: (==) Float" }; + +PCmpFloat : (e p : Num) -> PCmp (TCFloat e p); +PCmpFloat e p = + { cmpEq = PEqFloat e p + , cmp = \(x y : TCFloat e p) (k : Bool) -> error Bool "Unimplemented: Cmp Float" + }; + +PZeroFloat : (e p : Num) -> PZero (TCFloat e p); +PZeroFloat e p = error (TCFloat e p) "Unimplemented: Zero Float"; + +PRingFloat : (e p : Num) -> PRing (TCFloat e p); +PRingFloat e p = + { ringZero = PZeroFloat e p + , add = \(x y : TCFloat e p) -> error (TCFloat e p) "Unimplemented: (+) Float" + , sub = \(x y : TCFloat e p) -> error (TCFloat e p) "Unimplemented: (-) Float" + , mul = \(x y : TCFloat e p) -> error (TCFloat e p) "Unimplemented: (*) Float" + , neg = \(x : TCFloat e p) -> error (TCFloat e p) "Unimplemented: neg Float" + , int = \ (i : Integer) -> error (TCFloat e p) "Unimplemented: toInteger Float" + }; + +PFieldFloat : (e p : Num) -> PField (TCFloat e p); +PFieldFloat e p = + { fieldRing = PRingFloat e p + , recip = \(x : TCFloat e p) -> error (TCFloat e p) "Unimplemented: recip Float" + , fieldDiv = \(x y : TCFloat e p) -> error (TCFloat e p) "Unimplemented: (/.) Float" + }; + +PRoundFloat : (e p : Num) -> PRound (TCFloat e p); +PRoundFloat e p = + { roundField = PFieldFloat e p + , roundCmp = PCmpFloat e p + , floor = \(x : TCFloat e p) -> error Integer "Unimplemented: floor Float" + , ceiling = \(x : TCFloat e p) -> error Integer "Unimplemented: ceiling Float" + , trunc = \(x : TCFloat e p) -> error Integer "Unimplemented: trunc Float" + , roundAway = \(x : TCFloat e p) -> error Integer "Unimplemented: roundAway Float" + , roundToEven = \(x : TCFloat e p) -> error Integer "Unimplemented: roundToEven Float" + }; + +PLiteralFloat : (e p : Num) -> PLiteral (TCFloat e p); +PLiteralFloat e p = \ (x : Nat) -> error (TCFloat e p) "Unimplemented: Literal Float"; + +ecFpNaN : (e : Num) -> (p : Num) -> TCFloat e p; +ecFpNaN e p = error (TCFloat e p) "Unimplemented: fpNaN"; + +ecFpPosInf : (e : Num) -> (p : Num) -> TCFloat e p; +ecFpPosInf e p = error (TCFloat e p) "Unimplemented: fpPosInf"; + +ecFpFromBits : (e : Num) -> (p : Num) -> seq (tcAdd e p) Bool -> TCFloat e p; +ecFpFromBits e p _ = error (TCFloat e p) "Unimplemented: fpFromBits"; + +ecFpToBits : (e : Num) -> (p : Num) -> TCFloat e p -> seq (tcAdd e p) Bool; +ecFpToBits e p _ = error (seq (tcAdd e p) Bool) "Unimplemented: fpToBits"; + +ecFpEq : (e : Num) -> (p : Num) -> TCFloat e p -> TCFloat e p -> Bool; +ecFpEq e p _ _ = error Bool "Unimplemented: =.="; + +ecFpAdd : (e : Num) -> (p : Num) -> Vec 3 Bool -> TCFloat e p -> TCFloat e p -> TCFloat e p; +ecFpAdd e p _ _ _ = error (TCFloat e p) "Unimplemented: fpAdd"; + +ecFpSub : (e : Num) -> (p : Num) -> Vec 3 Bool -> TCFloat e p -> TCFloat e p -> TCFloat e p; +ecFpSub e p _ _ _ = error (TCFloat e p) "Unimplemented: fpSub"; + +ecFpMul : (e : Num) -> (p : Num) -> Vec 3 Bool -> TCFloat e p -> TCFloat e p -> TCFloat e p; +ecFpMul e p _ _ _ = error (TCFloat e p) "Unimplemented: fpMul"; + +ecFpDiv : (e : Num) -> (p : Num) -> Vec 3 Bool -> TCFloat e p -> TCFloat e p -> TCFloat e p; +ecFpDiv e p _ _ _ = error (TCFloat e p) "Unimplemented: fpDiv"; + +ecFpToRational : (e : Num) -> (p : Num) -> TCFloat e p -> Rational; +ecFpToRational e p _ = error Rational "Unimplemented: fpToRational"; + +ecFpFromRational : (e : Num) -> (p : Num) -> Vec 3 Bool -> Rational -> TCFloat e p; +ecFpFromRational e p _ _ = error (TCFloat e p) "Unimplemented: fpFromRational"; + +fpIsNaN : (e : Num) -> (p : Num) -> TCFloat e p -> Bool; +fpIsNaN e p x = error Bool "Unimplemented: fpIsNaN"; + +fpIsInf : (e : Num) -> (p : Num) -> TCFloat e p -> Bool; +fpIsInf e p x = error Bool "Unimplemented: fpIsInf"; + +fpIsZero : (e : Num) -> (p : Num) -> TCFloat e p -> Bool; +fpIsZero e p x = error Bool "Unimplemented: fpIsZero"; + +fpIsNeg : (e : Num) -> (p : Num) -> TCFloat e p -> Bool; +fpIsNeg e p x = error Bool "Unimplemented: fpIsNeg"; + +fpIsNormal : (e : Num) -> (p : Num) -> TCFloat e p -> Bool; +fpIsNormal e p x = error Bool "Unimplemented: fpIsNormal"; + +fpIsSubnormal : (e : Num) -> (p : Num) -> TCFloat e p -> Bool; +fpIsSubnormal e p x = error Bool "Unimplemented: fpIsSubnormal"; + +fpFMA : + (e : Num) -> (p : Num) -> Vec 3 Bool -> + TCFloat e p -> TCFloat e p -> TCFloat e p -> TCFloat e p; +fpFMA e p r x y z = error (TCFloat e p) "Unimplemented: fpFMA"; + +fpAbs : (e : Num) -> (p : Num) -> TCFloat e p -> TCFloat e p; +fpAbs e p x = error (TCFloat e p) "Unimplemented: fpAbs"; + +fpSqrt : (e : Num) -> (p : Num) -> Vec 3 Bool -> TCFloat e p -> TCFloat e p; +fpSqrt e p r x = error (TCFloat e p) "Unimplemented: fpSqrt"; + + +-------------------------------------------------------------------------------- +-- Extra primitives + +-- Array update +ecUpdate : (n : Num) -> (a ix: sort 0) -> PIntegral ix -> seq n a -> ix -> a -> seq n a; +ecUpdate n = + Num#rec + (\ (n:Num) -> (a ix : sort 0) -> PIntegral ix -> seq n a -> ix -> a -> seq n a) + (\ (n:Nat) -> \ (a:sort 0) -> \ (ix : sort 0) -> \ (pix:PIntegral ix) -> \ (xs : Vec n a) -> + -- Case for (TCNum n, TCNum w) + pix.posNegCases (a -> Vec n a) + (upd n a xs) + (\ (_:Nat) -> \ (_:a) -> xs)) + -- (error (Nat -> a -> Vec n a) "ecUpdate: negative index")) + (\ (a:sort 0) -> \ (ix:sort 0) -> \ (pix:PIntegral ix) -> \ (xs : Stream a) -> + pix.posNegCases (a -> Stream a) + (streamUpd a xs) + (\ (_:Nat) -> \ (_:a) -> xs)) + --(error (Nat -> a -> Stream a) "ecUpdate: negative index")) + n; + + +ecUpdateEnd : (n : Num) -> (a ix: sort 0) -> PIntegral ix -> seq n a -> ix -> a -> seq n a; +ecUpdateEnd = + finNumRec + (\ (n:Num) -> (a ix: sort 0) -> PIntegral ix -> seq n a -> ix -> a -> seq n a) + (\ (n:Nat) -> \ (a:sort 0) -> \ (ix:sort 0) -> \ (pix:PIntegral ix) -> \ (xs:Vec n a) -> + pix.posNegCases (a -> Vec n a) + (\ (i:Nat) -> upd n a xs (subNat (subNat n 1) i)) + (\ (_:Nat) -> \ (_:a) -> xs)); + -- (error (Nat -> a -> Vec n a) "ecUpdateEnd: negative index")); + + +-- Bitvector truncation +ecTrunc : (m n : Num) -> seq (tcAdd m n) Bool -> seq n Bool; +ecTrunc = + finNumRec2 + (\ (m:Num) -> \ (n:Num) -> seq (tcAdd m n) Bool -> seq n Bool) + bvTrunc; + +-- Zero extension +ecUExt : (m n : Num) -> seq n Bool -> seq (tcAdd m n) Bool; +ecUExt = + finNumRec2 (\ (m:Num) -> \ (n:Num) -> seq n Bool -> seq (tcAdd m n) Bool) + bvUExt; + +ecSExt : (m n : Num) -> seq n Bool -> seq (tcAdd m n) Bool; +ecSExt = + finNumRec2 + (\ (m n : Num) -> seq n Bool -> seq (tcAdd m n) Bool) + (\ (m n : Nat) -> + natCase + (\ (n' : Nat) -> Vec n' Bool -> Vec (addNat m n') Bool) + (\ (_ : Vec 0 Bool) -> bvNat (addNat m 0) 0) + (bvSExt m) + n); + +-- Signed greater-than +ecSgt : (n : Num) -> seq n Bool -> seq n Bool -> Bool; +ecSgt = + finNumRec (\ (n : Num) -> seq n Bool -> seq n Bool -> Bool) bvsgt; + +-- Signed greater-or-equal +ecSge : (n : Num) -> seq n Bool -> seq n Bool -> Bool; +ecSge = + finNumRec (\ (n : Num) -> seq n Bool -> seq n Bool -> Bool) bvsge; + +-- Signed less-than +ecSlt : (n : Num) -> seq n Bool -> seq n Bool -> Bool; +ecSlt = + finNumRec (\ (n : Num) -> seq n Bool -> seq n Bool -> Bool) bvslt; + +-- Signed less-or-equal +ecSle : (n : Num) -> seq n Bool -> seq n Bool -> Bool; +ecSle = + finNumRec (\ (n : Num) -> seq n Bool -> seq n Bool -> Bool) bvsle; + +-- Array operations +ecArrayConstant : (a b : sort 0) -> b -> Array a b; +ecArrayConstant = arrayConstant; + +ecArrayLookup : (a b : sort 0) -> (Array a b) -> a -> b; +ecArrayLookup = arrayLookup; + +ecArrayUpdate : (a b : sort 0) -> (Array a b) -> a -> b -> (Array a b); +ecArrayUpdate = arrayUpdate; + +-------------------------------------------------------------------------------- +-- Rewrite rules + +axiom replicate_False : (n : Nat) -> Eq (Vec n Bool) (replicate n Bool False) (bvNat n 0); + +axiom subNat_0 : (n : Nat) -> Eq Nat (subNat n 0) n; + +{- +axiom demote_add_distr + : (w : Nat) + -> (x y : Num) + -> Eq (Vec w Bool) + (ecNumber (tcAdd x y) (TCNum w)) + (bvAdd w (ecNumber x (TCNum w)) (ecNumber y (TCNum w))); +-} + +-------------------------------------------------------------------------------- diff --git a/cryptol-saw-core/src/Verifier/SAW/Cryptol.hs b/cryptol-saw-core/src/Verifier/SAW/Cryptol.hs new file mode 100644 index 0000000000..2e293779c3 --- /dev/null +++ b/cryptol-saw-core/src/Verifier/SAW/Cryptol.hs @@ -0,0 +1,1770 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE DoAndIfThenElse #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TupleSections #-} + +{- | +Module : Verifier.SAW.Cryptol +Copyright : Galois, Inc. 2012-2015 +License : BSD3 +Maintainer : huffman@galois.com +Stability : experimental +Portability : non-portable (language extensions) +-} + +module Verifier.SAW.Cryptol where + +import Control.Monad (foldM, join, unless) +import Data.Bifunctor (first) +import qualified Data.Foldable as Fold +import Data.List +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Maybe (fromMaybe) +import qualified Data.IntTrie as IntTrie +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Data.Set as Set +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Vector as Vector +import Prelude () +import Prelude.Compat +import Text.URI + +import qualified Cryptol.Eval.Type as TV +import qualified Cryptol.Backend.Monad as V +import qualified Cryptol.Eval.Value as V +import qualified Cryptol.Eval.Concrete as V +import Cryptol.Eval.Type (evalValType) +import qualified Cryptol.TypeCheck.AST as C +import qualified Cryptol.TypeCheck.Subst as C (Subst, apSubst, listSubst, singleTParamSubst) +import qualified Cryptol.ModuleSystem.Name as C + (asPrim, nameUnique, nameIdent, nameInfo, NameInfo(..)) +import qualified Cryptol.Utils.Ident as C + ( Ident, PrimIdent(..), mkIdent, prelPrim, floatPrim, arrayPrim + , ModName, modNameToText, identText, interactiveName + ) +import qualified Cryptol.Utils.RecordMap as C +import Cryptol.TypeCheck.TypeOf (fastTypeOf, fastSchemaOf) +import Cryptol.Utils.PP (pretty) + +import Verifier.SAW.Cryptol.Panic +import Verifier.SAW.Conversion +import Verifier.SAW.FiniteValue (FirstOrderType(..), FirstOrderValue(..)) +import qualified Verifier.SAW.Simulator.Concrete as SC +import Verifier.SAW.Prim (BitVector(..)) +import Verifier.SAW.Rewriter +import Verifier.SAW.SharedTerm +import Verifier.SAW.Simulator.MonadLazy (force) +import Verifier.SAW.TypedAST (mkSort, mkModuleName, FieldName, LocalName) + +import GHC.Stack + +-------------------------------------------------------------------------------- +-- Type Environments + +-- | SharedTerms are paired with a deferred shift amount for loose variables +data Env = Env + { envT :: Map Int (Term, Int) -- ^ Type variables are referenced by unique id + , envE :: Map C.Name (Term, Int) -- ^ Term variables are referenced by name + , envP :: Map C.Prop (Term, [FieldName], Int) + -- ^ Bound propositions are referenced implicitly by their types + -- The actual class dictionary we need is obtained by applying the + -- given field selectors (in reverse order!) to the term. + , envC :: Map C.Name C.Schema -- ^ Cryptol type environment + , envS :: [Term] -- ^ SAW-Core bound variable environment (for type checking) + , envRefPrims :: Map C.PrimIdent C.Expr + } + +emptyEnv :: Env +emptyEnv = Env Map.empty Map.empty Map.empty Map.empty [] Map.empty + +liftTerm :: (Term, Int) -> (Term, Int) +liftTerm (t, j) = (t, j + 1) + +liftProp :: (Term, [FieldName], Int) -> (Term, [FieldName], Int) +liftProp (t, fns, j) = (t, fns, j + 1) + +-- | Increment dangling bound variables of all types in environment. +liftEnv :: Env -> Env +liftEnv env = + Env { envT = fmap liftTerm (envT env) + , envE = fmap liftTerm (envE env) + , envP = fmap liftProp (envP env) + , envC = envC env + , envS = envS env + , envRefPrims = envRefPrims env + } + +bindTParam :: SharedContext -> C.TParam -> Env -> IO Env +bindTParam sc tp env = do + let env' = liftEnv env + v <- scLocalVar sc 0 + k <- importKind sc (C.tpKind tp) + return $ env' { envT = Map.insert (C.tpUnique tp) (v, 0) (envT env') + , envS = k : envS env } + +bindName :: SharedContext -> C.Name -> C.Schema -> Env -> IO Env +bindName sc name schema env = do + let env' = liftEnv env + v <- scLocalVar sc 0 + t <- importSchema sc env schema + return $ env' { envE = Map.insert name (v, 0) (envE env') + , envC = Map.insert name schema (envC env') + , envS = t : envS env' } + +bindProp :: SharedContext -> C.Prop -> Env -> IO Env +bindProp sc prop env = do + let env' = liftEnv env + v <- scLocalVar sc 0 + k <- scSort sc (mkSort 0) + return $ env' { envP = insertSupers prop [] v (envP env') + , envS = k : envS env' + } + +-- | When we insert a nonerasable prop into the environment, make +-- sure to also insert all its superclasses. We arrange it so +-- that every class dictionary contains the implementation of its +-- superclass dictionaries, which can be extracted via field projections. +insertSupers :: + C.Prop -> + [FieldName] {- Field names to project the associated class (in reverse order) -} -> + Term -> + Map C.Prop (Term, [FieldName], Int) -> + Map C.Prop (Term, [FieldName], Int) +insertSupers prop fs v m + -- If the prop is already in the map, stop + | Just _ <- Map.lookup prop m = m + + -- Insert the prop and check if it has any superclasses that also need to be added + | otherwise = Map.insert (normalizeProp prop) (v, fs, 0) $ go prop + + where + super p f t = insertSupers (C.TCon (C.PC p) [t]) (f:fs) v + + go (C.TCon (C.PC p) [t]) = + case p of + C.PRing -> super C.PZero "ringZero" t m + C.PLogic -> super C.PZero "logicZero" t m + C.PField -> super C.PRing "fieldRing" t m + C.PIntegral -> super C.PRing "integralRing" t m + C.PRound -> super C.PField "roundField" t . super C.PCmp "roundCmp" t $ m + C.PCmp -> super C.PEq "cmpEq" t m + C.PSignedCmp -> super C.PEq "signedCmpEq" t m + _ -> m + go _ = m + + +-- | We normalize the first argument of 'Literal' class constraints +-- arbitrarily to 'inf', so that we can ignore that parameter when +-- matching dictionaries. +normalizeProp :: C.Prop -> C.Prop +normalizeProp prop + | Just (_, a) <- C.pIsLiteral prop = C.pLiteral C.tInf a + | Just (_, a) <- C.pIsLiteralLessThan prop = C.pLiteralLessThan C.tInf a + | otherwise = prop + +-------------------------------------------------------------------------------- + +importKind :: SharedContext -> C.Kind -> IO Term +importKind sc kind = + case kind of + C.KType -> scSort sc (mkSort 0) + C.KNum -> scDataTypeApp sc "Cryptol.Num" [] + C.KProp -> scSort sc (mkSort 0) + (C.:->) k1 k2 -> join $ scFun sc <$> importKind sc k1 <*> importKind sc k2 + +importTFun :: SharedContext -> C.TFun -> IO Term +importTFun sc tf = + case tf of + C.TCWidth -> scGlobalDef sc "Cryptol.tcWidth" + C.TCAdd -> scGlobalDef sc "Cryptol.tcAdd" + C.TCSub -> scGlobalDef sc "Cryptol.tcSub" + C.TCMul -> scGlobalDef sc "Cryptol.tcMul" + C.TCDiv -> scGlobalDef sc "Cryptol.tcDiv" + C.TCMod -> scGlobalDef sc "Cryptol.tcMod" + C.TCExp -> scGlobalDef sc "Cryptol.tcExp" + C.TCMin -> scGlobalDef sc "Cryptol.tcMin" + C.TCMax -> scGlobalDef sc "Cryptol.tcMax" + C.TCCeilDiv -> scGlobalDef sc "Cryptol.tcCeilDiv" + C.TCCeilMod -> scGlobalDef sc "Cryptol.tcCeilMod" + C.TCLenFromThenTo -> scGlobalDef sc "Cryptol.tcLenFromThenTo" + +-- | Precondition: @not ('isErasedProp' pc)@. +importPC :: SharedContext -> C.PC -> IO Term +importPC sc pc = + case pc of + C.PEqual -> panic "importPC PEqual" [] + C.PNeq -> panic "importPC PNeq" [] + C.PGeq -> panic "importPC PGeq" [] + C.PFin -> panic "importPC PFin" [] + C.PHas _ -> panic "importPC PHas" [] + C.PPrime -> panic "importPC PPrime" [] + C.PZero -> scGlobalDef sc "Cryptol.PZero" + C.PLogic -> scGlobalDef sc "Cryptol.PLogic" + C.PRing -> scGlobalDef sc "Cryptol.PRing" + C.PIntegral -> scGlobalDef sc "Cryptol.PIntegral" + C.PField -> scGlobalDef sc "Cryptol.PField" + C.PRound -> scGlobalDef sc "Cryptol.PRound" + C.PEq -> scGlobalDef sc "Cryptol.PEq" + C.PCmp -> scGlobalDef sc "Cryptol.PCmp" + C.PSignedCmp -> scGlobalDef sc "Cryptol.PSignedCmp" + C.PLiteral -> scGlobalDef sc "Cryptol.PLiteral" + C.PLiteralLessThan -> scGlobalDef sc "Cryptol.PLiteralLessThan" + C.PAnd -> panic "importPC PAnd" [] + C.PTrue -> panic "importPC PTrue" [] + C.PFLiteral -> panic "importPC PFLiteral" [] + C.PValidFloat -> panic "importPC PValidFloat" [] + +-- | Translate size types to SAW values of type Num, value types to SAW types of sort 0. +importType :: SharedContext -> Env -> C.Type -> IO Term +importType sc env ty = + case ty of + C.TVar tvar -> + case tvar of + C.TVFree{} {- Int Kind (Set TVar) Doc -} -> unimplemented "TVFree" + C.TVBound v -> case Map.lookup (C.tpUnique v) (envT env) of + Just (t, j) -> incVars sc 0 j t + Nothing -> panic "importType TVBound" [] + C.TUser _ _ t -> go t + C.TRec fm -> + importType sc env (C.tTuple (map snd (C.canonicalFields fm))) + + C.TNewtype nt ts -> + do let s = C.listSubst (zip (map C.TVBound (C.ntParams nt)) ts) + let t = plainSubst s (C.TRec (C.ntFields nt)) + go t + + C.TCon tcon tyargs -> + case tcon of + C.TC tc -> + case tc of + C.TCNum n -> scCtorApp sc "Cryptol.TCNum" =<< sequence [scNat sc (fromInteger n)] + C.TCInf -> scCtorApp sc "Cryptol.TCInf" [] + C.TCBit -> scBoolType sc + C.TCInteger -> scIntegerType sc + C.TCIntMod -> scGlobalApply sc "Cryptol.IntModNum" =<< traverse go tyargs + C.TCFloat -> scGlobalApply sc "Cryptol.TCFloat" =<< traverse go tyargs + C.TCArray -> do a <- go (tyargs !! 0) + b <- go (tyargs !! 1) + scArrayType sc a b + C.TCRational -> scGlobalApply sc "Cryptol.Rational" [] + C.TCSeq -> scGlobalApply sc "Cryptol.seq" =<< traverse go tyargs + C.TCFun -> do a <- go (tyargs !! 0) + b <- go (tyargs !! 1) + scFun sc a b + C.TCTuple _n -> scTupleType sc =<< traverse go tyargs + C.TCAbstract{} -> panic "importType TODO: abstract type" [] + C.PC pc -> + case pc of + C.PLiteral -> -- we omit first argument to class Literal + do a <- go (tyargs !! 1) + scGlobalApply sc "Cryptol.PLiteral" [a] + C.PLiteralLessThan -> -- we omit first argument to class LiteralLessThan + do a <- go (tyargs !! 1) + scGlobalApply sc "Cryptol.PLiteralLessThan" [a] + _ -> + do pc' <- importPC sc pc + tyargs' <- traverse go tyargs + scApplyAll sc pc' tyargs' + C.TF tf -> + do tf' <- importTFun sc tf + tyargs' <- traverse go tyargs + scApplyAll sc tf' tyargs' + C.TError _k -> + panic "importType TError" [] + where + go = importType sc env + +isErasedProp :: C.Prop -> Bool +isErasedProp prop = + case prop of + C.TCon (C.PC C.PZero ) _ -> False + C.TCon (C.PC C.PLogic ) _ -> False + C.TCon (C.PC C.PRing ) _ -> False + C.TCon (C.PC C.PIntegral ) _ -> False + C.TCon (C.PC C.PField ) _ -> False + C.TCon (C.PC C.PRound ) _ -> False + C.TCon (C.PC C.PEq ) _ -> False + C.TCon (C.PC C.PCmp ) _ -> False + C.TCon (C.PC C.PSignedCmp ) _ -> False + C.TCon (C.PC C.PLiteral ) _ -> False + C.TCon (C.PC C.PLiteralLessThan) _ -> False + _ -> True + +importPropsType :: SharedContext -> Env -> [C.Prop] -> C.Type -> IO Term +importPropsType sc env [] ty = importType sc env ty +importPropsType sc env (prop : props) ty + | isErasedProp prop = importPropsType sc env props ty + | otherwise = + do p <- importType sc env prop + t <- importPropsType sc env props ty + scFun sc p t + +nameToLocalName :: C.Name -> LocalName +nameToLocalName = C.identText . C.nameIdent + +nameToFieldName :: C.Name -> FieldName +nameToFieldName = C.identText . C.nameIdent + +tparamToLocalName :: C.TParam -> LocalName +tparamToLocalName tp = maybe (Text.pack ("u" ++ show (C.tpUnique tp))) nameToLocalName (C.tpName tp) + +importPolyType :: SharedContext -> Env -> [C.TParam] -> [C.Prop] -> C.Type -> IO Term +importPolyType sc env [] props ty = importPropsType sc env props ty +importPolyType sc env (tp : tps) props ty = + do k <- importKind sc (C.tpKind tp) + env' <- bindTParam sc tp env + t <- importPolyType sc env' tps props ty + scPi sc (tparamToLocalName tp) k t + +importSchema :: SharedContext -> Env -> C.Schema -> IO Term +importSchema sc env (C.Forall tparams props ty) = importPolyType sc env tparams props ty + +proveProp :: HasCallStack => SharedContext -> Env -> C.Prop -> IO Term +proveProp sc env prop = + case Map.lookup (normalizeProp prop) (envP env) of + + -- Class dictionary was provided as an argument + Just (prf, fs, j) -> + do -- shift deBruijn indicies by j + v <- incVars sc 0 j prf + -- apply field projections as necessary to compute superclasses + -- NB: reverse the order of the fields + foldM (scRecordSelect sc) v (reverse fs) + + -- Class dictionary not provided, compute it from the structure of types + Nothing -> + case prop of + -- instance Zero Bit + (C.pIsZero -> Just (C.tIsBit -> True)) + -> do scGlobalApply sc "Cryptol.PZeroBit" [] + -- instance Zero Integer + (C.pIsZero -> Just (C.tIsInteger -> True)) + -> do scGlobalApply sc "Cryptol.PZeroInteger" [] + -- instance Zero (Z n) + (C.pIsZero -> Just (C.tIsIntMod -> Just n)) + -> do n' <- importType sc env n + scGlobalApply sc "Cryptol.PZeroIntModNum" [n'] + -- instance Zero Rational + (C.pIsZero -> Just (C.tIsRational -> True)) + -> do scGlobalApply sc "Cryptol.PZeroRational" [] + -- instance Zero [n] + (C.pIsZero -> Just (C.tIsSeq -> Just (n, C.tIsBit -> True))) + -> do n' <- importType sc env n + scGlobalApply sc "Cryptol.PZeroSeqBool" [n'] + -- instance ValidFloat e p => Zero (Float e p) + (C.pIsZero -> Just (C.tIsFloat -> Just (e, p))) + -> do e' <- importType sc env e + p' <- importType sc env p + scGlobalApply sc "Cryptol.PZeroFloat" [e', p'] + -- instance (Zero a) => Zero [n]a + (C.pIsZero -> Just (C.tIsSeq -> Just (n, a))) + -> do n' <- importType sc env n + a' <- importType sc env a + pa <- proveProp sc env (C.pZero a) + scGlobalApply sc "Cryptol.PZeroSeq" [n', a', pa] + -- instance (Zero b) => Zero (a -> b) + (C.pIsZero -> Just (C.tIsFun -> Just (a, b))) + -> do a' <- importType sc env a + b' <- importType sc env b + pb <- proveProp sc env (C.pZero b) + scGlobalApply sc "Cryptol.PZeroFun" [a', b', pb] + -- instance (Zero a, Zero b, ...) => Zero (a, b, ...) + (C.pIsZero -> Just (C.tIsTuple -> Just ts)) + -> do ps <- traverse (proveProp sc env . C.pZero) ts + scTuple sc ps + -- instance (Zero a, Zero b, ...) => Zero { x : a, y : b, ... } + (C.pIsZero -> Just (C.tIsRec -> Just fm)) + -> do proveProp sc env (C.pZero (C.tTuple (map snd (C.canonicalFields fm)))) + + -- instance Logic Bit + (C.pIsLogic -> Just (C.tIsBit -> True)) + -> do scGlobalApply sc "Cryptol.PLogicBit" [] + -- instance Logic [n] + (C.pIsLogic -> Just (C.tIsSeq -> Just (n, C.tIsBit -> True))) + -> do n' <- importType sc env n + scGlobalApply sc "Cryptol.PLogicSeqBool" [n'] + -- instance (Logic a) => Logic [n]a + (C.pIsLogic -> Just (C.tIsSeq -> Just (n, a))) + -> do n' <- importType sc env n + a' <- importType sc env a + pa <- proveProp sc env (C.pLogic a) + scGlobalApply sc "Cryptol.PLogicSeq" [n', a', pa] + -- instance (Logic b) => Logic (a -> b) + (C.pIsLogic -> Just (C.tIsFun -> Just (a, b))) + -> do a' <- importType sc env a + b' <- importType sc env b + pb <- proveProp sc env (C.pLogic b) + scGlobalApply sc "Cryptol.PLogicFun" [a', b', pb] + -- instance Logic () + (C.pIsLogic -> Just (C.tIsTuple -> Just [])) + -> do scGlobalApply sc "Cryptol.PLogicUnit" [] + -- instance (Logic a, Logic b) => Logic (a, b) + (C.pIsLogic -> Just (C.tIsTuple -> Just [t])) + -> do proveProp sc env (C.pLogic t) + (C.pIsLogic -> Just (C.tIsTuple -> Just (t : ts))) + -> do a <- importType sc env t + b <- importType sc env (C.tTuple ts) + pa <- proveProp sc env (C.pLogic t) + pb <- proveProp sc env (C.pLogic (C.tTuple ts)) + scGlobalApply sc "Cryptol.PLogicPair" [a, b, pa, pb] + -- instance (Logic a, Logic b, ...) => instance Logic { x : a, y : b, ... } + (C.pIsLogic -> Just (C.tIsRec -> Just fm)) + -> do proveProp sc env (C.pLogic (C.tTuple (map snd (C.canonicalFields fm)))) + + -- instance Ring Integer + (C.pIsRing -> Just (C.tIsInteger -> True)) + -> do scGlobalApply sc "Cryptol.PRingInteger" [] + -- instance Ring (Z n) + (C.pIsRing -> Just (C.tIsIntMod -> Just n)) + -> do n' <- importType sc env n + scGlobalApply sc "Cryptol.PRingIntModNum" [n'] + -- instance Ring Rational + (C.pIsRing -> Just (C.tIsRational -> True)) + -> do scGlobalApply sc "Cryptol.PRingRational" [] + -- instance (fin n) => Ring [n] + (C.pIsRing -> Just (C.tIsSeq -> Just (n, C.tIsBit -> True))) + -> do n' <- importType sc env n + scGlobalApply sc "Cryptol.PRingSeqBool" [n'] + -- instance ValidFloat e p => Ring (Float e p) + (C.pIsRing -> Just (C.tIsFloat -> Just (e, p))) + -> do e' <- importType sc env e + p' <- importType sc env p + scGlobalApply sc "Cryptol.PRingFloat" [e', p'] + -- instance (Ring a) => Ring [n]a + (C.pIsRing -> Just (C.tIsSeq -> Just (n, a))) + -> do n' <- importType sc env n + a' <- importType sc env a + pa <- proveProp sc env (C.pRing a) + scGlobalApply sc "Cryptol.PRingSeq" [n', a', pa] + -- instance (Ring b) => Ring (a -> b) + (C.pIsRing -> Just (C.tIsFun -> Just (a, b))) + -> do a' <- importType sc env a + b' <- importType sc env b + pb <- proveProp sc env (C.pRing b) + scGlobalApply sc "Cryptol.PRingFun" [a', b', pb] + -- instance Ring () + (C.pIsRing -> Just (C.tIsTuple -> Just [])) + -> do scGlobalApply sc "Cryptol.PRingUnit" [] + -- instance (Ring a, Ring b) => Ring (a, b) + (C.pIsRing -> Just (C.tIsTuple -> Just [t])) + -> do proveProp sc env (C.pRing t) + (C.pIsRing -> Just (C.tIsTuple -> Just (t : ts))) + -> do a <- importType sc env t + b <- importType sc env (C.tTuple ts) + pa <- proveProp sc env (C.pRing t) + pb <- proveProp sc env (C.pRing (C.tTuple ts)) + scGlobalApply sc "Cryptol.PRingPair" [a, b, pa, pb] + -- instance (Ring a, Ring b, ...) => instance Ring { x : a, y : b, ... } + (C.pIsRing -> Just (C.tIsRec -> Just fm)) + -> do proveProp sc env (C.pRing (C.tTuple (map snd (C.canonicalFields fm)))) + + -- instance Integral Integer + (C.pIsIntegral -> Just (C.tIsInteger -> True)) + -> do scGlobalApply sc "Cryptol.PIntegralInteger" [] + -- instance Integral [n] + (C.pIsIntegral -> Just (C.tIsSeq -> (Just (n, C.tIsBit -> True)))) + -> do n' <- importType sc env n + scGlobalApply sc "Cryptol.PIntegralSeqBool" [n'] + + -- instance Field Rational + (C.pIsField -> Just (C.tIsRational -> True)) + -> do scGlobalApply sc "Cryptol.PFieldRational" [] + -- instance (prime p) => Field (Z p) + (C.pIsField -> Just (C.tIsIntMod -> Just n)) + -> do n' <- importType sc env n + scGlobalApply sc "Cryptol.PFieldIntModNum" [n'] + -- instance (ValidFloat e p) => Field (Float e p) + (C.pIsField -> Just (C.tIsFloat -> Just (e, p))) + -> do e' <- importType sc env e + p' <- importType sc env p + scGlobalApply sc "Cryptol.PFieldFloat" [e', p'] + + -- instance Round Rational + (C.pIsRound -> Just (C.tIsRational -> True)) + -> do scGlobalApply sc "Cryptol.PRoundRational" [] + -- instance (ValidFloat e p) => Round (Float e p) + (C.pIsRound -> Just (C.tIsFloat -> Just (e, p))) + -> do e' <- importType sc env e + p' <- importType sc env p + scGlobalApply sc "Cryptol.PRoundFloat" [e', p'] + + -- instance Eq Bit + (C.pIsEq -> Just (C.tIsBit -> True)) + -> do scGlobalApply sc "Cryptol.PEqBit" [] + -- instance Eq Integer + (C.pIsEq -> Just (C.tIsInteger -> True)) + -> do scGlobalApply sc "Cryptol.PEqInteger" [] + -- instance Eq (Z n) + (C.pIsEq -> Just (C.tIsIntMod -> Just n)) + -> do n' <- importType sc env n + scGlobalApply sc "Cryptol.PEqIntModNum" [n'] + -- instance Eq Rational + (C.pIsEq -> Just (C.tIsRational -> True)) + -> do scGlobalApply sc "Cryptol.PEqRational" [] + -- instance Eq (Float e p) + (C.pIsEq -> Just (C.tIsFloat -> Just (e, p))) + -> do e' <- importType sc env e + p' <- importType sc env p + scGlobalApply sc "Cryptol.PEqFloat" [e', p'] + -- instance (fin n) => Eq [n] + (C.pIsEq -> Just (C.tIsSeq -> Just (n, C.tIsBit -> True))) + -> do n' <- importType sc env n + scGlobalApply sc "Cryptol.PEqSeqBool" [n'] + -- instance (fin n, Eq a) => Eq [n]a + (C.pIsEq -> Just (C.tIsSeq -> Just (n, a))) + -> do n' <- importType sc env n + a' <- importType sc env a + pa <- proveProp sc env (C.pEq a) + scGlobalApply sc "Cryptol.PEqSeq" [n', a', pa] + -- instance Eq () + (C.pIsEq -> Just (C.tIsTuple -> Just [])) + -> do scGlobalApply sc "Cryptol.PEqUnit" [] + -- instance (Eq a, Eq b) => Eq (a, b) + (C.pIsEq -> Just (C.tIsTuple -> Just [t])) + -> do proveProp sc env (C.pEq t) + (C.pIsEq -> Just (C.tIsTuple -> Just (t : ts))) + -> do a <- importType sc env t + b <- importType sc env (C.tTuple ts) + pa <- proveProp sc env (C.pEq t) + pb <- proveProp sc env (C.pEq (C.tTuple ts)) + scGlobalApply sc "Cryptol.PEqPair" [a, b, pa, pb] + -- instance (Eq a, Eq b, ...) => instance Eq { x : a, y : b, ... } + (C.pIsEq -> Just (C.tIsRec -> Just fm)) + -> do proveProp sc env (C.pEq (C.tTuple (map snd (C.canonicalFields fm)))) + + -- instance Cmp Bit + (C.pIsCmp -> Just (C.tIsBit -> True)) + -> do scGlobalApply sc "Cryptol.PCmpBit" [] + -- instance Cmp Integer + (C.pIsCmp -> Just (C.tIsInteger -> True)) + -> do scGlobalApply sc "Cryptol.PCmpInteger" [] + -- instance Cmp Rational + (C.pIsCmp -> Just (C.tIsRational -> True)) + -> do scGlobalApply sc "Cryptol.PCmpRational" [] + -- instance Cmp (Float e p) + (C.pIsCmp -> Just (C.tIsFloat -> Just (e, p))) + -> do e' <- importType sc env e + p' <- importType sc env p + scGlobalApply sc "Cryptol.PCmpFloat" [e', p'] + -- instance (fin n) => Cmp [n] + (C.pIsCmp -> Just (C.tIsSeq -> Just (n, C.tIsBit -> True))) + -> do n' <- importType sc env n + scGlobalApply sc "Cryptol.PCmpSeqBool" [n'] + -- instance (fin n, Cmp a) => Cmp [n]a + (C.pIsCmp -> Just (C.tIsSeq -> Just (n, a))) + -> do n' <- importType sc env n + a' <- importType sc env a + pa <- proveProp sc env (C.pCmp a) + scGlobalApply sc "Cryptol.PCmpSeq" [n', a', pa] + -- instance Cmp () + (C.pIsCmp -> Just (C.tIsTuple -> Just [])) + -> do scGlobalApply sc "Cryptol.PCmpUnit" [] + -- instance (Cmp a, Cmp b) => Cmp (a, b) + (C.pIsCmp -> Just (C.tIsTuple -> Just [t])) + -> do proveProp sc env (C.pCmp t) + (C.pIsCmp -> Just (C.tIsTuple -> Just (t : ts))) + -> do a <- importType sc env t + b <- importType sc env (C.tTuple ts) + pa <- proveProp sc env (C.pCmp t) + pb <- proveProp sc env (C.pCmp (C.tTuple ts)) + scGlobalApply sc "Cryptol.PCmpPair" [a, b, pa, pb] + -- instance (Cmp a, Cmp b, ...) => instance Cmp { x : a, y : b, ... } + (C.pIsCmp -> Just (C.tIsRec -> Just fm)) + -> do proveProp sc env (C.pCmp (C.tTuple (map snd (C.canonicalFields fm)))) + + -- instance (fin n) => SignedCmp [n] + (C.pIsSignedCmp -> Just (C.tIsSeq -> Just (n, C.tIsBit -> True))) + -> do n' <- importType sc env n + scGlobalApply sc "Cryptol.PSignedCmpSeqBool" [n'] + -- instance (fin n, SignedCmp a) => SignedCmp [n]a + (C.pIsSignedCmp -> Just (C.tIsSeq -> Just (n, a))) + -> do n' <- importType sc env n + a' <- importType sc env a + pa <- proveProp sc env (C.pSignedCmp a) + scGlobalApply sc "Cryptol.PSignedCmpSeq" [n', a', pa] + -- instance SignedCmp () + (C.pIsSignedCmp -> Just (C.tIsTuple -> Just [])) + -> do scGlobalApply sc "Cryptol.PSignedCmpUnit" [] + -- instance (SignedCmp a, SignedCmp b) => SignedCmp (a, b) + (C.pIsSignedCmp -> Just (C.tIsTuple -> Just [t])) + -> do proveProp sc env (C.pSignedCmp t) + (C.pIsSignedCmp -> Just (C.tIsTuple -> Just (t : ts))) + -> do a <- importType sc env t + b <- importType sc env (C.tTuple ts) + pa <- proveProp sc env (C.pSignedCmp t) + pb <- proveProp sc env (C.pSignedCmp (C.tTuple ts)) + scGlobalApply sc "Cryptol.PSignedCmpPair" [a, b, pa, pb] + -- instance (SignedCmp a, SignedCmp b, ...) => instance SignedCmp { x : a, y : b, ... } + (C.pIsSignedCmp -> Just (C.tIsRec -> Just fm)) + -> do proveProp sc env (C.pSignedCmp (C.tTuple (map snd (C.canonicalFields fm)))) + + -- instance Literal val Bit + (C.pIsLiteral -> Just (_, C.tIsBit -> True)) + -> do scGlobalApply sc "Cryptol.PLiteralBit" [] + -- instance Literal val Integer + (C.pIsLiteral -> Just (_, C.tIsInteger -> True)) + -> do scGlobalApply sc "Cryptol.PLiteralInteger" [] + -- instance Literal val (Z n) + (C.pIsLiteral -> Just (_, C.tIsIntMod -> Just n)) + -> do n' <- importType sc env n + scGlobalApply sc "Cryptol.PLiteralIntModNum" [n'] + -- instance Literal val Rational + (C.pIsLiteral -> Just (_, C.tIsRational -> True)) + -> do scGlobalApply sc "Cryptol.PLiteralRational" [] + -- instance (fin n, n >= width val) => Literal val [n] + (C.pIsLiteral -> Just (_, C.tIsSeq -> Just (n, C.tIsBit -> True))) + -> do n' <- importType sc env n + scGlobalApply sc "Cryptol.PLiteralSeqBool" [n'] + -- instance ValidFloat e p => Literal val (Float e p) (with extra constraints) + (C.pIsLiteral -> Just (_, C.tIsFloat -> Just (e, p))) + -> do e' <- importType sc env e + p' <- importType sc env p + scGlobalApply sc "Cryptol.PLiteralFloat" [e', p'] + + -- instance (2 >= val) => LiteralLessThan val Bit + (C.pIsLiteralLessThan -> Just (_, C.tIsBit -> True)) + -> do scGlobalApply sc "Cryptol.PLiteralBit" [] + -- instance LiteralLessThan val Integer + (C.pIsLiteralLessThan -> Just (_, C.tIsInteger -> True)) + -> do scGlobalApply sc "Cryptol.PLiteralInteger" [] + -- instance (fin n, n >= 1, n >= val) LiteralLessThan val (Z n) + (C.pIsLiteralLessThan -> Just (_, C.tIsIntMod -> Just n)) + -> do n' <- importType sc env n + scGlobalApply sc "Cryptol.PLiteralIntModNum" [n'] + -- instance Literal val Rational + (C.pIsLiteralLessThan -> Just (_, C.tIsRational -> True)) + -> do scGlobalApply sc "Cryptol.PLiteralRational" [] + -- instance (fin n, n >= lg2 val) => Literal val [n] + (C.pIsLiteralLessThan -> Just (_, C.tIsSeq -> Just (n, C.tIsBit -> True))) + -> do n' <- importType sc env n + scGlobalApply sc "Cryptol.PLiteralSeqBool" [n'] + -- instance ValidFloat e p => Literal val (Float e p) (with extra constraints) + (C.pIsLiteralLessThan -> Just (_, C.tIsFloat -> Just (e, p))) + -> do e' <- importType sc env e + p' <- importType sc env p + scGlobalApply sc "Cryptol.PLiteralFloat" [e', p'] + + _ -> do panic "proveProp" [pretty prop] + +importPrimitive :: SharedContext -> Env -> C.Name -> C.Schema -> IO Term +importPrimitive sc env n sch + | Just nm <- C.asPrim n, Just term <- Map.lookup nm (prelPrims <> arrayPrims <> floatPrims) = term sc + | Just nm <- C.asPrim n, Just expr <- Map.lookup nm (envRefPrims env) = + do t <- importSchema sc env sch + e <- importExpr sc env expr + nmi <- importName n + scConstant' sc nmi e t + | Just nm <- C.asPrim n = panic "Unknown Cryptol primitive name" [show nm] + | otherwise = panic "Improper Cryptol primitive name" [show n] + +prelPrims :: Map C.PrimIdent (SharedContext -> IO Term) +prelPrims = + Map.fromList $ + first C.prelPrim <$> + [ ("True", flip scBool True) + , ("False", flip scBool False) + , ("number", flip scGlobalDef "Cryptol.ecNumber") -- Converts a numeric type into its corresponding value. + -- -- {val, a} (Literal val a) => a + + , ("fromZ", flip scGlobalDef "Cryptol.ecFromZ") -- {n} (fin n, n >= 1) => Z n -> Integer + + -- -- Zero + , ("zero", flip scGlobalDef "Cryptol.ecZero") -- {a} (Zero a) => a + + -- -- Logic + , ("&&", flip scGlobalDef "Cryptol.ecAnd") -- {a} (Logic a) => a -> a -> a + , ("||", flip scGlobalDef "Cryptol.ecOr") -- {a} (Logic a) => a -> a -> a + , ("^", flip scGlobalDef "Cryptol.ecXor") -- {a} (Logic a) => a -> a -> a + , ("complement", flip scGlobalDef "Cryptol.ecCompl") -- {a} (Logic a) => a -> a + + -- -- Ring + , ("fromInteger", flip scGlobalDef "Cryptol.ecFromInteger") -- {a} (Ring a) => Integer -> a + , ("+", flip scGlobalDef "Cryptol.ecPlus") -- {a} (Ring a) => a -> a -> a + , ("-", flip scGlobalDef "Cryptol.ecMinus") -- {a} (Ring a) => a -> a -> a + , ("*", flip scGlobalDef "Cryptol.ecMul") -- {a} (Ring a) => a -> a -> a + , ("negate", flip scGlobalDef "Cryptol.ecNeg") -- {a} (Ring a) => a -> a + + -- -- Integral + , ("toInteger", flip scGlobalDef "Cryptol.ecToInteger") -- {a} (Integral a) => a -> Integer + , ("/", flip scGlobalDef "Cryptol.ecDiv") -- {a} (Integral a) => a -> a -> a + , ("%", flip scGlobalDef "Cryptol.ecMod") -- {a} (Integral a) => a -> a -> a + , ("^^", flip scGlobalDef "Cryptol.ecExp") -- {a} (Ring a, Integral b) => a -> b -> a + , ("infFrom", flip scGlobalDef "Cryptol.ecInfFrom") -- {a} (Integral a) => a -> [inf]a + , ("infFromThen", flip scGlobalDef "Cryptol.ecInfFromThen") -- {a} (Integral a) => a -> a -> [inf]a + + -- -- Field + , ("recip", flip scGlobalDef "Cryptol.ecRecip") -- {a} (Field a) => a -> a + , ("/.", flip scGlobalDef "Cryptol.ecFieldDiv") -- {a} (Field a) => a -> a -> a + + -- -- Round + , ("ceiling", flip scGlobalDef "Cryptol.ecCeiling") -- {a} (Round a) => a -> Integer + , ("floor", flip scGlobalDef "Cryptol.ecFloor") -- {a} (Round a) => a -> Integer + , ("trunc", flip scGlobalDef "Cryptol.ecTruncate") -- {a} (Round a) => a -> Integer + , ("roundAway", flip scGlobalDef "Cryptol.ecRoundAway") -- {a} (Round a) => a -> Integer + , ("roundToEven", flip scGlobalDef "Cryptol.ecRoundToEven") -- {a} (Round a) => a -> Integer + + -- -- Eq + , ("==", flip scGlobalDef "Cryptol.ecEq") -- {a} (Eq a) => a -> a -> Bit + , ("!=", flip scGlobalDef "Cryptol.ecNotEq") -- {a} (Eq a) => a -> a -> Bit + + -- -- Cmp + , ("<", flip scGlobalDef "Cryptol.ecLt") -- {a} (Cmp a) => a -> a -> Bit + , (">", flip scGlobalDef "Cryptol.ecGt") -- {a} (Cmp a) => a -> a -> Bit + , ("<=", flip scGlobalDef "Cryptol.ecLtEq") -- {a} (Cmp a) => a -> a -> Bit + , (">=", flip scGlobalDef "Cryptol.ecGtEq") -- {a} (Cmp a) => a -> a -> Bit + + -- -- SignedCmp + , ("<$", flip scGlobalDef "Cryptol.ecSLt") -- {a} (SignedCmp a) => a -> a -> Bit + + -- -- Bitvector primitives + , ("/$", flip scGlobalDef "Cryptol.ecSDiv") -- {n} (fin n, n>=1) => [n] -> [n] -> [n] + , ("%$", flip scGlobalDef "Cryptol.ecSMod") -- {n} (fin n, n>=1) => [n] -> [n] -> [n] + , ("lg2", flip scGlobalDef "Cryptol.ecLg2") -- {n} (fin n) => [n] -> [n] + , (">>$", flip scGlobalDef "Cryptol.ecSShiftR") -- {n, ix} (fin n, n >= 1, Integral ix) => [n] -> ix -> [n] + + -- -- Rational primitives + , ("ratio", flip scGlobalDef "Cryptol.ecRatio") -- Integer -> Integer -> Rational + + -- -- FLiteral + , ("fraction", flip scGlobalDef "Cryptol.ecFraction") -- {m, n, r, a} FLiteral m n r a => a + + -- -- Shifts/rotates + , ("<<", flip scGlobalDef "Cryptol.ecShiftL") -- {n, ix, a} (Integral ix, Zero a) => [n]a -> ix -> [n]a + , (">>", flip scGlobalDef "Cryptol.ecShiftR") -- {n, ix, a} (Integral ix, Zero a) => [n]a -> ix -> [n]a + , ("<<<", flip scGlobalDef "Cryptol.ecRotL") -- {n, ix, a} (fin n, Integral ix) => [n]a -> ix -> [n]a + , (">>>", flip scGlobalDef "Cryptol.ecRotR") -- {n, ix, a} (fin n, Integral ix) => [n]a -> ix -> [n]a + + -- -- Sequences primitives + , ("#", flip scGlobalDef "Cryptol.ecCat") -- {a,b,d} (fin a) => [a] d -> [b] d -> [a + b] d + , ("splitAt", flip scGlobalDef "Cryptol.ecSplitAt") -- {a,b,c} (fin a) => [a+b] c -> ([a]c,[b]c) + , ("join", flip scGlobalDef "Cryptol.ecJoin") -- {a,b,c} (fin b) => [a][b]c -> [a * b]c + , ("split", flip scGlobalDef "Cryptol.ecSplit") -- {a,b,c} (fin b) => [a * b] c -> [a][b] c + , ("reverse", flip scGlobalDef "Cryptol.ecReverse") -- {a,b} (fin a) => [a] b -> [a] b + , ("transpose", flip scGlobalDef "Cryptol.ecTranspose") -- {a,b,c} [a][b]c -> [b][a]c + , ("@", flip scGlobalDef "Cryptol.ecAt") -- {n, a, ix} (Integral ix) => [n]a -> ix -> a + , ("!", flip scGlobalDef "Cryptol.ecAtBack") -- {n, a, ix} (fin n, Integral ix) => [n]a -> ix -> a + , ("update", flip scGlobalDef "Cryptol.ecUpdate") -- {n, a, ix} (Integral ix) => [n]a -> ix -> a -> [n]a + , ("updateEnd", flip scGlobalDef "Cryptol.ecUpdateEnd") -- {n, a, ix} (fin n, Integral ix) => [n]a -> ix -> a -> [n]a + + -- -- Enumerations + , ("fromTo", flip scGlobalDef "Cryptol.ecFromTo") + -- -- fromTo : {first, last, bits, a} + -- -- ( fin last, fin bits, last >== first, + -- -- Literal first a, Literal last a) + -- -- => [1 + (last - first)]a + , ("fromToLessThan", flip scGlobalDef "Cryptol.ecFromToLessThan") + -- -- fromToLessThan : {first, bound, a} + -- -- ( fin first, bound >= first, + -- -- LiteralLessThan bound a) + -- -- => [bound - first]a + , ("fromThenTo", flip scGlobalDef "Cryptol.ecFromThenTo") + -- -- fromThenTo : {first, next, last, a, len} + -- -- ( fin first, fin next, fin last + -- -- , Literal first a, Literal next a, Literal last a + -- -- , first != next + -- -- , lengthFromThenTo first next last == len) => [len]a + + -- Evaluation primitives: deepseq, parmap + , ("deepseq", flip scGlobalDef "Cryptol.ecDeepseq") -- {a, b} (Eq b) => a -> b -> b + , ("parmap", flip scGlobalDef "Cryptol.ecParmap") -- {a, b, n} (Eq b, fin n) => (a -> b) -> [n]a -> [n]b + , ("foldl", flip scGlobalDef "Cryptol.ecFoldl") -- {n, a, b} (fin n) => (a -> b -> a) -> a -> [n]b -> a + , ("foldl'", flip scGlobalDef "Cryptol.ecFoldlPrime") -- {n, a, b} (fin n, Eq a) => (a -> b -> a) -> a -> [n]b -> a + + , ("error", flip scGlobalDef "Cryptol.ecError") -- {at,len} (fin len) => [len][8] -> at -- Run-time error + , ("random", flip scGlobalDef "Cryptol.ecRandom") -- {a} => [32] -> a -- Random values + , ("trace", flip scGlobalDef "Cryptol.ecTrace") -- {n,a,b} [n][8] -> a -> b -> b + ] + +arrayPrims :: Map C.PrimIdent (SharedContext -> IO Term) +arrayPrims = + Map.fromList $ + first C.arrayPrim <$> + [ ("arrayConstant", flip scGlobalDef "Cryptol.ecArrayConstant") -- {a,b} b -> Array a b + , ("arrayLookup", flip scGlobalDef "Cryptol.ecArrayLookup") -- {a,b} Array a b -> a -> b + , ("arrayUpdate", flip scGlobalDef "Cryptol.ecArrayUpdate") -- {a,b} Array a b -> a -> b -> Array a b + ] + +floatPrims :: Map C.PrimIdent (SharedContext -> IO Term) +floatPrims = + Map.fromList $ + first C.floatPrim <$> + [ ("fpNaN", flip scGlobalDef "Cryptol.ecFpNaN") + , ("fpPosInf", flip scGlobalDef "Cryptol.ecFpPosInf") + , ("fpFromBits", flip scGlobalDef "Cryptol.ecFpFromBits") + , ("fpToBits", flip scGlobalDef "Cryptol.ecFpToBits") + , ("=.=", flip scGlobalDef "Cryptol.ecFpEq") + , ("fpAdd", flip scGlobalDef "Cryptol.ecFpAdd") + , ("fpSub", flip scGlobalDef "Cryptol.ecFpSub") + , ("fpMul", flip scGlobalDef "Cryptol.ecFpMul") + , ("fpDiv", flip scGlobalDef "Cryptol.ecFpDiv") + , ("fpToRational", flip scGlobalDef "Cryptol.ecFpToRational") + , ("fpFromRational", flip scGlobalDef "Cryptol.ecFpFromRational") + , ("fpIsNaN", flip scGlobalDef "Cryptol.fpIsNaN") + , ("fpIsInf", flip scGlobalDef "Cryptol.fpIsInf") + , ("fpIsZero", flip scGlobalDef "Cryptol.fpIsZero") + , ("fpIsNeg", flip scGlobalDef "Cryptol.fpIsNeg") + , ("fpIsNormal", flip scGlobalDef "Cryptol.fpIsNormal") + , ("fpIsSubnormal", flip scGlobalDef "Cryptol.fpIsSubnormal") + , ("fpFMA", flip scGlobalDef "Cryptol.fpFMA") + , ("fpAbs", flip scGlobalDef "Cryptol.fpAbs") + , ("fpSqrt", flip scGlobalDef "Cryptol.fpSqrt") + ] + + +-- | Convert a Cryptol expression to a SAW-Core term. Calling +-- 'scTypeOf' on the result of @'importExpr' sc env expr@ must yield a +-- type that is equivalent (i.e. convertible) with the one returned by +-- @'importSchema' sc env ('fastTypeOf' ('envC' env) expr)@. +importExpr :: SharedContext -> Env -> C.Expr -> IO Term +importExpr sc env expr = + case expr of + C.EList es t -> + do t' <- importType sc env t + es' <- traverse (importExpr' sc env (C.tMono t)) es + scVector sc t' es' + + C.ETuple es -> + do es' <- traverse (importExpr sc env) es + scTuple sc es' + + C.ERec fm -> + do es' <- traverse (importExpr sc env . snd) (C.canonicalFields fm) + scTuple sc es' + + C.ESel e sel -> + -- Elimination for tuple/record/list + case sel of + C.TupleSel i _maybeLen -> + do e' <- importExpr sc env e + let t = fastTypeOf (envC env) e + case C.tIsTuple t of + Just ts -> + do scTupleSelector sc e' (i+1) (length ts) + Nothing -> + do f <- mapTupleSelector sc env i t + scApply sc f e' + C.RecordSel x _ -> + do e' <- importExpr sc env e + let t = fastTypeOf (envC env) e + case C.tIsRec t of + Just fm -> + do i <- the (elemIndex x (map fst (C.canonicalFields fm))) + scTupleSelector sc e' (i+1) (length (C.canonicalFields fm)) + Nothing -> + do f <- mapRecordSelector sc env x t + scApply sc f e' + C.ListSel i _maybeLen -> + do let t = fastTypeOf (envC env) e + (n, a) <- + case C.tIsSeq t of + Just (n, a) -> return (n, a) + Nothing -> panic "importExpr" ["ListSel: not a list type"] + a' <- importType sc env a + n' <- importType sc env n + e' <- importExpr sc env e + i' <- scNat sc (fromIntegral i) + scGlobalApply sc "Cryptol.eListSel" [a', n', e', i'] + + C.ESet _ e1 sel e2 -> + case sel of + C.TupleSel i _maybeLen -> + do e1' <- importExpr sc env e1 + e2' <- importExpr sc env e2 + let t1 = fastTypeOf (envC env) e1 + case C.tIsTuple t1 of + Nothing -> panic "importExpr" ["ESet/TupleSel: not a tuple type"] + Just ts -> + do ts' <- traverse (importType sc env) ts + let t2' = ts' !! i + f <- scGlobalApply sc "Cryptol.const" [t2', t2', e2'] + g <- tupleUpdate sc f i ts' + scApply sc g e1' + C.RecordSel x _ -> + do e1' <- importExpr sc env e1 + e2' <- importExpr sc env e2 + let t1 = fastTypeOf (envC env) e1 + case C.tIsRec t1 of + Nothing -> panic "importExpr" ["ESet/TupleSel: not a tuple type"] + Just tm -> + do i <- the (elemIndex x (map fst (C.canonicalFields tm))) + ts' <- traverse (importType sc env . snd) (C.canonicalFields tm) + let t2' = ts' !! i + f <- scGlobalApply sc "Cryptol.const" [t2', t2', e2'] + g <- tupleUpdate sc f i ts' + scApply sc g e1' + C.ListSel _i _maybeLen -> + panic "importExpr" ["ESet/ListSel: unsupported"] + + C.EIf e1 e2 e3 -> + do let ty = fastTypeOf (envC env) e2 + ty' <- importType sc env ty + e1' <- importExpr sc env e1 + e2' <- importExpr sc env e2 + e3' <- importExpr' sc env (C.tMono ty) e3 + scGlobalApply sc "Prelude.ite" [ty', e1', e2', e3'] + + C.EComp len eltty e mss -> + importComp sc env len eltty e mss + + C.EVar qname -> + case Map.lookup qname (envE env) of + Just (e', j) -> incVars sc 0 j e' + Nothing -> panic "importExpr" ["unknown variable: " ++ show qname] + + C.ETAbs tp e -> + do env' <- bindTParam sc tp env + k <- importKind sc (C.tpKind tp) + e' <- importExpr sc env' e + scLambda sc (tparamToLocalName tp) k e' + + C.ETApp e t -> + do e' <- importExpr sc env e + t' <- importType sc env t + scApply sc e' t' + + C.EApp e1 e2 -> + do e1' <- importExpr sc env e1 + let t1 = fastTypeOf (envC env) e1 + t1a <- + case C.tIsFun t1 of + Just (a, _) -> return a + Nothing -> panic "importExpr" ["expected function type"] + e2' <- importExpr' sc env (C.tMono t1a) e2 + scApply sc e1' e2' + + C.EAbs x t e -> + do t' <- importType sc env t + env' <- bindName sc x (C.tMono t) env + e' <- importExpr sc env' e + scLambda sc (nameToLocalName x) t' e' + + C.EProofAbs prop e + | isErasedProp prop -> importExpr sc env e + | otherwise -> + do p' <- importType sc env prop + env' <- bindProp sc prop env + e' <- importExpr sc env' e + scLambda sc "_P" p' e' + + C.EProofApp e -> + case fastSchemaOf (envC env) e of + C.Forall [] (p : _ps) _ty + | isErasedProp p -> importExpr sc env e + | otherwise -> + do e' <- importExpr sc env e + prf <- proveProp sc env p + scApply sc e' prf + s -> panic "importExpr" ["EProofApp: invalid type: " ++ show (e, s)] + + C.EWhere e dgs -> + do env' <- importDeclGroups sc env dgs + importExpr sc env' e + + C.ELocated _ e -> + importExpr sc env e + + where + the :: Maybe a -> IO a + the = maybe (panic "importExpr" ["internal type error"]) return + + +-- | Convert a Cryptol expression with the given type schema to a +-- SAW-Core term. Calling 'scTypeOf' on the result of @'importExpr'' +-- sc env schema expr@ must yield a type that is equivalent (i.e. +-- convertible) with the one returned by @'importSchema' sc env +-- schema@. +importExpr' :: SharedContext -> Env -> C.Schema -> C.Expr -> IO Term +importExpr' sc env schema expr = + case expr of + C.ETuple es -> + do ty <- the (C.isMono schema) + ts <- the (C.tIsTuple ty) + es' <- sequence (zipWith go ts es) + scTuple sc es' + + C.ERec fm -> + do ty <- the (C.isMono schema) + tm <- the (C.tIsRec ty) + es' <- sequence (zipWith go (map snd (C.canonicalFields tm)) (map snd (C.canonicalFields fm))) + scTuple sc es' + + C.EIf e1 e2 e3 -> + do ty <- the (C.isMono schema) + ty' <- importType sc env ty + e1' <- importExpr sc env e1 + e2' <- importExpr' sc env schema e2 + e3' <- importExpr' sc env schema e3 + scGlobalApply sc "Prelude.ite" [ty', e1', e2', e3'] + + C.ETAbs tp e -> + do schema' <- + case schema of + C.Forall (tp1 : tparams) props ty -> + let s = C.singleTParamSubst tp1 (C.TVar (C.TVBound tp)) + in return (C.Forall tparams (map (plainSubst s) props) (plainSubst s ty)) + C.Forall [] _ _ -> panic "importExpr'" ["internal error: unexpected type abstraction"] + env' <- bindTParam sc tp env + k <- importKind sc (C.tpKind tp) + e' <- importExpr' sc env' schema' e + scLambda sc (tparamToLocalName tp) k e' + + C.EAbs x _ e -> + do ty <- the (C.isMono schema) + (a, b) <- the (C.tIsFun ty) + a' <- importType sc env a + env' <- bindName sc x (C.tMono a) env + e' <- importExpr' sc env' (C.tMono b) e + scLambda sc (nameToLocalName x) a' e' + + C.EProofAbs _ e -> + do (prop, schema') <- + case schema of + C.Forall [] (p : ps) ty -> return (p, C.Forall [] ps ty) + C.Forall _ _ _ -> panic "importExpr" ["internal type error"] + if isErasedProp prop + then importExpr' sc env schema' e + else do p' <- importType sc env prop + env' <- bindProp sc prop env + e' <- importExpr' sc env' schema' e + scLambda sc "_P" p' e' + + C.EWhere e dgs -> + do env' <- importDeclGroups sc env dgs + importExpr' sc env' schema e + + C.ELocated _ e -> + importExpr' sc env schema e + + C.EList {} -> fallback + C.ESel {} -> fallback + C.ESet {} -> fallback + C.EComp {} -> fallback + C.EVar {} -> fallback + C.EApp {} -> fallback + C.ETApp {} -> fallback + C.EProofApp {} -> fallback + + where + go :: C.Type -> C.Expr -> IO Term + go t = importExpr' sc env (C.tMono t) + + the :: Maybe a -> IO a + the = maybe (panic "importExpr" ["internal type error"]) return + + fallback :: IO Term + fallback = + do let t1 = fastTypeOf (envC env) expr + t2 <- the (C.isMono schema) + expr' <- importExpr sc env expr + coerceTerm sc env t1 t2 expr' + +mapTupleSelector :: SharedContext -> Env -> Int -> C.Type -> IO Term +mapTupleSelector sc env i = fmap fst . go + where + go :: C.Type -> IO (Term, C.Type) + go t = + case C.tNoUser t of + (C.tIsSeq -> Just (n, a)) -> do + (f, b) <- go a + a' <- importType sc env a + b' <- importType sc env b + n' <- importType sc env n + g <- scGlobalApply sc "Cryptol.seqMap" [a', b', n', f] + return (g, C.tSeq n b) + (C.tIsFun -> Just (n, a)) -> do + (f, b) <- go a + a' <- importType sc env a + b' <- importType sc env b + n' <- importType sc env n + g <- scGlobalApply sc "Cryptol.compose" [n', a', b', f] + return (g, C.tFun n b) + (C.tIsTuple -> Just ts) -> do + x <- scLocalVar sc 0 + y <- scTupleSelector sc x (i+1) (length ts) + t' <- importType sc env t + f <- scLambda sc "x" t' y + return (f, ts !! i) + _ -> panic "importExpr" ["invalid tuple selector", show i, show t] + +mapRecordSelector :: SharedContext -> Env -> C.Ident -> C.Type -> IO Term +mapRecordSelector sc env i = fmap fst . go + where + go :: C.Type -> IO (Term, C.Type) + go t = + case C.tNoUser t of + (C.tIsSeq -> Just (n, a)) -> + do (f, b) <- go a + a' <- importType sc env a + b' <- importType sc env b + n' <- importType sc env n + g <- scGlobalApply sc "Cryptol.seqMap" [a', b', n', f] + return (g, C.tSeq n b) + (C.tIsFun -> Just (n, a)) -> + do (f, b) <- go a + a' <- importType sc env a + b' <- importType sc env b + n' <- importType sc env n + g <- scGlobalApply sc "Cryptol.compose" [n', a', b', f] + return (g, C.tFun n b) + (C.tIsRec -> Just tm) | Just k <- elemIndex i (map fst (C.canonicalFields tm)) -> + do x <- scLocalVar sc 0 + y <- scTupleSelector sc x (k+1) (length (C.canonicalFields tm)) + t' <- importType sc env t + f <- scLambda sc "x" t' y + return (f, snd (C.canonicalFields tm !! k)) + _ -> panic "importExpr" ["invalid record selector", show i, show t] + +tupleUpdate :: SharedContext -> Term -> Int -> [Term] -> IO Term +tupleUpdate _ f 0 [_] = return f +tupleUpdate sc f 0 (a : ts) = + do b <- scTupleType sc ts + scGlobalApply sc "Cryptol.updFst" [a, b, f] +tupleUpdate sc f n (a : ts) = + do g <- tupleUpdate sc f (n - 1) ts + b <- scTupleType sc ts + scGlobalApply sc "Cryptol.updSnd" [a, b, g] +tupleUpdate _ _ _ [] = panic "tupleUpdate" ["empty tuple"] + +-- | Apply a substitution to a type *without* simplifying +-- constraints like @Ring [n]a@ to @Ring a@. (This is in contrast to +-- 'apSubst', which performs simplifications wherever possible.) +plainSubst :: C.Subst -> C.Type -> C.Type +plainSubst s ty = + case ty of + C.TCon tc ts -> C.TCon tc (map (plainSubst s) ts) + C.TUser f ts t -> C.TUser f (map (plainSubst s) ts) (plainSubst s t) + C.TRec fs -> C.TRec (fmap (plainSubst s) fs) + C.TVar x -> C.apSubst s (C.TVar x) + C.TNewtype nt ts -> C.TNewtype nt (fmap (plainSubst s) ts) + + +-- | Generate a URI representing a cryptol name from a sequence of +-- name parts representing the fully-qualified name. If a \"unique\" +-- value is given, this represents a dynamically bound name in +-- the \"\\" pseudo-module, and the unique value will +-- be incorporated into the name as a fragment identifier. +-- At least one name component must be supplied. +-- +-- Some examples: +-- +-- * @Cryptol::foldl@ ---> @cryptol:\/Cryptol\/foldl@ +-- * @MyModule::SubModule::name@ ---> @cryptol:\/MyModule\/SubModule\/name@ +-- * @\::f@ ---> @cryptol:f#1234@ +-- +-- In the above example, 1234 is the unique integer value provided with the name. + +cryptolURI :: + [Text] {- ^ Name components -} -> + Maybe Int {- ^ unique integer for dynamic names -} -> + URI +cryptolURI [] _ = panic "cryptolURI" ["Could not make URI from empty path"] +cryptolURI (p:ps) Nothing = + fromMaybe (panic "cryptolURI" ["Could not make URI from the given path", show (p:ps)]) $ + do sch <- mkScheme "cryptol" + path' <- mapM mkPathPiece (p:|ps) + pure URI + { uriScheme = Just sch + , uriAuthority = Left True -- absolute path + , uriPath = Just (False, path') + , uriQuery = [] + , uriFragment = Nothing + } +cryptolURI (p:ps) (Just uniq) = + fromMaybe (panic "cryptolURI" ["Could not make URI from the given path", show (p:ps), show uniq]) $ + do sch <- mkScheme "cryptol" + path' <- mapM mkPathPiece (p:|ps) + frag <- mkFragment (Text.pack (show uniq)) + pure URI + { uriScheme = Just sch + , uriAuthority = Left False -- relative path + , uriPath = Just (False, path') + , uriQuery = [] + , uriFragment = Just frag + } + +-- | Tests if the given 'NameInfo' represents a name imported +-- from the given Cryptol module name. If so, it returns +-- the identifier within that module. Note, this does +-- not match dynamic identifiers from the \"\\" +-- pseudo-module. +isCryptolModuleName :: C.ModName -> NameInfo -> Maybe Text +isCryptolModuleName modNm (ImportedName uri _) + | Just sch <- uriScheme uri + , unRText sch == "cryptol" + , Left True <- uriAuthority uri + , Just (False, x :| xs) <- uriPath uri + , [] <- uriQuery uri + , Nothing <- uriFragment uri + = checkModName (x:xs) (Text.splitOn "::" (C.modNameToText modNm)) + + where + checkModName [i] [] = Just (unRText i) + checkModName (x:xs) (m:ms) | unRText x == m = checkModName xs ms + checkModName _ _ = Nothing + +isCryptolModuleName _ _ = Nothing + + +-- | Tests if the given `NameInfo` represents a name +-- from the special \ cryptol module. +-- If so, returns the base identifier name. +isCryptolInteractiveName :: NameInfo -> Maybe Text +isCryptolInteractiveName (ImportedName uri _) + | Just sch <- uriScheme uri + , unRText sch == "cryptol" + , Left False <- uriAuthority uri + , Just (False, i :| []) <- uriPath uri + , [] <- uriQuery uri + , Just _ <- uriFragment uri + = Just (unRText i) + +isCryptolInteractiveName _ = Nothing + + + +importName :: C.Name -> IO NameInfo +importName cnm = + case C.nameInfo cnm of + C.Parameter -> fail ("Cannot import non-top-level name: " ++ show cnm) + C.Declared modNm _ + | modNm == C.interactiveName -> + let shortNm = C.identText (C.nameIdent cnm) + aliases = [shortNm] + uri = cryptolURI [shortNm] (Just (C.nameUnique cnm)) + in pure (ImportedName uri aliases) + + | otherwise -> + let modNmTxt = C.modNameToText modNm + modNms = Text.splitOn "::" modNmTxt + shortNm = C.identText (C.nameIdent cnm) + aliases = [shortNm, modNmTxt <> "::" <> shortNm] + uri = cryptolURI (modNms ++ [shortNm]) Nothing + in pure (ImportedName uri aliases) + +-- | Currently this imports declaration groups by inlining all the +-- definitions. (With subterm sharing, this is not as bad as it might +-- seem.) We might want to think about generating let or where +-- expressions instead. +importDeclGroup :: Bool -> SharedContext -> Env -> C.DeclGroup -> IO Env + +importDeclGroup isTopLevel sc env (C.Recursive [decl]) = + case C.dDefinition decl of + C.DPrim -> + panic "importDeclGroup" ["Primitive declarations cannot be recursive:", show (C.dName decl)] + C.DExpr expr -> + do env1 <- bindName sc (C.dName decl) (C.dSignature decl) env + t' <- importSchema sc env (C.dSignature decl) + e' <- importExpr' sc env1 (C.dSignature decl) expr + let x = nameToLocalName (C.dName decl) + f' <- scLambda sc x t' e' + rhs <- scGlobalApply sc "Prelude.fix" [t', f'] + rhs' <- if isTopLevel then + do nmi <- importName (C.dName decl) + scConstant' sc nmi rhs t' + else + return rhs + let env' = env { envE = Map.insert (C.dName decl) (rhs', 0) (envE env) + , envC = Map.insert (C.dName decl) (C.dSignature decl) (envC env) } + return env' + + +-- - A group of mutually-recursive declarations - +-- We handle this by "tupling up" all the declarations using a record and +-- taking the fixpoint at this record type. The desired declarations are then +-- achieved by projecting the field names from this record. +importDeclGroup isTopLevel sc env (C.Recursive decls) = + do -- build the environment for the declaration bodies + let dm = Map.fromList [ (C.dName d, d) | d <- decls ] + + -- grab a reference to the outermost variable; this will be the record in the body + -- of the lambda we build later + v0 <- scLocalVar sc 0 + + -- build a list of projections from a record variable + vm <- traverse (scRecordSelect sc v0 . nameToFieldName . C.dName) dm + + -- the types of the declarations + tm <- traverse (importSchema sc env . C.dSignature) dm + -- the type of the recursive record + rect <- scRecordType sc (Map.assocs $ Map.mapKeys nameToFieldName tm) + + let env1 = liftEnv env + let env2 = env1 { envE = Map.union (fmap (\v -> (v, 0)) vm) (envE env1) + , envC = Map.union (fmap C.dSignature dm) (envC env1) + , envS = rect : envS env1 } + + let extractDeclExpr decl = + case C.dDefinition decl of + C.DExpr expr -> importExpr' sc env2 (C.dSignature decl) expr + C.DPrim -> + panic "importDeclGroup" + [ "Primitive declarations cannot be recursive:" + , show (C.dName decl) + ] + + -- the raw imported bodies of the declarations + em <- traverse extractDeclExpr dm + + -- the body of the recursive record + recv <- scRecord sc (Map.mapKeys nameToFieldName em) + + -- build a lambda from the record body... + f <- scLambda sc "fixRecord" rect recv + + -- and take its fixpoint + rhs <- scGlobalApply sc "Prelude.fix" [rect, f] + + -- finally, build projections from the fixed record to shove into the environment + -- if toplevel, then wrap each binding with a Constant constructor + let mkRhs d t = + do let s = nameToFieldName (C.dName d) + r <- scRecordSelect sc rhs s + if isTopLevel then + do nmi <- importName (C.dName d) + scConstant' sc nmi r t + else + return r + rhss <- sequence (Map.intersectionWith mkRhs dm tm) + + let env' = env { envE = Map.union (fmap (\v -> (v, 0)) rhss) (envE env) + , envC = Map.union (fmap C.dSignature dm) (envC env) + } + return env' + +importDeclGroup isTopLevel sc env (C.NonRecursive decl) = + case C.dDefinition decl of + C.DPrim + | isTopLevel -> do + rhs <- importPrimitive sc env (C.dName decl) (C.dSignature decl) + let env' = env { envE = Map.insert (C.dName decl) (rhs, 0) (envE env) + , envC = Map.insert (C.dName decl) (C.dSignature decl) (envC env) } + return env' + | otherwise -> do + panic "importDeclGroup" ["Primitive declarations only allowed at top-level:", show (C.dName decl)] + + C.DExpr expr -> do + rhs <- importExpr' sc env (C.dSignature decl) expr + rhs' <- if not isTopLevel then return rhs else do + nmi <- importName (C.dName decl) + t <- importSchema sc env (C.dSignature decl) + scConstant' sc nmi rhs t + let env' = env { envE = Map.insert (C.dName decl) (rhs', 0) (envE env) + , envC = Map.insert (C.dName decl) (C.dSignature decl) (envC env) } + return env' + +importDeclGroups :: SharedContext -> Env -> [C.DeclGroup] -> IO Env +importDeclGroups sc = foldM (importDeclGroup False sc) + +importTopLevelDeclGroups :: SharedContext -> Env -> [C.DeclGroup] -> IO Env +importTopLevelDeclGroups sc = foldM (importDeclGroup True sc) + +coerceTerm :: SharedContext -> Env -> C.Type -> C.Type -> Term -> IO Term +coerceTerm sc env t1 t2 e + | t1 == t2 = do return e + | otherwise = + do t1' <- importType sc env t1 + t2' <- importType sc env t2 + q <- proveEq sc env t1 t2 + scGlobalApply sc "Prelude.coerce" [t1', t2', q, e] + +proveEq :: SharedContext -> Env -> C.Type -> C.Type -> IO Term +proveEq sc env t1 t2 + | t1 == t2 = + do s <- scSort sc (mkSort 0) + t' <- importType sc env t1 + scCtorApp sc "Prelude.Refl" [s, t'] + | otherwise = + case (C.tNoUser t1, C.tNoUser t2) of + (C.tIsSeq -> Just (n1, a1), C.tIsSeq -> Just (n2, a2)) -> + do n1' <- importType sc env n1 + n2' <- importType sc env n2 + a1' <- importType sc env a1 + a2' <- importType sc env a2 + num <- scDataTypeApp sc "Cryptol.Num" [] + nEq <- if n1 == n2 + then scCtorApp sc "Prelude.Refl" [num, n1'] + else scGlobalApply sc "Prelude.unsafeAssert" [num, n1', n2'] + aEq <- proveEq sc env a1 a2 + if a1 == a2 + then scGlobalApply sc "Cryptol.seq_cong1" [n1', n2', a1', nEq] + else scGlobalApply sc "Cryptol.seq_cong" [n1', n2', a1', a2', nEq, aEq] + (C.tIsIntMod -> Just n1, C.tIsIntMod -> Just n2) -> + do n1' <- importType sc env n1 + n2' <- importType sc env n2 + num <- scDataTypeApp sc "Cryptol.Num" [] + nEq <- if n1 == n2 + then scCtorApp sc "Prelude.Refl" [num, n1'] + else scGlobalApply sc "Prelude.unsafeAssert" [num, n1', n2'] + scGlobalApply sc "Cryptol.IntModNum_cong" [n1', n2', nEq] + (C.tIsFun -> Just (a1, b1), C.tIsFun -> Just (a2, b2)) -> + do a1' <- importType sc env a1 + a2' <- importType sc env a2 + b1' <- importType sc env b1 + b2' <- importType sc env b2 + aEq <- proveEq sc env a1 a2 + bEq <- proveEq sc env b1 b2 + scGlobalApply sc "Cryptol.fun_cong" [a1', a2', b1', b2', aEq, bEq] + (C.tIsTuple -> Just (a1 : ts1), C.tIsTuple -> Just (a2 : ts2)) + | length ts1 == length ts2 -> + do let b1 = C.tTuple ts1 + b2 = C.tTuple ts2 + a1' <- importType sc env a1 + a2' <- importType sc env a2 + b1' <- importType sc env b1 + b2' <- importType sc env b2 + aEq <- proveEq sc env a1 a2 + bEq <- proveEq sc env b1 b2 + if b1 == b2 + then scGlobalApply sc "Cryptol.pair_cong1" [a1', a2', b1', aEq] + else if a1 == a2 + then scGlobalApply sc "Cryptol.pair_cong2" [a1', b1', b2', bEq] + else scGlobalApply sc "Cryptol.pair_cong" [a1', a2', b1', b2', aEq, bEq] + (C.tIsRec -> Just tm1, C.tIsRec -> Just tm2) + | map fst (C.canonicalFields tm1) == map fst (C.canonicalFields tm2) -> + proveEq sc env (C.tTuple (map snd (C.canonicalFields tm1))) (C.tTuple (map snd (C.canonicalFields tm2))) + (_, _) -> + panic "proveEq" ["Internal type error:", pretty t1, pretty t2] + +-------------------------------------------------------------------------------- +-- List comprehensions + +importComp :: SharedContext -> Env -> C.Type -> C.Type -> C.Expr -> [[C.Match]] -> IO Term +importComp sc env lenT elemT expr mss = + do let zipAll [] = panic "importComp" ["zero-branch list comprehension"] + zipAll [branch] = + do (xs, len, ty, args) <- importMatches sc env branch + m <- importType sc env len + a <- importType sc env ty + return (xs, m, a, [args], len) + zipAll (branch : branches) = + do (xs, len, ty, args) <- importMatches sc env branch + m <- importType sc env len + a <- importType sc env ty + (ys, n, b, argss, len') <- zipAll branches + zs <- scGlobalApply sc "Cryptol.seqZip" [a, b, m, n, xs, ys] + mn <- scGlobalApply sc "Cryptol.tcMin" [m, n] + ab <- scTupleType sc [a, b] + return (zs, mn, ab, args : argss, C.tMin len len') + (xs, n, a, argss, lenT') <- zipAll mss + f <- lambdaTuples sc env elemT expr argss + b <- importType sc env elemT + ys <- scGlobalApply sc "Cryptol.seqMap" [a, b, n, f, xs] + -- The resulting type might not match the annotation, so we coerce + coerceTerm sc env (C.tSeq lenT' elemT) (C.tSeq lenT elemT) ys + +lambdaTuples :: SharedContext -> Env -> C.Type -> C.Expr -> [[(C.Name, C.Type)]] -> IO Term +lambdaTuples sc env _ty expr [] = importExpr sc env expr +lambdaTuples sc env ty expr (args : argss) = + do f <- lambdaTuple sc env ty expr argss args + if null args || null argss + then return f + else do a <- importType sc env (tNestedTuple (map snd args)) + b <- importType sc env (tNestedTuple (map (tNestedTuple . map snd) argss)) + c <- importType sc env ty + scGlobalApply sc "Prelude.uncurry" [a, b, c, f] + +lambdaTuple :: SharedContext -> Env -> C.Type -> C.Expr -> [[(C.Name, C.Type)]] -> [(C.Name, C.Type)] -> IO Term +lambdaTuple sc env ty expr argss [] = lambdaTuples sc env ty expr argss +lambdaTuple sc env ty expr argss ((x, t) : args) = + do a <- importType sc env t + env' <- bindName sc x (C.Forall [] [] t) env + e <- lambdaTuple sc env' ty expr argss args + f <- scLambda sc (nameToLocalName x) a e + if null args + then return f + else do b <- importType sc env (tNestedTuple (map snd args)) + let tuple = tNestedTuple (map (tNestedTuple . map snd) argss) + c <- importType sc env (if null argss then ty else C.tFun tuple ty) + scGlobalApply sc "Prelude.uncurry" [a, b, c, f] + +tNestedTuple :: [C.Type] -> C.Type +tNestedTuple [] = C.tTuple [] +tNestedTuple [t] = t +tNestedTuple (t : ts) = C.tTuple [t, tNestedTuple ts] + + +-- | Returns the shared term, length type, element tuple type, bound +-- variables. +importMatches :: SharedContext -> Env -> [C.Match] + -> IO (Term, C.Type, C.Type, [(C.Name, C.Type)]) +importMatches _sc _env [] = panic "importMatches" ["importMatches: empty comprehension branch"] + +importMatches sc env [C.From name _len _eltty expr] = do + (len, ty) <- case C.tIsSeq (fastTypeOf (envC env) expr) of + Just x -> return x + Nothing -> panic "importMatches" ["type mismatch from: " ++ show (fastTypeOf (envC env) expr)] + xs <- importExpr sc env expr + return (xs, len, ty, [(name, ty)]) + +importMatches sc env (C.From name _len _eltty expr : matches) = do + (len1, ty1) <- case C.tIsSeq (fastTypeOf (envC env) expr) of + Just x -> return x + Nothing -> panic "importMatches" ["type mismatch from: " ++ show (fastTypeOf (envC env) expr)] + m <- importType sc env len1 + a <- importType sc env ty1 + xs <- importExpr sc env expr + env' <- bindName sc name (C.Forall [] [] ty1) env + (body, len2, ty2, args) <- importMatches sc env' matches + n <- importType sc env len2 + b <- importType sc env ty2 + f <- scLambda sc (nameToLocalName name) a body + result <- scGlobalApply sc "Cryptol.from" [a, b, m, n, xs, f] + return (result, C.tMul len1 len2, C.tTuple [ty1, ty2], (name, ty1) : args) + +importMatches sc env [C.Let decl] + | C.DPrim <- C.dDefinition decl = do + panic "importMatches" ["Primitive declarations not allowed in 'let':", show (C.dName decl)] + | C.DExpr expr <- C.dDefinition decl = do + e <- importExpr sc env expr + ty1 <- case C.dSignature decl of + C.Forall [] [] ty1 -> return ty1 + _ -> unimplemented "polymorphic Let" + a <- importType sc env ty1 + result <- scGlobalApply sc "Prelude.single" [a, e] + return (result, C.tOne, ty1, [(C.dName decl, ty1)]) + +importMatches sc env (C.Let decl : matches) = + case C.dDefinition decl of + C.DPrim -> do + panic "importMatches" ["Primitive declarations not allowed in 'let':", show (C.dName decl)] + C.DExpr expr -> do + e <- importExpr sc env expr + ty1 <- case C.dSignature decl of + C.Forall [] [] ty1 -> return ty1 + _ -> unimplemented "polymorphic Let" + a <- importType sc env ty1 + env' <- bindName sc (C.dName decl) (C.dSignature decl) env + (body, len, ty2, args) <- importMatches sc env' matches + n <- importType sc env len + b <- importType sc env ty2 + f <- scLambda sc (nameToLocalName (C.dName decl)) a body + result <- scGlobalApply sc "Cryptol.mlet" [a, b, n, e, f] + return (result, len, C.tTuple [ty1, ty2], (C.dName decl, ty1) : args) + +pIsNeq :: C.Type -> Maybe (C.Type, C.Type) +pIsNeq ty = case C.tNoUser ty of + C.TCon (C.PC C.PNeq) [t1, t2] -> Just (t1, t2) + _ -> Nothing + +-------------------------------------------------------------------------------- +-- Utilities + +asCryptolTypeValue :: SC.TValue SC.Concrete -> Maybe C.Type +asCryptolTypeValue v = + case v of + SC.VBoolType -> return C.tBit + SC.VIntType -> return C.tInteger + SC.VIntModType n -> return (C.tIntMod (C.tNum n)) + SC.VArrayType v1 v2 -> do + t1 <- asCryptolTypeValue v1 + t2 <- asCryptolTypeValue v2 + return $ C.tArray t1 t2 + SC.VVecType n v2 -> do + t2 <- asCryptolTypeValue v2 + return (C.tSeq (C.tNum n) t2) + SC.VDataType "Prelude.Stream" [v1] -> + case v1 of + SC.TValue tv -> C.tSeq C.tInf <$> asCryptolTypeValue tv + _ -> Nothing + SC.VUnitType -> return (C.tTuple []) + SC.VPairType v1 v2 -> do + t1 <- asCryptolTypeValue v1 + t2 <- asCryptolTypeValue v2 + case C.tIsTuple t2 of + Just ts -> return (C.tTuple (t1 : ts)) + Nothing -> return (C.tTuple [t1, t2]) + SC.VPiType v1 f -> do + case v1 of + -- if we see that the parameter is a Cryptol.Num, it's a + -- pretty good guess that it originally was a + -- polymorphic number type. + SC.VDataType "Cryptol.Num" [] -> + let msg= unwords ["asCryptolTypeValue: can't infer a polymorphic Cryptol" + ,"type. Please, make sure all numeric types are" + ,"specialized before constructing a typed term." + ] + in error msg + -- otherwise we issue a generic error about dependent type inference + _ -> do + let msg = unwords ["asCryptolTypeValue: can't infer a Cryptol type" + ,"for a dependent SAW-Core type." + ] + let v2 = SC.runIdentity (f (error msg)) + t1 <- asCryptolTypeValue v1 + t2 <- asCryptolTypeValue v2 + return (C.tFun t1 t2) + _ -> Nothing + +-- | Deprecated. +scCryptolType :: SharedContext -> Term -> IO C.Type +scCryptolType sc t = + do modmap <- scGetModuleMap sc + case SC.evalSharedTerm modmap Map.empty Map.empty t of + SC.TValue (asCryptolTypeValue -> Just ty) -> return ty + _ -> panic "scCryptolType" ["scCryptolType: unsupported type " ++ showTerm t] + +-- | Deprecated. +scCryptolEq :: SharedContext -> Term -> Term -> IO Term +scCryptolEq sc x y = + do rules <- concat <$> traverse defRewrites defs + let ss = addConvs natConversions (addRules rules emptySimpset) + tx <- scTypeOf sc x >>= rewriteSharedTerm sc ss >>= scCryptolType sc + ty <- scTypeOf sc y >>= rewriteSharedTerm sc ss >>= scCryptolType sc + unless (tx == ty) $ + panic "scCryptolEq" + [ "scCryptolEq: type mismatch between" + , pretty tx + , "and" + , pretty ty + ] + + -- Actually apply the equality function, along with the Eq class dictionary + t <- scTypeOf sc x + c <- scCryptolType sc t + k <- importType sc emptyEnv c + eqPrf <- proveProp sc emptyEnv (C.pEq c) + scGlobalApply sc "Cryptol.ecEq" [k, eqPrf, x, y] + + where + defs = map (mkIdent (mkModuleName ["Cryptol"])) ["seq", "ty"] + defRewrites ident = + do maybe_def <- scFindDef sc ident + case maybe_def of + Nothing -> return [] + Just def -> scDefRewriteRules sc def + +-- | Convert from SAWCore's Value type to Cryptol's, guided by the +-- Cryptol type schema. +exportValueWithSchema :: C.Schema -> SC.CValue -> V.Value +exportValueWithSchema (C.Forall [] [] ty) v = exportValue (evalValType mempty ty) v +exportValueWithSchema _ _ = V.VPoly mempty (error "exportValueWithSchema") +-- TODO: proper support for polymorphic values + +exportValue :: TV.TValue -> SC.CValue -> V.Value +exportValue ty v = case ty of + + TV.TVBit -> + V.VBit (SC.toBool v) + + TV.TVInteger -> + V.VInteger (case v of SC.VInt x -> x; _ -> error "exportValue: expected integer") + + TV.TVIntMod _modulus -> + V.VInteger (case v of SC.VIntMod _ x -> x; _ -> error "exportValue: expected intmod") + + TV.TVArray{} -> error $ "exportValue: (on array type " ++ show ty ++ ")" + + TV.TVRational -> error "exportValue: Not yet implemented: Rational" + + TV.TVFloat _ _ -> panic "exportValue: Not yet implemented: Float" [] + + TV.TVSeq _ e -> + case v of + SC.VWord w -> V.word V.Concrete (toInteger (width w)) (unsigned w) + SC.VVector xs + | TV.isTBit e -> V.VWord (toInteger (Vector.length xs)) (V.ready (V.LargeBitsVal (fromIntegral (Vector.length xs)) + (V.finiteSeqMap . map (V.ready . V.VBit . SC.toBool . SC.runIdentity . force) $ Fold.toList xs))) + | otherwise -> V.VSeq (toInteger (Vector.length xs)) $ V.finiteSeqMap $ + map (V.ready . exportValue e . SC.runIdentity . force) $ Vector.toList xs + _ -> error $ "exportValue (on seq type " ++ show ty ++ ")" + + -- infinite streams + TV.TVStream e -> + case v of + SC.VExtra (SC.CStream trie) -> V.VStream (V.IndexSeqMap $ \i -> V.ready $ exportValue e (IntTrie.apply trie i)) + _ -> error $ "exportValue (on seq type " ++ show ty ++ ")" + + -- tuples + TV.TVTuple etys -> V.VTuple (exportTupleValue etys v) + + -- records + TV.TVRec fields -> + V.VRecord (C.recordFromFieldsWithDisplay (C.displayOrder fields) $ exportRecordValue (C.canonicalFields fields) v) + + -- functions + TV.TVFun _aty _bty -> + V.VFun mempty (error "exportValue: TODO functions") + + -- abstract types + TV.TVAbstract{} -> + error "exportValue: TODO abstract types" + + -- newtypes + TV.TVNewtype _ _ fields -> + exportValue (TV.TVRec fields) v + + +exportTupleValue :: [TV.TValue] -> SC.CValue -> [V.Eval V.Value] +exportTupleValue tys v = + case (tys, v) of + ([] , SC.VUnit ) -> [] + ([t] , _ ) -> [V.ready $ exportValue t v] + (t : ts, SC.VPair x y) -> (V.ready $ exportValue t (run x)) : exportTupleValue ts (run y) + _ -> error $ "exportValue: expected tuple" + where + run = SC.runIdentity . force + +exportRecordValue :: [(C.Ident, TV.TValue)] -> SC.CValue -> [(C.Ident, V.Eval V.Value)] +exportRecordValue fields v = + case (fields, v) of + ([] , SC.VUnit ) -> [] + ([(n, t)] , _ ) -> [(n, V.ready $ exportValue t v)] + ((n, t) : ts, SC.VPair x y) -> + (n, V.ready $ exportValue t (run x)) : exportRecordValue ts (run y) + (_, SC.VRecordValue (alistAllFields + (map (C.identText . fst) fields) -> Just ths)) -> + zipWith (\(n,t) x -> (n, V.ready $ exportValue t (run x))) fields ths + _ -> error $ "exportValue: expected record" + where + run = SC.runIdentity . force + +fvAsBool :: FirstOrderValue -> Bool +fvAsBool (FOVBit b) = b +fvAsBool _ = error "fvAsBool: expected FOVBit value" + +exportFirstOrderValue :: FirstOrderValue -> V.Value +exportFirstOrderValue fv = + case fv of + FOVBit b -> V.VBit b + FOVInt i -> V.VInteger i + FOVIntMod _ i -> V.VInteger i + FOVWord w x -> V.word V.Concrete (toInteger w) x + FOVVec t vs + | t == FOTBit -> V.VWord len (V.ready (V.LargeBitsVal len (V.finiteSeqMap . map (V.ready . V.VBit . fvAsBool) $ vs))) + | otherwise -> V.VSeq len (V.finiteSeqMap (map (V.ready . exportFirstOrderValue) vs)) + where len = toInteger (length vs) + FOVArray{} -> error $ "exportFirstOrderValue: unsupported FOT Array" + FOVTuple vs -> V.VTuple (map (V.ready . exportFirstOrderValue) vs) + FOVRec vm -> V.VRecord $ C.recordFromFields [ (C.mkIdent n, V.ready $ exportFirstOrderValue v) | (n, v) <- Map.assocs vm ] + +importFirstOrderValue :: FirstOrderType -> V.Value -> IO FirstOrderValue +importFirstOrderValue t0 v0 = V.runEval mempty (go t0 v0) + where + go :: FirstOrderType -> V.Value -> V.Eval FirstOrderValue + go t v = case (t,v) of + (FOTBit , V.VBit b) -> return (FOVBit b) + (FOTInt , V.VInteger i) -> return (FOVInt i) + (FOTVec _ FOTBit, V.VWord w wv) -> FOVWord (fromIntegral w) . V.bvVal <$> (V.asWordVal V.Concrete =<< wv) + (FOTVec _ ty , V.VSeq len xs) -> FOVVec ty <$> traverse (go ty =<<) (V.enumerateSeqMap len xs) + (FOTTuple tys , V.VTuple xs) -> FOVTuple <$> traverse (\(ty, x) -> go ty =<< x) (zip tys xs) + (FOTRec fs , V.VRecord xs) -> + do xs' <- Map.fromList <$> mapM importField (C.canonicalFields xs) + let missing = Set.difference (Map.keysSet fs) (Set.fromList (map C.identText (C.displayOrder xs))) + unless (Set.null missing) + (panic "importFirstOrderValue" $ + ["Missing fields while importing finite value:"] ++ (map show (Set.toList missing))) + return $ FOVRec $ xs' + where + importField :: (C.Ident, V.Eval V.Value) -> V.Eval (FieldName, FirstOrderValue) + importField (C.identText -> nm, x) + | Just ty <- Map.lookup nm fs = do + x' <- go ty =<< x + return (nm, x') + | otherwise = panic "importFirstOrderValue" ["Unexpected field name while importing finite value:", show nm] + + _ -> panic "importFirstOrderValue" + ["Expected finite value of type:", show t, "but got", show v] diff --git a/cryptol-saw-core/src/Verifier/SAW/Cryptol/Panic.hs b/cryptol-saw-core/src/Verifier/SAW/Cryptol/Panic.hs new file mode 100644 index 0000000000..bdea8c0079 --- /dev/null +++ b/cryptol-saw-core/src/Verifier/SAW/Cryptol/Panic.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Verifier.SAW.Cryptol.Panic + ( panic, unimplemented ) + where + +import Panic hiding (panic) +import qualified Panic as Panic + +data CryptolSawCore = CryptolSawCore + +panic :: HasCallStack => String -> [String] -> a +panic = Panic.panic CryptolSawCore + +instance PanicComponent CryptolSawCore where + panicComponentName _ = "cryptol-saw-core" + panicComponentIssues _ = "https://github.com/GaloisInc/saw-script/issues" + + {-# Noinline panicComponentRevision #-} + panicComponentRevision = $useGitRevision + +unimplemented :: HasCallStack => String -> a +unimplemented name = panic "unimplemented" [name] + diff --git a/cryptol-saw-core/src/Verifier/SAW/Cryptol/Prelude.hs b/cryptol-saw-core/src/Verifier/SAW/Cryptol/Prelude.hs new file mode 100644 index 0000000000..6ddb2ff3b3 --- /dev/null +++ b/cryptol-saw-core/src/Verifier/SAW/Cryptol/Prelude.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE TemplateHaskell #-} + +{- | +Module : Verifier.SAW.Cryptol.Prelude +Copyright : Galois, Inc. 2012-2015 +License : BSD3 +Maintainer : huffman@galois.com +Stability : experimental +Portability : non-portable (language extensions) +-} + +module Verifier.SAW.Cryptol.Prelude + ( Module + , module Verifier.SAW.Cryptol.Prelude + , scLoadPreludeModule + ) where + +import Verifier.SAW.Prelude +import Verifier.SAW.ParserUtils + +$(defineModuleFromFileWithFns + "cryptolModule" "scLoadCryptolModule" "saw/Cryptol.sawcore") diff --git a/cryptol-saw-core/src/Verifier/SAW/Cryptol/Simpset.hs b/cryptol-saw-core/src/Verifier/SAW/Cryptol/Simpset.hs new file mode 100644 index 0000000000..c6a03265d5 --- /dev/null +++ b/cryptol-saw-core/src/Verifier/SAW/Cryptol/Simpset.hs @@ -0,0 +1,54 @@ +{- | +Module : Verifier.SAW.Cryptol.Simpset +Copyright : Galois, Inc. 2018 +License : BSD3 +Maintainer : huffman@galois.com +Stability : experimental +Portability : non-portable (language extensions) +-} + +{-# LANGUAGE OverloadedStrings #-} + +module Verifier.SAW.Cryptol.Simpset + ( mkCryptolSimpset + ) where + +import Verifier.SAW.Module +import Verifier.SAW.Rewriter +import Verifier.SAW.SharedTerm +import Verifier.SAW.Term.Functor + +mkCryptolSimpset :: SharedContext -> IO Simpset +mkCryptolSimpset sc = + do m <- scFindModule sc cryptolModuleName + scSimpset sc (cryptolDefs m) [] [] + where + cryptolDefs m = filter (not . excluded) $ moduleDefs m + excluded d = defIdent d `elem` excludedNames + +cryptolModuleName :: ModuleName +cryptolModuleName = mkModuleName ["Cryptol"] + +excludedNames :: [Ident] +excludedNames = + map (mkIdent cryptolModuleName) + [ "fix" + , "pair_cong" + , "seq_cong" + , "pair_cong1" + , "pair_cong2" + , "seq_cong1" + , "fun_cong" + , "seq_TCNum" + , "seq_TCInf" + , "PLiteral" + , "PLogic" + , "PRing" + , "PIntegral" + , "PField" + , "PRound" + , "PEq" + , "PCmp" + , "PSignedCmp" + , "ecEq" + ] diff --git a/cryptol-saw-core/src/Verifier/SAW/CryptolEnv.hs b/cryptol-saw-core/src/Verifier/SAW/CryptolEnv.hs new file mode 100644 index 0000000000..4d640ce7e4 --- /dev/null +++ b/cryptol-saw-core/src/Verifier/SAW/CryptolEnv.hs @@ -0,0 +1,670 @@ +{- | +Module : SAWScript.CryptolEnv +Description : Context for interpreting Cryptol within SAW-Script. +License : BSD3 +Maintainer : huffman +Stability : provisional +-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Verifier.SAW.CryptolEnv + ( ImportVisibility(..) + , CryptolEnv(..) + , initCryptolEnv + , loadCryptolModule + , bindCryptolModule + , lookupCryptolModule + , importModule + , bindTypedTerm + , bindType + , bindInteger + , parseTypedTerm + , parseDecls + , parseSchema + , declareName + , typeNoUser + , schemaNoUser + , translateExpr + , getNamingEnv + , getAllIfaceDecls + , InputText(..) + , lookupIn + , resolveIdentifier + ) + where + +--import qualified Control.Exception as X +import Data.ByteString (ByteString) +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Data.Set as Set +import Data.Maybe (fromMaybe) +import Data.Text (Text, pack, splitOn) +import Control.Monad(when) + +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid +import Data.Traversable +#endif + +import System.Environment (lookupEnv) +import System.Environment.Executable (splitExecutablePath) +import System.FilePath ((), normalise, joinPath, splitPath, splitSearchPath) + +import Verifier.SAW.SharedTerm (SharedContext, Term, incVars) + +import qualified Verifier.SAW.Cryptol as C + +import qualified Cryptol.Eval as E +import qualified Cryptol.Parser as P +import qualified Cryptol.Parser.AST as P +import qualified Cryptol.Parser.Position as P +import qualified Cryptol.TypeCheck as T +import qualified Cryptol.TypeCheck.AST as T +import qualified Cryptol.TypeCheck.Error as TE +import qualified Cryptol.TypeCheck.Infer as TI +import qualified Cryptol.TypeCheck.Kind as TK +import qualified Cryptol.TypeCheck.Monad as TM +import qualified Cryptol.TypeCheck.Solver.SMT as SMT +--import qualified Cryptol.TypeCheck.PP as TP + +import qualified Cryptol.ModuleSystem as M +import qualified Cryptol.ModuleSystem.Base as MB +import qualified Cryptol.ModuleSystem.Env as ME +import qualified Cryptol.ModuleSystem.Exports as MEx +import qualified Cryptol.ModuleSystem.Interface as MI +import qualified Cryptol.ModuleSystem.Monad as MM +import qualified Cryptol.ModuleSystem.NamingEnv as MN +import qualified Cryptol.ModuleSystem.Name as MN +import qualified Cryptol.ModuleSystem.Renamer as MR + +import qualified Cryptol.Utils.Ident as C + +import Cryptol.Utils.PP +import Cryptol.Utils.Ident (Ident, preludeName, preludeReferenceName + , packIdent, interactiveName, identText + , packModName, textToModName, modNameChunks + , prelPrim) +import Cryptol.Utils.Logger (quietLogger) + +--import SAWScript.REPL.Monad (REPLException(..)) +import Verifier.SAW.TypedTerm +-- import SAWScript.Utils (Pos(..)) +-- import SAWScript.AST (Located(getVal, locatedPos), Import(..)) + + +-- | Parse input, together with information about where it came from. +data InputText = InputText + { inpText :: String -- ^ Parse this + , inpFile :: String -- ^ It came from this file (or thing) + , inpLine :: Int -- ^ On this line number + , inpCol :: Int -- ^ On this column number + } + + + +-------------------------------------------------------------------------------- + +-- | Should a given import result in all symbols being visible (as they +-- are for focused modules in the Cryptol REPL) or only public symbols? +-- Making all symbols visible is useful for verification and code +-- generation. +data ImportVisibility + = OnlyPublic + | PublicAndPrivate + +data CryptolEnv = CryptolEnv + { eImports :: [(ImportVisibility, P.Import)] -- ^ Declarations of imported Cryptol modules + , eModuleEnv :: ME.ModuleEnv -- ^ Imported modules, and state for the ModuleM monad + , eExtraNames :: MR.NamingEnv -- ^ Context for the Cryptol renamer + , eExtraTypes :: Map T.Name T.Schema -- ^ Cryptol types for extra names in scope + , eExtraTSyns :: Map T.Name T.TySyn -- ^ Extra Cryptol type synonyms in scope + , eTermEnv :: Map T.Name Term -- ^ SAWCore terms for *all* names in scope + } + + +-- Finding things -------------------------------------------------------------- + + +-- | Lookup a name in a map containg Cryptol names. +-- The string corresponds to the Cryptol name we are looking for. +-- If it is unqualifed, then we return any entry associated with the given +-- name. If the string is qualified (i.e., has @::@), then we only consider +-- entries from the module in the qualified. +-- The result is either the corresponding value, or a list of the +lookupIn :: String -> Map T.Name b -> Either [T.Name] b +lookupIn nm mp = + case [ x | x <- Map.toList mp, matches (fst x) ] of + [ (_,v) ] -> Right v + opts -> Left (map fst opts) + where + matches = nameMatcher nm + + +-- | Parse a string into a function that will match names. +-- If the string is unqualified (i.e., no `::`), then we match all +-- names with the given identifier. Otherwise, we only match the +-- ones in the module specified by the qualifier. +nameMatcher :: String -> T.Name -> Bool +nameMatcher xs = + case modNameChunks (textToModName (pack xs)) of + [] -> const False + [x] -> (packIdent x ==) . MN.nameIdent + cs -> let m = MN.Declared (packModName (map pack (init cs))) MN.UserName + i = packIdent (last cs) + in \n -> MN.nameIdent n == i && MN.nameInfo n == m + + + +-- Initialize ------------------------------------------------------------------ + +initCryptolEnv :: + (?fileReader :: FilePath -> IO ByteString) => + SharedContext -> IO CryptolEnv +initCryptolEnv sc = do + modEnv0 <- M.initialModuleEnv + + -- Set the Cryptol include path (TODO: we may want to do this differently) + (binDir, _) <- splitExecutablePath + let instDir = normalise . joinPath . init . splitPath $ binDir + mCryptolPath <- lookupEnv "CRYPTOLPATH" + let cryptolPaths = + case mCryptolPath of + Nothing -> [] + Just path -> +#if defined(mingw32_HOST_OS) || defined(__MINGW32__) + -- Windows paths search from end to beginning + reverse (splitSearchPath path) +#else + splitSearchPath path +#endif + let modEnv1 = modEnv0 { ME.meSearchPath = cryptolPaths ++ + (instDir "lib") : ME.meSearchPath modEnv0 } + + -- Load Cryptol prelude + (_, modEnv2) <- + liftModuleM modEnv1 $ + MB.loadModuleFrom False (MM.FromModule preludeName) + + -- Load Cryptol reference implementations + ((_,refMod), modEnv) <- + liftModuleM modEnv2 $ + MB.loadModuleFrom False (MM.FromModule preludeReferenceName) + + -- Set up reference implementation redirections + let refDecls = T.mDecls refMod + let nms = fst <$> Map.toList (M.ifDecls (M.ifPublic (M.genIface refMod))) + let refPrims = Map.fromList + [ (prelPrim (identText (MN.nameIdent nm)), T.EWhere (T.EVar nm) refDecls) + | nm <- nms ] + let cryEnv0 = C.emptyEnv{ C.envRefPrims = refPrims } + + -- Generate SAWCore translations for all values in scope + termEnv <- genTermEnv sc modEnv cryEnv0 + + return CryptolEnv + { eImports = [ (OnlyPublic, P.Import preludeName Nothing Nothing) + , (OnlyPublic, P.Import preludeReferenceName (Just preludeReferenceName) Nothing) + ] + , eModuleEnv = modEnv + , eExtraNames = mempty + , eExtraTypes = Map.empty + , eExtraTSyns = Map.empty + , eTermEnv = termEnv + } + +-- Parse ----------------------------------------------------------------------- + +ioParseExpr :: InputText -> IO (P.Expr P.PName) +ioParseExpr = ioParseGeneric P.parseExprWith + +ioParseDecls :: InputText -> IO [P.Decl P.PName] +ioParseDecls = ioParseGeneric P.parseDeclsWith + +ioParseSchema :: InputText -> IO (P.Schema P.PName) +ioParseSchema = ioParseGeneric P.parseSchemaWith + +ioParseGeneric :: + (P.Config -> Text -> Either P.ParseError a) -> InputText -> IO a +ioParseGeneric parse inp = ioParseResult (parse cfg (pack str)) + where + cfg = P.defaultConfig { P.cfgSource = inpFile inp } + str = concat [ replicate (inpLine inp - 1) '\n' + , replicate (inpCol inp - 1) ' ' + , inpText inp ] + +ioParseResult :: Either P.ParseError a -> IO a +ioParseResult res = case res of + Right a -> return a + Left e -> fail $ "Cryptol parse error:\n" ++ show (P.ppError e) -- X.throwIO (ParseError e) + +-- Rename ---------------------------------------------------------------------- + +getNamingEnv :: CryptolEnv -> MR.NamingEnv +getNamingEnv env = eExtraNames env `MR.shadowing` nameEnv + where + nameEnv = mconcat $ fromMaybe [] $ traverse loadImport (eImports env) + loadImport (vis, i) = do + lm <- ME.lookupModule (T.iModule i) (eModuleEnv env) + let ifc = ME.lmInterface lm + syms = case vis of + OnlyPublic -> MI.ifPublic ifc + PublicAndPrivate -> MI.ifPublic ifc `mappend` M.ifPrivate ifc + return $ MN.interpImport i syms + +getAllIfaceDecls :: ME.ModuleEnv -> M.IfaceDecls +getAllIfaceDecls me = mconcat (map (both . ME.lmInterface) (ME.getLoadedModules (ME.meLoadedModules me))) + where both ifc = M.ifPublic ifc `mappend` M.ifPrivate ifc + +-- Typecheck ------------------------------------------------------------------- + +runInferOutput :: TM.InferOutput a -> MM.ModuleM a +runInferOutput out = + case out of + + TM.InferOK nm warns seeds supply o -> + do MM.setNameSeeds seeds + MM.setSupply supply + MM.typeCheckWarnings nm warns + return o + + TM.InferFailed nm warns errs -> + do MM.typeCheckWarnings nm warns + MM.typeCheckingFailed nm errs + +-- Translate ------------------------------------------------------------------- + +mkCryEnv :: + (?fileReader :: FilePath -> IO ByteString) => + CryptolEnv -> IO C.Env +mkCryEnv env = + do let modEnv = eModuleEnv env + let ifaceDecls = getAllIfaceDecls modEnv + (types, _) <- + liftModuleM modEnv $ + do prims <- MB.getPrimMap + -- noIfaceParams because we don't support translating functors yet + TM.inpVars `fmap` MB.genInferInput P.emptyRange prims + MI.noIfaceParams ifaceDecls + let types' = Map.union (eExtraTypes env) types + let terms = eTermEnv env + let cryEnv = C.emptyEnv + { C.envE = fmap (\t -> (t, 0)) terms + , C.envC = types' + } + return cryEnv + +translateExpr :: + (?fileReader :: FilePath -> IO ByteString) => + SharedContext -> CryptolEnv -> T.Expr -> IO Term +translateExpr sc env expr = + do cryEnv <- mkCryEnv env + C.importExpr sc cryEnv expr + +translateDeclGroups :: + (?fileReader :: FilePath -> IO ByteString) => + SharedContext -> CryptolEnv -> [T.DeclGroup] -> IO CryptolEnv +translateDeclGroups sc env dgs = + do cryEnv <- mkCryEnv env + cryEnv' <- C.importTopLevelDeclGroups sc cryEnv dgs + termEnv' <- traverse (\(t, j) -> incVars sc 0 j t) (C.envE cryEnv') + + let decls = concatMap T.groupDecls dgs + let names = map T.dName decls + let newTypes = Map.fromList [ (T.dName d, T.dSignature d) | d <- decls ] + let addName name = MR.shadowing (MN.singletonE (P.mkUnqual (MN.nameIdent name)) name) + return env + { eExtraNames = foldr addName (eExtraNames env) names + , eExtraTypes = Map.union (eExtraTypes env) newTypes + , eTermEnv = termEnv' + } + +-- | Translate all declarations in all loaded modules to SAWCore terms +genTermEnv :: SharedContext -> ME.ModuleEnv -> C.Env -> IO (Map T.Name Term) +genTermEnv sc modEnv cryEnv0 = do + let declGroups = concatMap T.mDecls + $ filter (not . T.isParametrizedModule) + $ ME.loadedModules modEnv + cryEnv <- C.importTopLevelDeclGroups sc cryEnv0 declGroups + traverse (\(t, j) -> incVars sc 0 j t) (C.envE cryEnv) + +-------------------------------------------------------------------------------- + +checkNotParameterized :: T.Module -> IO () +checkNotParameterized m = + when (T.isParametrizedModule m) $ + fail $ unlines [ "Cannot load parameterized modules directly." + , "Either use a ` import, or make a module instantiation." + ] + + +loadCryptolModule :: + (?fileReader :: FilePath -> IO ByteString) => + SharedContext -> CryptolEnv -> FilePath -> + IO (CryptolModule, CryptolEnv) +loadCryptolModule sc env path = do + let modEnv = eModuleEnv env + (m, modEnv') <- liftModuleM modEnv (MB.loadModuleByPath path) + checkNotParameterized m + + let ifaceDecls = getAllIfaceDecls modEnv' + (types, modEnv'') <- liftModuleM modEnv' $ do + prims <- MB.getPrimMap + TM.inpVars `fmap` MB.genInferInput P.emptyRange prims MI.noIfaceParams ifaceDecls + + -- Regenerate SharedTerm environment. + oldCryEnv <- mkCryEnv env + let oldModNames = map ME.lmName $ ME.lmLoadedModules $ ME.meLoadedModules modEnv + let isNew m' = T.mName m' `notElem` oldModNames + let newModules = filter isNew $ map ME.lmModule $ ME.lmLoadedModules $ ME.meLoadedModules modEnv'' + let newDeclGroups = concatMap T.mDecls newModules + newCryEnv <- C.importTopLevelDeclGroups sc oldCryEnv newDeclGroups + newTermEnv <- traverse (\(t, j) -> incVars sc 0 j t) (C.envE newCryEnv) + + let names = MEx.eBinds (T.mExports m) -- :: Set T.Name + let tm' = Map.filterWithKey (\k _ -> Set.member k names) $ + Map.intersectionWith TypedTerm types newTermEnv + let env' = env { eModuleEnv = modEnv'' + , eTermEnv = newTermEnv + } + let sm' = Map.filterWithKey (\k _ -> Set.member k (MEx.eTypes (T.mExports m))) (T.mTySyns m) + return (CryptolModule sm' tm', env') + +bindCryptolModule :: (P.ModName, CryptolModule) -> CryptolEnv -> CryptolEnv +bindCryptolModule (modName, CryptolModule sm tm) env = + env { eExtraNames = flip (foldr addName) (Map.keys tm) $ + flip (foldr addTSyn) (Map.keys sm) $ eExtraNames env + , eExtraTSyns = Map.union sm (eExtraTSyns env) + , eExtraTypes = Map.union (fmap (\(TypedTerm s _) -> s) tm) (eExtraTypes env) + , eTermEnv = Map.union (fmap (\(TypedTerm _ t) -> t) tm) (eTermEnv env) + } + where + addName name = MN.shadowing (MN.singletonE (P.mkQual modName (MN.nameIdent name)) name) + addTSyn name = MN.shadowing (MN.singletonT (P.mkQual modName (MN.nameIdent name)) name) + +lookupCryptolModule :: CryptolModule -> String -> IO TypedTerm +lookupCryptolModule (CryptolModule _ tm) name = + case Map.lookup (packIdent name) (Map.mapKeys MN.nameIdent tm) of + Nothing -> fail $ "Binding not found: " ++ name + Just t -> return t + +-------------------------------------------------------------------------------- + +importModule :: + (?fileReader :: FilePath -> IO ByteString) => + SharedContext {- ^ Shared context for creating terms -} -> + CryptolEnv {- ^ Extend this environment -} -> + Either FilePath P.ModName {- ^ Where to find the module -} -> + Maybe P.ModName {- ^ Name qualifier -} -> + ImportVisibility {- ^ What visibility to give symbols from this module -} -> + Maybe P.ImportSpec {- ^ What to import -} -> + IO CryptolEnv +importModule sc env src as vis imps = do + let modEnv = eModuleEnv env + (m, modEnv') <- + liftModuleM modEnv $ + case src of + Left path -> MB.loadModuleByPath path + Right mn -> snd <$> MB.loadModuleFrom True (MM.FromModule mn) + checkNotParameterized m + + -- Regenerate SharedTerm environment. + oldCryEnv <- mkCryEnv env + let oldModNames = map ME.lmName $ ME.lmLoadedModules $ ME.meLoadedModules modEnv + let isNew m' = T.mName m' `notElem` oldModNames + let newModules = filter isNew $ map ME.lmModule $ ME.lmLoadedModules $ ME.meLoadedModules modEnv' + let newDeclGroups = concatMap T.mDecls newModules + newCryEnv <- C.importTopLevelDeclGroups sc oldCryEnv newDeclGroups + newTermEnv <- traverse (\(t, j) -> incVars sc 0 j t) (C.envE newCryEnv) + + return env { eImports = (vis, P.Import (T.mName m) as imps) : eImports env + , eModuleEnv = modEnv' + , eTermEnv = newTermEnv } + +bindIdent :: Ident -> CryptolEnv -> (T.Name, CryptolEnv) +bindIdent ident env = (name, env') + where + modEnv = eModuleEnv env + supply = ME.meSupply modEnv + fixity = Nothing + (name, supply') = MN.mkDeclared interactiveName MN.UserName ident fixity P.emptyRange supply + modEnv' = modEnv { ME.meSupply = supply' } + env' = env { eModuleEnv = modEnv' } + +bindTypedTerm :: (Ident, TypedTerm) -> CryptolEnv -> CryptolEnv +bindTypedTerm (ident, TypedTerm schema trm) env = + env' { eExtraNames = MR.shadowing (MN.singletonE pname name) (eExtraNames env) + , eExtraTypes = Map.insert name schema (eExtraTypes env) + , eTermEnv = Map.insert name trm (eTermEnv env) + } + where + pname = P.mkUnqual ident + (name, env') = bindIdent ident env + +bindType :: (Ident, T.Schema) -> CryptolEnv -> CryptolEnv +bindType (ident, T.Forall [] [] ty) env = + env' { eExtraNames = MR.shadowing (MN.singletonT pname name) (eExtraNames env) + , eExtraTSyns = Map.insert name tysyn (eExtraTSyns env) + } + where + pname = P.mkUnqual ident + (name, env') = bindIdent ident env + tysyn = T.TySyn name [] [] ty Nothing +bindType _ env = env -- only monomorphic types may be bound + +bindInteger :: (Ident, Integer) -> CryptolEnv -> CryptolEnv +bindInteger (ident, n) env = + env' { eExtraNames = MR.shadowing (MN.singletonT pname name) (eExtraNames env) + , eExtraTSyns = Map.insert name tysyn (eExtraTSyns env) + } + where + pname = P.mkUnqual ident + (name, env') = bindIdent ident env + tysyn = T.TySyn name [] [] (T.tNum n) Nothing + +-------------------------------------------------------------------------------- + +resolveIdentifier :: + (?fileReader :: FilePath -> IO ByteString) => + CryptolEnv -> Text -> IO (Maybe T.Name) +resolveIdentifier env nm = + case splitOn (pack "::") nm of + [] -> pure Nothing + [i] -> doResolve (P.UnQual (C.mkIdent i)) + xs -> let (qs,i) = (init xs, last xs) + in doResolve (P.Qual (C.packModName qs) (C.mkIdent i)) + where + modEnv = eModuleEnv env + nameEnv = getNamingEnv env + + doResolve pnm = + SMT.withSolver (ME.meSolverConfig modEnv) $ \s -> + do let minp = MM.ModuleInput True (pure defaultEvalOpts) ?fileReader modEnv + (res, _ws) <- MM.runModuleM (minp s) $ + MM.interactive (MB.rename interactiveName nameEnv (MR.renameVar pnm)) + case res of + Left _ -> pure Nothing + Right (x,_) -> pure (Just x) + + +parseTypedTerm :: + (?fileReader :: FilePath -> IO ByteString) => + SharedContext -> CryptolEnv -> InputText -> IO TypedTerm +parseTypedTerm sc env input = do + let modEnv = eModuleEnv env + + -- Parse + pexpr <- ioParseExpr input + + ((expr, schema), modEnv') <- liftModuleM modEnv $ do + + -- Eliminate patterns + npe <- MM.interactive (MB.noPat pexpr) + + -- Resolve names + let nameEnv = getNamingEnv env + re <- MM.interactive (MB.rename interactiveName nameEnv (MR.rename npe)) + + -- Infer types + let ifDecls = getAllIfaceDecls modEnv + let range = fromMaybe P.emptyRange (P.getLoc re) + prims <- MB.getPrimMap + -- noIfaceParams because we don't support functors yet + tcEnv <- MB.genInferInput range prims MI.noIfaceParams ifDecls + let tcEnv' = tcEnv { TM.inpVars = Map.union (eExtraTypes env) (TM.inpVars tcEnv) + , TM.inpTSyns = Map.union (eExtraTSyns env) (TM.inpTSyns tcEnv) + } + + out <- MM.io (T.tcExpr re tcEnv') + MM.interactive (runInferOutput out) + + let env' = env { eModuleEnv = modEnv' } + + -- Translate + trm <- translateExpr sc env' expr + return (TypedTerm schema trm) + +parseDecls :: + (?fileReader :: FilePath -> IO ByteString) => + SharedContext -> CryptolEnv -> InputText -> IO CryptolEnv +parseDecls sc env input = do + let modEnv = eModuleEnv env + let ifaceDecls = getAllIfaceDecls modEnv + + -- Parse + (decls :: [P.Decl P.PName]) <- ioParseDecls input + + (tmodule, modEnv') <- liftModuleM modEnv $ do + + -- Eliminate patterns + (npdecls :: [P.Decl P.PName]) <- MM.interactive (MB.noPat decls) + + -- Convert from 'Decl' to 'TopDecl' so that types will be generalized + let topdecls = [ P.Decl (P.TopLevel P.Public Nothing d) | d <- npdecls ] + + -- Label each TopDecl with the "interactive" module for unique name generation + let (mdecls :: [MN.InModule (P.TopDecl P.PName)]) = map (MN.InModule interactiveName) topdecls + nameEnv1 <- MN.liftSupply (MN.namingEnv' mdecls) + + -- Resolve names + let nameEnv = nameEnv1 `MR.shadowing` getNamingEnv env + (rdecls :: [P.TopDecl T.Name]) <- MM.interactive (MB.rename interactiveName nameEnv (traverse MR.rename topdecls)) + + -- Create a Module to contain the declarations + let rmodule = P.Module { P.mName = P.Located P.emptyRange interactiveName + , P.mInstance = Nothing + , P.mImports = [] + , P.mDecls = rdecls + } + + -- Infer types + let range = fromMaybe P.emptyRange (P.getLoc rdecls) + prims <- MB.getPrimMap + -- noIfaceParams because we don't support functors yet + tcEnv <- MB.genInferInput range prims MI.noIfaceParams ifaceDecls + let tcEnv' = tcEnv { TM.inpVars = Map.union (eExtraTypes env) (TM.inpVars tcEnv) + , TM.inpTSyns = Map.union (eExtraTSyns env) (TM.inpTSyns tcEnv) + } + + out <- MM.io (TM.runInferM tcEnv' (TI.inferModule rmodule)) + tmodule <- MM.interactive (runInferOutput out) + return tmodule + + -- Add new type synonyms and their name bindings to the environment + let syns' = Map.union (eExtraTSyns env) (T.mTySyns tmodule) + let addName name = MR.shadowing (MN.singletonT (P.mkUnqual (MN.nameIdent name)) name) + let names' = foldr addName (eExtraNames env) (Map.keys (T.mTySyns tmodule)) + let env' = env { eModuleEnv = modEnv', eExtraNames = names', eExtraTSyns = syns' } + + -- Translate + let dgs = T.mDecls tmodule + translateDeclGroups sc env' dgs + +parseSchema :: + (?fileReader :: FilePath -> IO ByteString) => + CryptolEnv -> InputText -> IO T.Schema +parseSchema env input = do + let modEnv = eModuleEnv env + + -- Parse + pschema <- ioParseSchema input + + fmap fst $ liftModuleM modEnv $ do + + -- Resolve names + let nameEnv = getNamingEnv env + rschema <- MM.interactive (MB.rename interactiveName nameEnv (MR.rename pschema)) + + let ifDecls = getAllIfaceDecls modEnv + let range = fromMaybe P.emptyRange (P.getLoc rschema) + prims <- MB.getPrimMap + -- noIfaceParams because we don't support functors yet + tcEnv <- MB.genInferInput range prims MI.noIfaceParams ifDecls + let tcEnv' = tcEnv { TM.inpTSyns = Map.union (eExtraTSyns env) (TM.inpTSyns tcEnv) } + let infer = + case rschema of + P.Forall [] [] t _ -> do + let k = Nothing -- allow either kind KNum or KType + (t', goals) <- TM.collectGoals $ TK.checkType t k + return (T.Forall [] [] t', goals) + _ -> TK.checkSchema TM.AllowWildCards rschema + out <- MM.io (TM.runInferM tcEnv' infer) + (schema, _goals) <- MM.interactive (runInferOutput out) + --mapM_ (MM.io . print . TP.ppWithNames TP.emptyNameMap) goals + return (schemaNoUser schema) + +declareName :: + (?fileReader :: FilePath -> IO ByteString) => + CryptolEnv -> P.ModName -> String -> IO (T.Name, CryptolEnv) +declareName env mname input = do + let pname = P.mkUnqual (packIdent input) + let modEnv = eModuleEnv env + (cname, modEnv') <- + liftModuleM modEnv $ MM.interactive $ + MN.liftSupply (MN.mkDeclared mname MN.UserName (P.getIdent pname) Nothing P.emptyRange) + let env' = env { eModuleEnv = modEnv' } + return (cname, env') + +typeNoUser :: T.Type -> T.Type +typeNoUser t = + case t of + T.TCon tc ts -> T.TCon tc (map typeNoUser ts) + T.TVar {} -> t + T.TUser _ _ ty -> typeNoUser ty + T.TRec fields -> T.TRec (fmap typeNoUser fields) + T.TNewtype nt ts -> T.TNewtype nt (fmap typeNoUser ts) + +schemaNoUser :: T.Schema -> T.Schema +schemaNoUser (T.Forall params props ty) = T.Forall params props (typeNoUser ty) + +------------------------------------------------------------ + +liftModuleM :: + (?fileReader :: FilePath -> IO ByteString) => + ME.ModuleEnv -> MM.ModuleM a -> IO (a, ME.ModuleEnv) +liftModuleM env m = + do let minp = MM.ModuleInput True (pure defaultEvalOpts) ?fileReader env + SMT.withSolver (ME.meSolverConfig env) $ \s -> + MM.runModuleM (minp s) m >>= moduleCmdResult + +defaultEvalOpts :: E.EvalOpts +defaultEvalOpts = E.EvalOpts quietLogger E.defaultPPOpts + +moduleCmdResult :: M.ModuleRes a -> IO (a, ME.ModuleEnv) +moduleCmdResult (res, ws) = do + mapM_ (print . pp) (map suppressDefaulting ws) + case res of + Right (a, me) -> return (a, me) + Left err -> fail $ "Cryptol error:\n" ++ show (pp err) -- X.throwIO (ModuleSystemError err) + where + suppressDefaulting :: MM.ModuleWarning -> MM.ModuleWarning + suppressDefaulting w = + case w of + MM.TypeCheckWarnings nm xs -> MM.TypeCheckWarnings nm (filter (notDefaulting . snd) xs) + MM.RenamerWarnings xs -> MM.RenamerWarnings xs + + notDefaulting :: TE.Warning -> Bool + notDefaulting (TE.DefaultingTo {}) = False + notDefaulting _ = True diff --git a/cryptol-saw-core/src/Verifier/SAW/TypedTerm.hs b/cryptol-saw-core/src/Verifier/SAW/TypedTerm.hs new file mode 100644 index 0000000000..e166d024ae --- /dev/null +++ b/cryptol-saw-core/src/Verifier/SAW/TypedTerm.hs @@ -0,0 +1,169 @@ +{- | +Module : SAWScript.TypedTerm +Description : SAW-Core terms paired with Cryptol types. +License : BSD3 +Maintainer : huffman +Stability : provisional +-} +module Verifier.SAW.TypedTerm where + +import Control.Monad (foldM) +import Data.Map (Map) +import qualified Data.Map as Map + +import Cryptol.ModuleSystem.Name (nameIdent) +import qualified Cryptol.TypeCheck.AST as C +import Cryptol.Utils.PP (pretty) +import qualified Cryptol.Utils.Ident as C (mkIdent) +import qualified Cryptol.Utils.RecordMap as C (recordFromFields) + +import Verifier.SAW.Cryptol (scCryptolType) +import Verifier.SAW.FiniteValue +import Verifier.SAW.Recognizer (asExtCns) +import Verifier.SAW.SharedTerm + +-- Typed terms ----------------------------------------------------------------- + +-- | Within SAWScript, we represent an object language term as a +-- SAWCore shared term paired with a Cryptol type schema. The Cryptol +-- type is used for type inference/checking of inline Cryptol +-- expressions. + +data TypedTerm = + TypedTerm + { ttSchema :: C.Schema + , ttTerm :: Term + } + deriving Show + +ttTermLens :: Functor f => (Term -> f Term) -> TypedTerm -> f TypedTerm +ttTermLens f tt = tt `seq` fmap (\x -> tt{ttTerm = x}) (f (ttTerm tt)) + +-- | Deprecated. +mkTypedTerm :: SharedContext -> Term -> IO TypedTerm +mkTypedTerm sc trm = do + ty <- scTypeOf sc trm + ct <- scCryptolType sc ty + return $ TypedTerm (C.Forall [] [] ct) trm + +-- | Apply a function-typed 'TypedTerm' to an argument. This operation +-- fails if the first 'TypedTerm' does not have a monomorphic function +-- type. +applyTypedTerm :: SharedContext -> TypedTerm -> TypedTerm -> IO TypedTerm +applyTypedTerm sc (TypedTerm schema1 t1) (TypedTerm _schema2 t2) = + case C.tIsFun =<< C.isMono schema1 of + Nothing -> fail "applyTypedTerm: not a function type" + Just (_, cty') -> TypedTerm (C.tMono cty') <$> scApply sc t1 t2 + +-- | Apply a 'TypedTerm' to a list of arguments. This operation fails +-- if the first 'TypedTerm' does not have a function type of +-- sufficient arity. +applyTypedTerms :: SharedContext -> TypedTerm -> [TypedTerm] -> IO TypedTerm +applyTypedTerms sc = foldM (applyTypedTerm sc) + +-- | Create an abstract defined constant with the specified name and body. +defineTypedTerm :: SharedContext -> String -> TypedTerm -> IO TypedTerm +defineTypedTerm sc name (TypedTerm schema t) = + do ty <- scTypeOf sc t + TypedTerm schema <$> scConstant sc name t ty + +-- | Make a tuple value from a list of 'TypedTerm's. This operation +-- fails if any 'TypedTerm' in the list has a polymorphic type. +tupleTypedTerm :: SharedContext -> [TypedTerm] -> IO TypedTerm +tupleTypedTerm sc tts = + case traverse (C.isMono . ttSchema) tts of + Nothing -> fail "tupleTypedTerm: invalid polymorphic term" + Just ctys -> + TypedTerm (C.tMono (C.tTuple ctys)) <$> scTuple sc (map ttTerm tts) + +-- | Given a 'TypedTerm' with a tuple type, return a list of its +-- projected components. This operation fails if the 'TypedTerm' does +-- not have a tuple type. +destTupleTypedTerm :: SharedContext -> TypedTerm -> IO [TypedTerm] +destTupleTypedTerm sc (TypedTerm schema t) = + case C.tIsTuple =<< C.isMono schema of + Nothing -> fail "asTupleTypedTerm: not a tuple type" + Just ctys -> + do let len = length ctys + let idxs = take len [1 ..] + ts <- traverse (\i -> scTupleSelector sc t i len) idxs + pure $ zipWith TypedTerm (map C.tMono ctys) ts + +-- First order types and values ------------------------------------------------ + +cryptolTypeOfFirstOrderType :: FirstOrderType -> C.Type +cryptolTypeOfFirstOrderType fot = + case fot of + FOTBit -> C.tBit + FOTInt -> C.tInteger + FOTIntMod n -> C.tIntMod (C.tNum n) + FOTVec n t -> C.tSeq (C.tNum n) (cryptolTypeOfFirstOrderType t) + -- NB, special case, don't produce 1-tuples + FOTTuple [x] -> cryptolTypeOfFirstOrderType x + FOTTuple ts -> C.tTuple (map cryptolTypeOfFirstOrderType ts) + FOTArray a b -> + C.tArray + (cryptolTypeOfFirstOrderType a) + (cryptolTypeOfFirstOrderType b) + FOTRec m -> + C.tRec $ + C.recordFromFields $ + [ (C.mkIdent l, cryptolTypeOfFirstOrderType t) + | (l, t) <- Map.assocs m ] + +typedTermOfFirstOrderValue :: SharedContext -> FirstOrderValue -> IO TypedTerm +typedTermOfFirstOrderValue sc fov = + do let fot = firstOrderTypeOf fov + let cty = cryptolTypeOfFirstOrderType fot + t <- scFirstOrderValue sc fov + pure $ TypedTerm (C.tMono cty) t + +-- Typed external constants ---------------------------------------------------- + +data TypedExtCns = + TypedExtCns + { tecType :: C.Type + , tecExt :: ExtCns Term + } + deriving Show + +-- | Recognize 'TypedTerm's that are external constants. +asTypedExtCns :: TypedTerm -> Maybe TypedExtCns +asTypedExtCns (TypedTerm schema t) = + do cty <- C.isMono schema + ec <- asExtCns t + pure $ TypedExtCns cty ec + +-- | Make a 'TypedTerm' from a 'TypedExtCns'. +typedTermOfExtCns :: SharedContext -> TypedExtCns -> IO TypedTerm +typedTermOfExtCns sc (TypedExtCns cty ec) = + TypedTerm (C.tMono cty) <$> scExtCns sc ec + +abstractTypedExts :: SharedContext -> [TypedExtCns] -> TypedTerm -> IO TypedTerm +abstractTypedExts sc tecs (TypedTerm (C.Forall params props ty) trm) = + do let tys = map tecType tecs + let exts = map tecExt tecs + let ty' = foldr C.tFun ty tys + trm' <- scAbstractExts sc exts trm + pure $ TypedTerm (C.Forall params props ty') trm' + +-- Typed modules --------------------------------------------------------------- + +-- | In SAWScript, we can refer to a Cryptol module as a first class +-- value. These are represented simply as maps from names to typed +-- terms. + +data CryptolModule = + CryptolModule (Map C.Name C.TySyn) (Map C.Name TypedTerm) + +showCryptolModule :: CryptolModule -> String +showCryptolModule (CryptolModule sm tm) = + unlines $ + (if Map.null sm then [] else + "Type Synonyms" : "=============" : map showTSyn (Map.elems sm) ++ [""]) ++ + "Symbols" : "=======" : map showBinding (Map.assocs tm) + where + showTSyn (C.TySyn name params _props rhs _doc) = + " " ++ unwords (pretty (nameIdent name) : map pretty params) ++ " = " ++ pretty rhs + showBinding (name, TypedTerm schema _) = + " " ++ pretty (nameIdent name) ++ " : " ++ pretty schema diff --git a/cryptol-saw-core/test/CryptolVerifierTC.hs b/cryptol-saw-core/test/CryptolVerifierTC.hs new file mode 100644 index 0000000000..e5bffe455b --- /dev/null +++ b/cryptol-saw-core/test/CryptolVerifierTC.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE QuasiQuotes #-} + +module Main where + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.Map as Map + +import Text.Heredoc (there) + +import qualified Cryptol.ModuleSystem.Name as N +import qualified Cryptol.Utils.Ident as N + +import qualified Verifier.SAW.Cryptol as C +import Verifier.SAW.SharedTerm +import qualified Verifier.SAW.SCTypeCheck as TC +import qualified Verifier.SAW.Cryptol.Prelude as C +import qualified Verifier.SAW.CryptolEnv as CEnv + +main :: IO () +main = + do sc <- mkSharedContext + C.scLoadPreludeModule sc + C.scLoadCryptolModule sc + putStrLn "Loaded Cryptol.sawcore!" + let ?fileReader = BS.readFile + cenv0 <- CEnv.initCryptolEnv sc + putStrLn "Translated Cryptol.cry!" + cenv1 <- CEnv.importModule sc cenv0 (Right N.floatName) Nothing CEnv.OnlyPublic Nothing + putStrLn "Translated Float.cry!" + cenv2 <- CEnv.importModule sc cenv1 (Right N.arrayName) Nothing CEnv.OnlyPublic Nothing + putStrLn "Translated Array.cry!" + cenv3 <- CEnv.parseDecls sc cenv2 (CEnv.InputText superclassContents "superclass.cry" 1 1) + putStrLn "Translated superclass.cry!" + cenv4 <- CEnv.parseDecls sc cenv3 (CEnv.InputText instanceContents "instance.cry" 1 1) + putStrLn "Translated instance.cry!" + mapM_ (checkTranslation sc) $ Map.assocs (CEnv.eTermEnv cenv4) + putStrLn "Checked all terms!" + +checkTranslation :: SharedContext -> (N.Name, Term) -> IO () +checkTranslation sc (name, term) = + do result <- TC.scTypeCheck sc Nothing term + case result of + Right _ -> pure () + Left err -> + do putStrLn $ "Type error when checking " ++ show (N.unpackIdent (N.nameIdent name)) + putStrLn $ unlines $ TC.prettyTCError err + fail "internal type error" + +superclassContents :: String +superclassContents = [there|test/superclass.cry|] + +instanceContents :: String +instanceContents = [there|test/instance.cry|] diff --git a/cryptol-saw-core/test/instance.cry b/cryptol-saw-core/test/instance.cry new file mode 100644 index 0000000000..faadcda03a --- /dev/null +++ b/cryptol-saw-core/test/instance.cry @@ -0,0 +1,386 @@ +//////////////////////////////////////////////////////////////////////////////// +// Zero + +/* instance Zero Bit */ +zeroBit : Bit +zeroBit = zero + +/* instance Zero Integer */ +zeroInteger : Integer +zeroInteger = zero + +/* instance Zero Rational */ +zeroRational : Rational +zeroRational = zero + +/* instance (fin n, n >= 1) => Zero (Z n) */ +zeroZ : {n} (fin n, n >= 1) => Z n +zeroZ = zero + +/* instance Zero [n] */ +zeroWord : {n} [n] +zeroWord = zero + +/* instance (Zero a) => Zero [n]a */ +zeroSeq : {n, a} (Zero a) => [n]a +zeroSeq = zero + +/* instance (ValidFloat e p) => Zero (Float e p) */ +zeroFloat : {e, p} (ValidFloat e p) => Float e p +zeroFloat = zero + +/* instance (Zero b) => Zero (a -> b) */ +zeroFun : {a, b} (Zero b) => a -> b +zeroFun = zero + +/* instance Zero () */ +zeroUnit : () +zeroUnit = zero + +/* instance (Zero a, Zero b, ...) => Zero (a, b, ...) */ +zeroTuple : {a, b} (Zero a, Zero b) => (a, b) +zeroTuple = zero + +/* instance Zero {} */ +zeroEmpty : {} +zeroEmpty = zero + +/* instance (Zero a, Zero b, ...) => Zero { x : a, y : b, ... } */ +zeroRecord : {a, b} (Zero a, Zero b) => {x : a, y : b} +zeroRecord = zero + +//////////////////////////////////////////////////////////////////////////////// +// Logic + +/* instance Logic Bit */ +logicBit : Bit -> Bit +logicBit = complement + +/* instance Logic [n] */ +logicWord : {n} [n] -> [n] +logicWord = complement + +/* instance (Logic a) => Logic [n]a */ +logicSeq : {n, a} (Logic a) => [n]a -> [n]a +logicSeq = complement + +/* instance (Logic b) => Logic (a -> b) */ +logicFun : {a, b} (Logic b) => (a -> b) -> (a -> b) +logicFun = complement + +/* instance Logic () */ +logicUnit : () -> () +logicUnit = complement + +/* instance (Logic a, Logic b, ...) => Logic (a, b, ...) */ +logicTuple : {a, b} (Logic a, Logic b) => (a, b) -> (a, b) +logicTuple = complement + +/* instance Logic {} */ +logicEmpty : {} -> {} +logicEmpty = complement + +/* instance (Logic a, Logic b, ...) => Logic { x : a, y : b, ... } */ +logicRecord : {a, b} (Logic a, Logic b) => {x : a, y : b} -> {x : a, y : b} +logicRecord = complement + +//////////////////////////////////////////////////////////////////////////////// +// Ring + +/* instance Ring Integer */ +ringInteger : Integer -> Integer +ringInteger = negate + +/* instance Ring Rational */ +ringRational : Rational -> Rational +ringRational = negate + +/* instance (fin n, n >= 1) => Ring (Z n) */ +ringZ : {n} (fin n, n >= 1) => Z n -> Z n +ringZ = negate + +/* instance (fin n) => Ring [n] */ +ringWord : {n} (fin n) => [n] -> [n] +ringWord = negate + +// NOTE: 'instance Ring a => Ring [n]a' holds for any type 'a' +// distinct from 'Bit'. + +/* instance Ring [n]Integer */ +ringSeqInteger : {n} [n]Integer -> [n]Integer +ringSeqInteger = negate + +/* instance Ring [n]Rational */ +ringSeqRational : {n} [n]Rational -> [n]Rational +ringSeqRational = negate + +/* instance (fin k, k >= 1) => Ring [n](Z k) */ +ringSeqZ : {n, k} (fin k, k >= 1) => [n](Z k) -> [n](Z k) +ringSeqZ = negate + +/* instance (Ring [k]a) => Ring [n][k]a */ +ringSeqSeq : {n, k, a} (Ring ([k]a)) => [n][k]a -> [n][k]a +ringSeqSeq = negate + +/* instance (Ring b) => Ring [n](a -> b) */ +ringSeqFun : {n, a, b} (Ring b) => [n](a -> b) -> [n](a -> b) +ringSeqFun = negate + +/* instance Ring [n]() */ +ringSeqUnit : {n} [n]() -> [n]() +ringSeqUnit = negate + +/* instance (Ring a, Ring b) => Ring [n](a, b) */ +ringSeqTuple : {n, a, b} (Ring a, Ring b) => [n](a, b) -> [n](a, b) +ringSeqTuple = negate + +/* instance Ring [n]{} */ +ringSeqEmpty : {n} [n]{} -> [n]{} +ringSeqEmpty = negate + +/* instance (Ring a, Ring b) => Ring [n]{x : a, y : b} */ +ringSeqRecord : {n, a, b} (Ring a, Ring b) => [n]{x : a, y : b} -> [n]{x : a, y : b} +ringSeqRecord = negate + +/* instance (ValidFloat e p) => Ring (Float e p) */ +ringFloat : {e, p} (ValidFloat e p) => Float e p -> Float e p +ringFloat = negate + +/* instance (Ring b) => Ring (a -> b) */ +ringFun : {a, b} (Ring b) => (a -> b) -> (a -> b) +ringFun = negate + +/* instance Ring () */ +ringUnit : () -> () +ringUnit = negate + +/* instance (Ring a, Ring b, ...) => Ring (a, b, ...) */ +ringTuple : {a, b} (Ring a, Ring b) => (a, b) -> (a, b) +ringTuple = negate + +/* instance Ring {} */ +ringEmpty : {} -> {} +ringEmpty = negate + +/* instance (Ring a, Ring b, ...) => Ring { x : a, y : b, ... } */ +ringRecord : {a, b} (Ring a, Ring b) => {x : a, y : b} -> {x : a, y : b} +ringRecord = negate + +//////////////////////////////////////////////////////////////////////////////// +// Integral + +/* instance Integral Integer */ +integralInteger : Integer -> Integer -> Integer +integralInteger = (%) + +/* instance (fin n) => Integral [n] */ +integralWord : {n} (fin n) => [n] -> [n] -> [n] +integralWord = (%) + +//////////////////////////////////////////////////////////////////////////////// +// Field + +/* instance Field Rational */ +fieldRational : Rational -> Rational +fieldRational = recip + +/* instance (ValidFloat e p) => Field (Float e p) */ +fieldFloat : {e, p} (ValidFloat e p) => Float e p -> Float e p +fieldFloat = recip + +/* instance (prime p) => Field (Z p) */ +fieldZ : {p} prime p => Z p -> Z p +fieldZ = recip + +//////////////////////////////////////////////////////////////////////////////// +// Round + +/* instance Round Rational */ +roundRational : Rational -> Integer +roundRational = floor + +/* instance (ValidFloat e p) => Round (Float e p) */ +roundFloat : {e, p} (ValidFloat e p) => Float e p -> Integer +roundFloat = floor + +//////////////////////////////////////////////////////////////////////////////// +// Eq + +/* instance Eq Bit */ +eqBit : Bit -> Bit -> Bit +eqBit = (==) + +/* instance Eq Integer */ +eqInteger : Integer -> Integer -> Bit +eqInteger = (==) + +/* instance Eq Rational */ +eqRational : Rational -> Rational -> Bit +eqRational = (==) + +/* instance (fin n, n >= 1) => Eq (Z n) */ +eqZ : {n} (fin n, n >= 1) => Z n -> Z n -> Bit +eqZ = (==) + +/* instance (fin n) => Eq [n] */ +eqWord : {n} (fin n) => [n] -> [n] -> Bit +eqWord = (==) + +/* instance (fin n, Eq a) => Eq [n]a */ +eqSeq : {n, a} (fin n, Eq a) => [n]a -> [n]a -> Bit +eqSeq = (==) + +/* instance (ValidFloat e p) => Eq (Float e p) */ +eqFloat : {e, p} (ValidFloat e p) => Float e p -> Float e p -> Bit +eqFloat = (==) + +/* instance Eq () */ +eqUnit : () -> () -> Bit +eqUnit = (==) + +/* instance (Eq a, Eq b, ...) => Eq (a, b, ...) */ +eqTuple : {a, b} (Eq a, Eq b) => (a, b) -> (a, b) -> Bit +eqTuple = (==) + +/* instance Eq {} */ +eqEmpty : {} -> {} -> Bit +eqEmpty = (==) + +/* instance (Eq a, Eq b, ...) => Eq { x : a, y : b, ... } */ +eqRecord : {a, b} (Eq a, Eq b) => {x : a, y : b} -> {x : a, y : b} -> Bit +eqRecord = (==) + +//////////////////////////////////////////////////////////////////////////////// +// Cmp + +/* instance Cmp Bit */ +cmpBit : Bit -> Bit -> Bit +cmpBit = (<) + +/* instance Cmp Integer */ +cmpInteger : Integer -> Integer -> Bit +cmpInteger = (<) + +/* instance Cmp Rational */ +cmpRational : Rational -> Rational -> Bit +cmpRational = (<) + +/* instance (fin n) => Cmp [n] */ +cmpWord : {n} (fin n) => [n] -> [n] -> Bit +cmpWord = (<) + +/* instance (fin n, Cmp a) => Cmp [n]a */ +cmpSeq : {n, a} (fin n, Cmp a) => [n]a -> [n]a -> Bit +cmpSeq = (<) + +/* instance (ValidFloat e p) => Cmp (Float e p) */ +cmpFloat : {e, p} (ValidFloat e p) => Float e p -> Float e p -> Bit +cmpFloat = (<) + +/* instance Cmp () */ +cmpUnit : () -> () -> Bit +cmpUnit = (<) + +/* instance (Cmp a, Cmp b, ...) => Cmp (a, b, ...) */ +cmpTuple : {a, b} (Cmp a, Cmp b) => (a, b) -> (a, b) -> Bit +cmpTuple = (<) + +/* instance Cmp {} */ +cmpEmpty : {} -> {} -> Bit +cmpEmpty = (<) + +/* instance (Cmp a, Cmp b, ...) => Cmp { x : a, y : b, ... } */ +cmpRecord : {a, b} (Cmp a, Cmp b) => {x : a, y : b} -> {x : a, y : b} -> Bit +cmpRecord = (<) + +//////////////////////////////////////////////////////////////////////////////// +// Cmp + +/* instance (fin n, n >= 1) => SignedCmp [n] */ +signedCmpWord : {n} (fin n, n >= 1) => [n] -> [n] -> Bit +signedCmpWord = (<$) + +// NOTE: 'instance (fin n, SignedCmp a) => SignedCmp ([n]a)' holds for +// any type 'a' distinct from 'Bit'. + +/* instance (fin n, SignedCmp [k]a) => SignedCmp [n][k]a */ +signedCmpSeqSeq : {n, k, a} (fin n, SignedCmp ([k]a)) => [n][k]a -> [n][k]a -> Bit +signedCmpSeqSeq = (<$) + +/* instance (fin n) => SignedCmp [n]() */ +signedCmpSeqUnit : {n} (fin n) => [n]() -> [n]() -> Bit +signedCmpSeqUnit = (<$) + +/* instance (SignedCmp a, SignedCmp b) => SignedCmp [n](a, b) */ +signedCmpSeqTuple : {n, a, b} (fin n, SignedCmp a, SignedCmp b) => [n](a, b) -> [n](a, b) -> Bit +signedCmpSeqTuple = (<$) + +/* instance SignedCmp [n]{} */ +signedCmpSeqEmpty : {n} (fin n) => [n]{} -> [n]{} -> Bit +signedCmpSeqEmpty = (<$) + +/* instance (SignedCmp a, SignedCmp b) => SignedCmp [n]{x : a, y : b} */ +signedCmpSeqRecord : {n, a, b} (fin n, SignedCmp a, SignedCmp b) => [n]{x : a, y : b} -> [n]{x : a, y : b} -> Bit +signedCmpSeqRecord = (<$) + +/* instance SignedCmp () */ +signedCmpUnit : () -> () -> Bit +signedCmpUnit = (<$) + +/* instance (SignedCmp a, SignedCmp b, ...) => SignedCmp (a, b, ...) */ +signedCmpTuple : {a, b} (SignedCmp a, SignedCmp b) => (a, b) -> (a, b) -> Bit +signedCmpTuple = (<$) + +/* instance SignedCmp {} */ +signedCmpEmpty : {} -> {} -> Bit +signedCmpEmpty = (<$) + +/* instance (SignedCmp a, SignedCmp b, ...) => SignedCmp { x : a, y : b, ... } */ +signedCmpRecord : {a, b} (SignedCmp a, SignedCmp b) => {x : a, y : b} -> {x : a, y : b} -> Bit +signedCmpRecord = (<$) + +//////////////////////////////////////////////////////////////////////////////// +// Literal + +/* instance (1 >= val) => Literal val Bit */ +literalBit : {val} (1 >= val) => Bit +literalBit = `val + +/* instance (fin val) => Literal val Integer */ +literalInteger : {val} (fin val) => Integer +literalInteger = `val + +/* instance (fin val) => Literal val Rational */ +literalRational : {val} (fin val) => Rational +literalRational = `val + +/* instance (fin val, fin n, n >= 1, n > val) => Literal val (Z n) */ +literalZ : {val, n} (fin val, fin n, n >= 1, n > val) => Z n +literalZ = `val + +/* instance (fin val, fin n, n >= width val) => Literal val [n] */ +literalWord : {val, n} (fin val, fin n, n >= width val) => [n] +literalWord = `val + +//////////////////////////////////////////////////////////////////////////////// +// LiteralLessThan + +/* instance (2 >= val) => LiteralLessThan val Bit */ +literalLessThanBit : {val} (1 >= val) => [val]Bit +literalLessThanBit = [0.. [val]Integer +literalLessThanInteger = [0.. [val]Rational +literalLessThanRational = [0..= 1, n >= val) => LiteralLessThan val (Z n) */ +literalLessThanZ : {val, n} (fin n, n >= 1, n >= val) => [val](Z n) +literalLessThanZ = [0..= width val) => LiteralLessThan val [n] */ +literalLessThanWord : {val, n} (fin n, n >= lg2 val) => [val][n] +literalLessThanWord = [0.. a +zeroRing = zero + +zeroLogic : {a} (Logic a) => a +zeroLogic = zero + +zeroIntegral : {a} (Integral a) => a +zeroIntegral = zero + +zeroField : {a} (Field a) => a +zeroField = zero + +zeroRound : {a} (Round a) => a +zeroRound = zero + +fromIntIntegral : {a} (Integral a) => a +fromIntIntegral = fromInteger 42 + +fromIntField : {a} (Field a) => a +fromIntField = fromInteger 42 + +fromIntRound : {a} (Round a) => a +fromIntRound = fromInteger 42 + +recipRound : {a} (Round a) => a -> Integer +recipRound x = trunc (recip x) + +compareRound : {a} (Round a) => a -> a -> Bit +compareRound x y = x < y + +eqCmp : {a} (Cmp a) => a -> a -> Bit +eqCmp x y = x == y diff --git a/deps/saw-core b/deps/saw-core deleted file mode 160000 index 12a8f95cc6..0000000000 --- a/deps/saw-core +++ /dev/null @@ -1 +0,0 @@ -Subproject commit 12a8f95cc6eeac9d472fe6cc74f87e288ca97887 diff --git a/rme/LICENSE b/rme/LICENSE new file mode 100644 index 0000000000..06a2e7f483 --- /dev/null +++ b/rme/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2016, 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 names of the authors nor the names of other + 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/rme/README.md b/rme/README.md new file mode 100644 index 0000000000..efb342f113 --- /dev/null +++ b/rme/README.md @@ -0,0 +1,2 @@ +This directory contains the Haskell `rme` library, which provides a +Reed-Muller Expansion datatype for representing Boolean formulas. diff --git a/rme/rme.cabal b/rme/rme.cabal new file mode 100644 index 0000000000..f73c2fb4ae --- /dev/null +++ b/rme/rme.cabal @@ -0,0 +1,26 @@ +Name: rme +Version: 0.1 +License: BSD3 +License-file: LICENSE +Author: Galois, Inc. +Maintainer: huffman@galois.com +Copyright: (c) 2016 Galois Inc. +Category: Formal Methods +Build-type: Simple +cabal-version: >= 1.8 +Synopsis: Reed-Muller Expansion normal form for Boolean Formulas +Description: + A representation of the Algebraic Normal Form of boolean formulas + using the Reed-Muller Expansion. + +library + build-depends: + base == 4.*, + containers, + vector + hs-source-dirs: src + exposed-modules: + Data.RME + Data.RME.Base + Data.RME.Vector + GHC-options: -Wall -Werror -Wcompat diff --git a/rme/src/Data/RME.hs b/rme/src/Data/RME.hs new file mode 100644 index 0000000000..90bdb97b82 --- /dev/null +++ b/rme/src/Data/RME.hs @@ -0,0 +1,18 @@ +{- | +Module : Data.RME +Copyright : Galois, Inc. 2016 +License : BSD3 +Maintainer : huffman@galois.com +Stability : experimental +Portability : portable + +Reed-Muller Expansion normal form for Boolean Formulas. +-} + +module Data.RME + ( module Data.RME.Base + , module Data.RME.Vector + ) where + +import Data.RME.Base +import Data.RME.Vector diff --git a/rme/src/Data/RME/Base.hs b/rme/src/Data/RME/Base.hs new file mode 100644 index 0000000000..09b00e6b18 --- /dev/null +++ b/rme/src/Data/RME/Base.hs @@ -0,0 +1,184 @@ +{- | +Module : Data.RME.Base +Copyright : Galois, Inc. 2016 +License : BSD3 +Maintainer : huffman@galois.com +Stability : experimental +Portability : portable + +Reed-Muller Expansion normal form for Boolean Formulas. +-} + +module Data.RME.Base + ( RME + , true, false, lit + , constant, isBool + , compl, xor, conj, disj, iff, mux + , eval + , sat, allsat + , degree + , depth, size + , explode + ) where + +-- | Boolean formulas in Algebraic Normal Form, using a representation +-- based on the Reed-Muller expansion. + +-- Invariants: The last argument to a `Node` constructor should never +-- be `R0`. Also the `Int` arguments should strictly increase as you +-- go deeper in the tree. + +data RME = Node !Int !RME !RME | R0 | R1 + deriving (Eq, Show) + +-- | Evaluate formula with given variable assignment. +eval :: RME -> (Int -> Bool) -> Bool +eval anf v = + case anf of + R0 -> False + R1 -> True + Node n a b -> (eval a v) /= (v n && eval b v) + +-- | Normalizing constructor. +node :: Int -> RME -> RME -> RME +node _ a R0 = a +node n a b = Node n a b + +-- | Constant true formula. +true :: RME +true = R1 + +-- | Constant false formula. +false :: RME +false = R0 + +-- | Boolean constant formulas. +constant :: Bool -> RME +constant False = false +constant True = true + +-- | Test whether an RME formula is a constant boolean. +isBool :: RME -> Maybe Bool +isBool R0 = Just False +isBool R1 = Just True +isBool _ = Nothing + +-- | Boolean literals. +lit :: Int -> RME +lit n = Node n R0 R1 + +-- | Logical complement. +compl :: RME -> RME +compl R0 = R1 +compl R1 = R0 +compl (Node n a b) = Node n (compl a) b + +-- | Logical exclusive-or. +xor :: RME -> RME -> RME +xor R0 y = y +xor R1 y = compl y +xor x R0 = x +xor x R1 = compl x +xor x@(Node i a b) y@(Node j c d) + | i < j = Node i (xor a y) b + | j < i = Node j (xor x c) d + | otherwise = node i (xor a c) (xor b d) + +-- | Logical conjunction. +conj :: RME -> RME -> RME +conj R0 _ = R0 +conj R1 y = y +conj _ R0 = R0 +conj x R1 = x +conj x@(Node i a b) y@(Node j c d) + | i < j = node i (conj a y) (conj b y) + | j < i = node j (conj x c) (conj x d) + | otherwise = node i ac (xor ac (conj (xor a b) (xor c d))) + where ac = conj a c + +-- | Logical disjunction. +disj :: RME -> RME -> RME +disj R0 y = y +disj R1 _ = R1 +disj x R0 = x +disj _ R1 = R1 +disj x@(Node i a b) y@(Node j c d) + | i < j = node i (disj a y) (conj b (compl y)) + | j < i = node j (disj x c) (conj (compl x) d) + | otherwise = node i ac (xor ac (disj (xor a b) (xor c d))) + where ac = disj a c + +-- | Logical equivalence. +iff :: RME -> RME -> RME +iff x y = xor (compl x) y +{- +iff R0 y = compl y +iff R1 y = y +iff x R0 = compl x +iff x R1 = x +iff x@(Node i a b) y@(Node j c d) + | i < j = Node i (iff a y) b + | j < i = Node j (iff x c) d + | otherwise = node i (iff a c) (xor b d) +-} + +-- | Logical if-then-else. +mux :: RME -> RME -> RME -> RME +--mux w x y = xor (conj w x) (conj (compl w) y) +mux R0 _ y = y +mux R1 x _ = x +mux b x y = xor (conj b (xor x y)) y + +{- +mux R0 x y = y +mux R1 x y = x +mux w R0 y = conj (compl w) y +mux w R1 y = disj w y +mux w x R0 = conj w x +mux w x R1 = disj (compl w) x +mux w@(Node i a b) x@(Node j c d) y@(Node k e f) + | i < j && i < k = node i (mux a x y) (conj b (xor x y)) + | j < i && j < k = node i (mux w c y) (conj w d) + | k < i && k < j = node i (mux w x e) (conj (compl w) f) + | i == j && i < k = node i (mux a c y) _ +-} + +-- | Satisfiability checker. +sat :: RME -> Maybe [(Int, Bool)] +sat R0 = Nothing +sat R1 = Just [] +sat (Node n a b) = + case sat a of + Just xs -> Just ((n, False) : xs) + Nothing -> fmap ((n, True) :) (sat b) + +-- | List of all satisfying assignments. +allsat :: RME -> [[(Int, Bool)]] +allsat R0 = [] +allsat R1 = [[]] +allsat (Node n a b) = + map ((n, False) :) (allsat a) ++ map ((n, True) :) (allsat (xor a b)) + +-- | Maximum polynomial degree. +degree :: RME -> Int +degree R0 = 0 +degree R1 = 0 +degree (Node _ a b) = max (degree a) (1 + degree b) + +-- | Tree depth. +depth :: RME -> Int +depth R0 = 0 +depth R1 = 0 +depth (Node _ a b) = 1 + max (depth a) (depth b) + +-- | Tree size. +size :: RME -> Int +size R0 = 1 +size R1 = 1 +size (Node _ a b) = 1 + size a + size b + +-- | Convert to an explicit polynomial representation. +explode :: RME -> [[Int]] +explode R0 = [] +explode R1 = [[]] +explode (Node i a b) = explode a ++ map (i:) (explode b) diff --git a/rme/src/Data/RME/Vector.hs b/rme/src/Data/RME/Vector.hs new file mode 100644 index 0000000000..fa7f96ca09 --- /dev/null +++ b/rme/src/Data/RME/Vector.hs @@ -0,0 +1,286 @@ +{-# LANGUAGE BangPatterns #-} +{- | +Module : Data.RME.Vector +Copyright : Galois, Inc. 2016 +License : BSD3 +Maintainer : huffman@galois.com +Stability : experimental +Portability : portable + +Operations on big-endian vectors of RME formulas. +-} + +module Data.RME.Vector + ( RMEV + , eq, ule, ult, sle, slt + , neg, add, sub, mul + , udiv, urem, sdiv, srem + , pmul, pmod, pdiv + , integer + , popcount + , countLeadingZeros + , countTrailingZeros + ) where + +import Data.RME.Base (RME) +import qualified Data.RME.Base as RME + +import qualified Data.Bits as Bits +import Data.Vector (Vector) +import qualified Data.Vector as V + +type RMEV = Vector RME + +-- | Constant integer literals. +integer :: Int -> Integer -> RMEV +integer width x = V.reverse (V.generate width (RME.constant . Bits.testBit x)) + +-- | Bitvector equality. +eq :: RMEV -> RMEV -> RME +eq x y = V.foldr RME.conj RME.true (V.zipWith RME.iff x y) + +-- | Unsigned less-than-or-equal. +ule :: RMEV -> RMEV -> RME +ule xv yv = go (V.toList xv) (V.toList yv) + where + go (x : xs) (y : ys) = + let z = go xs ys + in RME.xor (RME.conj y z) (RME.conj (RME.compl x) (RME.xor y z)) + go _ _ = RME.true + +-- | Unsigned less-than. +ult :: RMEV -> RMEV -> RME +ult x y = RME.compl (ule y x) + +swap_sign :: RMEV -> RMEV +swap_sign x + | V.null x = x + | otherwise = V.singleton (RME.compl (V.head x)) V.++ V.tail x + +-- | Signed less-than-or-equal. +sle :: RMEV -> RMEV -> RME +sle x y = ule (swap_sign x) (swap_sign y) + +-- | Signed less-than. +slt :: RMEV -> RMEV -> RME +slt x y = ult (swap_sign x) (swap_sign y) + +-- | Big-endian bitvector increment with carry. +increment :: [RME] -> (RME, [RME]) +increment [] = (RME.true, []) +increment (x : xs) = (RME.conj x c, RME.xor x c : ys) + where (c, ys) = increment xs + +-- | Two's complement bitvector negation. +neg :: RMEV -> RMEV +neg x = V.fromList (snd (increment (map RME.compl (V.toList x)))) + +-- | 1-bit full adder. +full_adder :: RME -> RME -> RME -> (RME, RME) +full_adder a b c = (carry, RME.xor (RME.xor a b) c) + where carry = RME.xor (RME.conj a b) (RME.conj (RME.xor a b) c) + +-- | Big-endian ripple-carry adder. +ripple_carry_adder :: [RME] -> [RME] -> RME -> (RME, [RME]) +ripple_carry_adder [] _ c = (c, []) +ripple_carry_adder _ [] c = (c, []) +ripple_carry_adder (x : xs) (y : ys) c = (c'', z : zs) + where (c', zs) = ripple_carry_adder xs ys c + (c'', z) = full_adder x y c' + +-- | Two's complement bitvector addition. +add :: RMEV -> RMEV -> RMEV +add x y = + V.fromList (snd (ripple_carry_adder (V.toList x) (V.toList y) RME.false)) + +-- | Two's complement bitvector subtraction. +sub :: RMEV -> RMEV -> RMEV +sub x y = + V.fromList (snd (ripple_carry_adder (V.toList x) (map RME.compl (V.toList y)) RME.true)) + +-- | Two's complement bitvector multiplication. +mul :: RMEV -> RMEV -> RMEV +mul x y = V.foldl f zero y + where + zero = V.replicate (V.length x) RME.false + f acc c = V.zipWith (RME.mux c) (add acc2 x) acc2 + where acc2 = V.drop 1 (acc V.++ V.singleton RME.false) + +-- | Unsigned bitvector division. +udiv :: RMEV -> RMEV -> RMEV +udiv x y = fst (udivrem x y) + +-- | Unsigned bitvector remainder. +urem :: RMEV -> RMEV -> RMEV +urem x y = snd (udivrem x y) + +-- | Signed bitvector division. +sdiv :: RMEV -> RMEV -> RMEV +sdiv x y = fst (sdivrem x y) + +-- | Signed bitvector remainder. +srem :: RMEV -> RMEV -> RMEV +srem x y = snd (sdivrem x y) + +udivrem :: RMEV -> RMEV -> (RMEV, RMEV) +udivrem dividend divisor = divStep 0 RME.false initial + where + n :: Int + n = V.length dividend + + -- Given an n-bit dividend and divisor, 'initial' is the starting value of + -- the 2n-bit "remainder register" that carries both the quotient and remainder; + initial :: RMEV + initial = integer n 0 V.++ dividend + + divStep :: Int -> RME -> RMEV -> (RMEV, RMEV) + divStep i p rr | i == n = (q `shiftL1` p, r) + where (r, q) = V.splitAt n rr + divStep i p rr = divStep (i+1) b (V.zipWith (RME.mux b) (V.fromList s V.++ q) rs) + where rs = rr `shiftL1` p + (r, q) = V.splitAt n rs + -- Subtract the divisor from the left half of the "remainder register" + (b, s) = ripple_carry_adder (V.toList r) (map RME.compl (V.toList divisor)) RME.true + + shiftL1 :: RMEV -> RME -> RMEV + shiftL1 v e = V.tail v `V.snoc` e + +-- Perform udivrem on the absolute value of the operands. Then, negate the +-- quotient if the signs of the operands differ and make the sign of a nonzero +-- remainder to match that of the dividend. +sdivrem :: RMEV -> RMEV -> (RMEV, RMEV) +sdivrem dividend divisor = (q',r') + where + sign1 = V.head dividend + sign2 = V.head divisor + signXor = RME.xor sign1 sign2 + negWhen x c = V.zipWith (RME.mux c) (neg x) x + dividend' = negWhen dividend sign1 + divisor' = negWhen divisor sign2 + (q, r) = udivrem dividend' divisor' + q' = negWhen q signXor + r' = negWhen r sign1 + +popcount :: RMEV -> RMEV +popcount bits = if l == 0 then V.empty else (V.replicate (l-w-1) RME.false) <> pcnt + where + l = V.length bits + w = Bits.countTrailingZeros l -- log_2 rounded down, w+1 is enough bits to hold popcount + zs = V.replicate w RME.false + + pcnt = foldr1 add xs -- length is w+1 + xs = [ zs <> V.singleton b | b <- V.toList bits ] + +countTrailingZeros :: RMEV -> RMEV +countTrailingZeros bits = countLeadingZeros (V.reverse bits) + +-- Big endian convention means its easier to count leading zeros +countLeadingZeros :: RMEV -> RMEV +countLeadingZeros bits = if l == 0 then V.empty else (V.replicate (l-w-1) RME.false) <> (go 0 (V.toList bits)) + where + l = V.length bits + w = Bits.countTrailingZeros l -- log_2 rounded down, w+1 is enough bits to hold count + + go :: Integer -> [RME] -> Vector RME + go !i [] = integer (w+1) i + go !i (b:bs) = V.zipWith (RME.mux b) (integer (w+1) i) (go (i+1) bs) + +-- | Polynomial multiplication. Note that the algorithm works the same +-- no matter which endianness convention is used. Result length is +-- @max 0 (m+n-1)@, where @m@ and @n@ are the lengths of the inputs. +pmul :: RMEV -> RMEV -> RMEV +pmul x y = V.generate (max 0 (m + n - 1)) coeff + where + m = V.length x + n = V.length y + coeff k = foldr RME.xor RME.false + [ RME.conj (x V.! i) (y V.! j) | i <- [0 .. k], let j = k - i, i < m, j < n ] + +-- | Polynomial mod with symbolic modulus. Return value has length one +-- less than the length of the modulus. +-- This implementation is optimized for the (common) case where the modulus +-- is concrete. +pmod :: RMEV -> RMEV -> RMEV +pmod x y = findmsb (V.toList y) + where + findmsb :: [RME] -> RMEV + findmsb [] = V.replicate (V.length y - 1) RME.false -- division by zero + findmsb (c : cs) + | c == RME.true = usemask cs + | c == RME.false = findmsb cs + | otherwise = V.zipWith (RME.mux c) (usemask cs) (findmsb cs) + + usemask :: [RME] -> RMEV + usemask m = zext (V.fromList (go (V.length x - 1) p0 z0)) (V.length y - 1) + where + zext v r = V.replicate (r - V.length v) RME.false V.++ v + msize = length m + p0 = replicate (msize - 1) RME.false ++ [RME.true] + z0 = replicate msize RME.false + + next :: [RME] -> [RME] + next [] = [] + next (b : bs) = + let m' = map (RME.conj b) m + bs' = bs ++ [RME.false] + in zipWith RME.xor m' bs' + + go :: Int -> [RME] -> [RME] -> [RME] + go i p acc + | i < 0 = acc + | otherwise = + let px = map (RME.conj (x V.! i)) p + acc' = zipWith RME.xor px acc + p' = next p + in go (i-1) p' acc' + +-- | Polynomial division. Return value has length +-- equal to the first argument. +pdiv :: RMEV -> RMEV -> RMEV +pdiv x y = fst (pdivmod x y) + +-- Polynomial div/mod: resulting lengths are as in Cryptol. + +-- TODO: probably this function should be disentangled to only compute +-- division, given that we have a separate polynomial modulus algorithm. +pdivmod :: RMEV -> RMEV -> (RMEV, RMEV) +pdivmod x y = findmsb (V.toList y) + where + findmsb :: [RME] -> (RMEV, RMEV) + findmsb (c : cs) = muxPair c (usemask cs) (findmsb cs) + findmsb [] = (x, V.replicate (V.length y - 1) RME.false) -- division by zero + + usemask :: [RME] -> (RMEV, RMEV) + usemask mask = (q, r) + where + (qs, rs) = pdivmod_helper (V.toList x) mask + z = RME.false + qs' = map (const z) rs ++ qs + rs' = replicate (V.length y - 1 - length rs) z ++ rs + q = V.fromList qs' + r = V.fromList rs' + + muxPair :: RME -> (RMEV, RMEV) -> (RMEV, RMEV) -> (RMEV, RMEV) + muxPair c a b + | c == RME.true = a + | c == RME.false = b + | otherwise = (V.zipWith (RME.mux c) (fst a) (fst b), V.zipWith (RME.mux c) (snd a) (snd b)) + +-- Divide ds by (1 : mask), giving quotient and remainder. All +-- arguments and results are big-endian. Remainder has the same length +-- as mask (but limited by length ds); total length of quotient ++ +-- remainder = length ds. +pdivmod_helper :: [RME] -> [RME] -> ([RME], [RME]) +pdivmod_helper ds mask = go (length ds - length mask) ds + where + go :: Int -> [RME] -> ([RME], [RME]) + go n cs | n <= 0 = ([], cs) + go _ [] = error "Data.AIG.Operations.pdiv: impossible" + go n (c : cs) = (c : qs, rs) + where cs' = mux_add c cs mask + (qs, rs) = go (n - 1) cs' + + mux_add :: RME -> [RME] -> [RME] -> [RME] + mux_add c (x : xs) (y : ys) = RME.mux c (RME.xor x y) x : mux_add c xs ys + mux_add _ [] (_ : _ ) = error "pdiv: impossible" + mux_add _ xs [] = xs diff --git a/saw-core-aig/.gitignore b/saw-core-aig/.gitignore new file mode 100644 index 0000000000..8ee1bf9489 --- /dev/null +++ b/saw-core-aig/.gitignore @@ -0,0 +1 @@ +.stack-work diff --git a/saw-core-aig/LICENSE b/saw-core-aig/LICENSE new file mode 100644 index 0000000000..9e2f031c53 --- /dev/null +++ b/saw-core-aig/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2012-2016, 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 names of the authors nor the names of other + 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/saw-core-aig/README.md b/saw-core-aig/README.md new file mode 100644 index 0000000000..a70f295730 --- /dev/null +++ b/saw-core-aig/README.md @@ -0,0 +1,2 @@ +This repository contains a backend for the `saw-core` library that uses +the `aig` library for construction of And-Inverter Graphs (AIGs). diff --git a/saw-core-aig/Setup.hs b/saw-core-aig/Setup.hs new file mode 100644 index 0000000000..9a994af677 --- /dev/null +++ b/saw-core-aig/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/saw-core-aig/saw-core-aig.cabal b/saw-core-aig/saw-core-aig.cabal new file mode 100644 index 0000000000..bd5745e91a --- /dev/null +++ b/saw-core-aig/saw-core-aig.cabal @@ -0,0 +1,30 @@ +Name: saw-core-aig +Version: 0.1 +License: BSD3 +License-file: LICENSE +Author: Galois, Inc. +Maintainer: huffman@galois.com +Copyright: (c) 2012-2016 Galois Inc. +Category: Formal Methods +Build-type: Simple +cabal-version: >= 1.8 +Synopsis: SAWCore backend for AIGs +Description: + A backend for symbolically evaluating terms in the SAWCore + intermediate language using the aig library to generate And-Inverter + Graphs (AIGs). + +library + build-depends: + aig, + base == 4.*, + containers, + saw-core, + text, + vector + hs-source-dirs: src + exposed-modules: + Verifier.SAW.Simulator.BitBlast + GHC-options: -Wall -Werror + if impl(ghc == 8.0.1) + ghc-options: -Wno-redundant-constraints diff --git a/saw-core-aig/src/Verifier/SAW/Simulator/BitBlast.hs b/saw-core-aig/src/Verifier/SAW/Simulator/BitBlast.hs new file mode 100644 index 0000000000..baf9bc76ef --- /dev/null +++ b/saw-core-aig/src/Verifier/SAW/Simulator/BitBlast.hs @@ -0,0 +1,547 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE TypeFamilies #-} + +{- | +Module : Verifier.SAW.Simulator.BitBlast +Copyright : Galois, Inc. 2012-2015 +License : BSD3 +Maintainer : jhendrix@galois.com +Stability : experimental +Portability : non-portable (language extensions) +-} + +module Verifier.SAW.Simulator.BitBlast + ( BValue + , withBitBlastedTerm + , withBitBlastedSATQuery + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +import Data.Traversable +#endif +import Control.Monad ((<=<),unless) +import Data.IORef +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Text as Text +import qualified Data.Vector as V +import Numeric.Natural (Natural) + +import Verifier.SAW.FiniteValue (FiniteType(..),FirstOrderType(..),toFiniteType) +import qualified Verifier.SAW.Simulator as Sim +import Verifier.SAW.Simulator.Value +import qualified Verifier.SAW.Simulator.Prims as Prims +import Verifier.SAW.SATQuery +import Verifier.SAW.SharedTerm +import Verifier.SAW.TypedAST +import qualified Verifier.SAW.Simulator.Concrete as Concrete +import qualified Verifier.SAW.Prim as Prim +import qualified Verifier.SAW.Recognizer as R + +import qualified Data.AIG as AIG + +type LitVector l = AIG.BV l + +------------------------------------------------------------ +-- Vector operations + +lvFromV :: V.Vector l -> LitVector l +lvFromV v = AIG.generate_msb0 (V.length v) ((V.!) v) + +vFromLV :: LitVector l -> V.Vector l +vFromLV lv = V.generate (AIG.length lv) (AIG.at lv) + +lvRotateL :: LitVector l -> Integer -> LitVector l +lvRotateL xs i + | AIG.length xs == 0 = xs + | otherwise = (AIG.++) (AIG.drop j xs) (AIG.take j xs) + where j = fromInteger (i `mod` toInteger (AIG.length xs)) + +lvRotateR :: LitVector l -> Integer -> LitVector l +lvRotateR xs i = lvRotateL xs (- i) + +lvShiftL :: l -> LitVector l -> Integer -> LitVector l +lvShiftL x xs i = (AIG.++) (AIG.drop j xs) (AIG.replicate j x) + where j = fromInteger (min i (toInteger (AIG.length xs))) + +lvShl :: l -> LitVector l -> Natural -> LitVector l +lvShl l v i = AIG.slice v j (n-j) AIG.++ AIG.replicate j l + where n = AIG.length v + j = fromIntegral i `min` n + +lvShiftR :: l -> LitVector l -> Integer -> LitVector l +lvShiftR x xs i = (AIG.++) (AIG.replicate j x) (AIG.take (AIG.length xs - j) xs) + where j = fromInteger (min i (toInteger (AIG.length xs))) + +lvShr :: l -> LitVector l -> Natural -> LitVector l +lvShr l v i = AIG.replicate j l AIG.++ AIG.slice v 0 (n-j) + where n = AIG.length v + j = fromIntegral i `min` n + +------------------------------------------------------------ +-- Values + +data BitBlast l + +type instance EvalM (BitBlast l) = IO +type instance VBool (BitBlast l) = l +type instance VWord (BitBlast l) = LitVector l +type instance VInt (BitBlast l) = Integer +type instance Extra (BitBlast l) = BExtra l + +type BValue l = Value (BitBlast l) +type BThunk l = Thunk (BitBlast l) + +data BExtra l + = BStream (Natural -> IO (BValue l)) (IORef (Map Natural (BValue l))) + +instance Show (BExtra l) where + show (BStream _ _) = "BStream" + +vBool :: l -> BValue l +vBool l = VBool l + +toBool :: BValue l -> l +toBool (VBool l) = l +toBool x = error $ unwords ["Verifier.SAW.Simulator.BitBlast.toBool", show x] + +vWord :: LitVector l -> BValue l +vWord lv = VWord lv + +toWord :: BValue l -> IO (LitVector l) +toWord (VWord lv) = return lv +toWord (VVector vv) = lvFromV <$> traverse (fmap toBool . force) vv +toWord x = fail $ unwords ["Verifier.SAW.Simulator.BitBlast.toWord", show x] + +flattenBValue :: BValue l -> IO (LitVector l) +flattenBValue (VBool l) = return (AIG.replicate 1 l) +flattenBValue (VWord lv) = return lv +flattenBValue (VExtra (BStream _ _)) = error "Verifier.SAW.Simulator.BitBlast.flattenBValue: BStream" +flattenBValue (VVector vv) = + AIG.concat <$> traverse (flattenBValue <=< force) (V.toList vv) +flattenBValue VUnit = return $ AIG.concat [] +flattenBValue (VPair x y) = do + vx <- flattenBValue =<< force x + vy <- flattenBValue =<< force y + return $ AIG.concat [vx, vy] +flattenBValue (VRecordValue elems) = do + AIG.concat <$> mapM (flattenBValue <=< force . snd) elems +flattenBValue _ = error $ unwords ["Verifier.SAW.Simulator.BitBlast.flattenBValue: unsupported value"] + +wordFun :: (LitVector l -> IO (BValue l)) -> BValue l +wordFun f = strictFun (\x -> toWord x >>= f) + +------------------------------------------------------------ + +-- | op : (n : Nat) -> Vec n Bool -> Nat -> Vec n Bool +bvShiftOp :: (LitVector l -> LitVector l -> IO (LitVector l)) + -> (LitVector l -> Natural -> LitVector l) + -> BValue l +bvShiftOp bvOp natOp = + constFun $ + wordFun $ \x -> return $ + strictFun $ \y -> + case y of + VNat n -> return (vWord (natOp x n)) + VToNat v -> fmap vWord (bvOp x =<< toWord v) + _ -> error $ unwords ["Verifier.SAW.Simulator.BitBlast.shiftOp", show y] + +lvSShr :: LitVector l -> Natural -> LitVector l +lvSShr v i = lvShr (AIG.msb v) v i + +------------------------------------------------------------ + +pure1 :: Applicative f => (a -> b) -> a -> f b +pure1 f x = pure (f x) + +pure2 :: Applicative f => (a -> b -> c) -> a -> b -> f c +pure2 f x y = pure (f x y) + +pure3 :: Applicative f => (a -> b -> c -> d) -> a -> b -> c -> f d +pure3 f x y z = pure (f x y z) + +prims :: AIG.IsAIG l g => g s -> Prims.BasePrims (BitBlast (l s)) +prims be = + Prims.BasePrims + { Prims.bpAsBool = AIG.asConstant be + -- Bitvectors + , Prims.bpUnpack = pure1 vFromLV + , Prims.bpPack = pure1 lvFromV + , Prims.bpBvAt = pure2 AIG.at + , Prims.bpBvLit = pure2 (AIG.bvFromInteger be) + , Prims.bpBvSize = AIG.length + , Prims.bpBvJoin = pure2 (AIG.++) + , Prims.bpBvSlice = pure3 (\i n v -> AIG.slice v i n) + -- Conditionals + , Prims.bpMuxBool = \b x y -> AIG.lazyMux be b (pure x) (pure y) + , Prims.bpMuxWord = \b x y -> AIG.iteM be b (pure x) (pure y) + , Prims.bpMuxInt = muxInt + , Prims.bpMuxExtra = muxBExtra be + -- Booleans + , Prims.bpTrue = AIG.trueLit be + , Prims.bpFalse = AIG.falseLit be + , Prims.bpNot = pure1 AIG.not + , Prims.bpAnd = AIG.and be + , Prims.bpOr = AIG.or be + , Prims.bpXor = AIG.xor be + , Prims.bpBoolEq = AIG.eq be + -- Bitvector logical + , Prims.bpBvNot = pure1 (fmap AIG.not) + , Prims.bpBvAnd = AIG.zipWithM (AIG.and be) + , Prims.bpBvOr = AIG.zipWithM (AIG.or be) + , Prims.bpBvXor = AIG.zipWithM (AIG.xor be) + -- Bitvector arithmetic + , Prims.bpBvNeg = AIG.neg be + , Prims.bpBvAdd = AIG.add be + , Prims.bpBvSub = AIG.sub be + , Prims.bpBvMul = AIG.mul be + , Prims.bpBvUDiv = AIG.uquot be + , Prims.bpBvURem = AIG.urem be + , Prims.bpBvSDiv = AIG.squot be + , Prims.bpBvSRem = AIG.srem be + , Prims.bpBvLg2 = bitblastLogBase2 be + -- Bitvector comparisons + , Prims.bpBvEq = AIG.bvEq be + , Prims.bpBvsle = AIG.sle be + , Prims.bpBvslt = AIG.slt be + , Prims.bpBvule = AIG.ule be + , Prims.bpBvult = AIG.ult be + , Prims.bpBvsge = flip (AIG.sle be) + , Prims.bpBvsgt = flip (AIG.slt be) + , Prims.bpBvuge = flip (AIG.ule be) + , Prims.bpBvugt = flip (AIG.ult be) + -- Bitvector shift/rotate + , Prims.bpBvRolInt = pure2 lvRotateL + , Prims.bpBvRorInt = pure2 lvRotateR + , Prims.bpBvShlInt = pure3 lvShiftL + , Prims.bpBvShrInt = pure3 lvShiftR + , Prims.bpBvRol = genShift be lvRotateL + , Prims.bpBvRor = genShift be lvRotateR + , Prims.bpBvShl = genShift be . lvShiftL + , Prims.bpBvShr = genShift be . lvShiftR + -- Bitvector misc + , Prims.bpBvPopcount = AIG.popCount be + , Prims.bpBvCountLeadingZeros = AIG.countLeadingZeros be + , Prims.bpBvCountTrailingZeros = AIG.countTrailingZeros be + , Prims.bpBvForall = unsupportedAIGPrimitive "bvForall" + + -- Integer operations + , Prims.bpIntAdd = pure2 (+) + , Prims.bpIntSub = pure2 (-) + , Prims.bpIntMul = pure2 (*) + , Prims.bpIntDiv = pure2 div + , Prims.bpIntMod = pure2 mod + , Prims.bpIntNeg = pure1 negate + , Prims.bpIntAbs = pure1 abs + , Prims.bpIntEq = pure2 (\x y -> AIG.constant be (x == y)) + , Prims.bpIntLe = pure2 (\x y -> AIG.constant be (x <= y)) + , Prims.bpIntLt = pure2 (\x y -> AIG.constant be (x < y)) + , Prims.bpIntMin = pure2 min + , Prims.bpIntMax = pure2 max + + -- Array operations + , Prims.bpArrayConstant = unsupportedAIGPrimitive "bpArrayConstant" + , Prims.bpArrayLookup = unsupportedAIGPrimitive "bpArrayLookup" + , Prims.bpArrayUpdate = unsupportedAIGPrimitive "bpArrayUpdate" + , Prims.bpArrayEq = unsupportedAIGPrimitive "bpArrayEq" + } + +unsupportedAIGPrimitive :: String -> a +unsupportedAIGPrimitive = Prim.unsupportedPrimitive "AIG" + +beConstMap :: AIG.IsAIG l g => g s -> Map Ident (BValue (l s)) +beConstMap be = + Map.union (Prims.constMap (prims be)) $ + Map.fromList + -- Shifts + [ ("Prelude.bvShl" , bvShiftOp (AIG.shl be) (lvShl (AIG.falseLit be))) + , ("Prelude.bvShr" , bvShiftOp (AIG.ushr be) (lvShr (AIG.falseLit be))) + , ("Prelude.bvSShr", bvShiftOp (AIG.sshr be) lvSShr) + -- Integers + , ("Prelude.intToNat", Prims.intToNatOp) + , ("Prelude.natToInt", Prims.natToIntOp) + , ("Prelude.intToBv" , intToBvOp be) + , ("Prelude.bvToInt" , bvToIntOp be) + , ("Prelude.sbvToInt", sbvToIntOp be) + -- Integers mod n + , ("Prelude.toIntMod" , toIntModOp) + , ("Prelude.fromIntMod", fromIntModOp) + , ("Prelude.intModEq" , intModEqOp be) + , ("Prelude.intModAdd" , intModBinOp (+)) + , ("Prelude.intModSub" , intModBinOp (-)) + , ("Prelude.intModMul" , intModBinOp (*)) + , ("Prelude.intModNeg" , intModUnOp negate) + -- Streams + , ("Prelude.MkStream", mkStreamOp) + , ("Prelude.streamGet", streamGetOp be) + -- Misc + , ("Prelude.expByNat", Prims.expByNatOp (prims be)) + ] + +-- | Lifts a strict mux operation to a lazy mux +lazyMux :: AIG.IsAIG l g => g s -> (l s -> a -> a -> IO a) -> l s -> IO a -> IO a -> IO a +lazyMux be muxFn c tm fm + | (AIG.===) c (AIG.trueLit be) = tm + | (AIG.===) c (AIG.falseLit be) = fm + | otherwise = do + t <- tm + f <- fm + muxFn c t f + +muxBVal :: AIG.IsAIG l g => g s -> l s -> BValue (l s) -> BValue (l s) -> IO (BValue (l s)) +muxBVal be = Prims.muxValue (prims be) + +muxInt :: a -> Integer -> Integer -> IO Integer +muxInt _ x y = if x == y then return x else fail $ "muxBVal: VInt " ++ show (x, y) + +muxBExtra :: AIG.IsAIG l g => g s -> l s -> BExtra (l s) -> BExtra (l s) -> IO (BExtra (l s)) +muxBExtra be c x y = + do let f i = do xi <- lookupBStream (VExtra x) i + yi <- lookupBStream (VExtra y) i + muxBVal be c xi yi + r <- newIORef Map.empty + return (BStream f r) + +-- | Barrel-shifter algorithm. Takes a list of bits in big-endian order. +genShift :: + AIG.IsAIG l g => g s -> (LitVector (l s) -> Integer -> LitVector (l s)) -> + LitVector (l s) -> LitVector (l s) -> IO (LitVector (l s)) +genShift be op x y = Prims.shifter (AIG.ite be) (pure2 op) x (AIG.bvToList y) + +-- | rounded-up log base 2, where we complete the function by setting: +-- lg2 0 = 0 +bitblastLogBase2 :: AIG.IsAIG l g => g s -> LitVector (l s) -> IO (LitVector (l s)) +bitblastLogBase2 g x = do + z <- AIG.isZero g x + AIG.iteM g z (return x) (AIG.logBase2_up g x) + +----------------------------------------- +-- Integer/bitvector conversions + +-- primitive bvToInt : (n : Nat) -> Vec n Bool -> Integer; +bvToIntOp :: AIG.IsAIG l g => g s -> BValue (l s) +bvToIntOp g = constFun $ wordFun $ \v -> + case AIG.asUnsigned g v of + Just i -> return $ VInt i + Nothing -> fail "Cannot convert symbolic bitvector to integer" + +-- primitive sbvToInt : (n : Nat) -> Vec n Bool -> Integer; +sbvToIntOp :: AIG.IsAIG l g => g s -> BValue (l s) +sbvToIntOp g = constFun $ wordFun $ \v -> + case AIG.asSigned g v of + Just i -> return $ VInt i + Nothing -> fail "Cannot convert symbolic bitvector to integer" + +-- primitive intToBv : (n : Nat) -> Integer -> Vec n Bool; +intToBvOp :: AIG.IsAIG l g => g s -> BValue (l s) +intToBvOp g = + Prims.natFun' "intToBv n" $ \n -> return $ + Prims.intFun "intToBv x" $ \x -> + VWord <$> + if n >= 0 then return (AIG.bvFromInteger g (fromIntegral n) x) + else AIG.neg g (AIG.bvFromInteger g (fromIntegral n) (negate x)) + +------------------------------------------------------------ + +toIntModOp :: BValue l +toIntModOp = + Prims.natFun $ \n -> return $ + Prims.intFun "toIntModOp" $ \x -> return $ + VIntMod n (x `mod` toInteger n) + +fromIntModOp :: BValue l +fromIntModOp = + constFun $ + Prims.intModFun "fromIntModOp" $ \x -> return $ + VInt x + +intModEqOp :: AIG.IsAIG l g => g s -> BValue (l s) +intModEqOp be = + constFun $ + Prims.intModFun "intModEqOp" $ \x -> return $ + Prims.intModFun "intModEqOp" $ \y -> return $ + VBool (AIG.constant be (x == y)) + +intModBinOp :: (Integer -> Integer -> Integer) -> BValue l +intModBinOp f = + Prims.natFun $ \n -> return $ + Prims.intModFun "intModBinOp x" $ \x -> return $ + Prims.intModFun "intModBinOp y" $ \y -> return $ + VIntMod n (f x y `mod` toInteger n) + +intModUnOp :: (Integer -> Integer) -> BValue l +intModUnOp f = + Prims.natFun $ \n -> return $ + Prims.intModFun "intModUnOp" $ \x -> return $ + VIntMod n (f x `mod` toInteger n) + +---------------------------------------- + +-- MkStream :: (a :: sort 0) -> (Nat -> a) -> Stream a; +mkStreamOp :: BValue l +mkStreamOp = + constFun $ + strictFun $ \f -> do + r <- newIORef Map.empty + return $ VExtra (BStream (\n -> apply f (ready (VNat n))) r) + +-- streamGet :: (a :: sort 0) -> Stream a -> Nat -> a; +streamGetOp :: AIG.IsAIG l g => g s -> BValue (l s) +streamGetOp be = + constFun $ + strictFun $ \xs -> return $ + strictFun $ \case + VNat n -> lookupBStream xs n + VToNat w -> + do bs <- toWord w + AIG.muxInteger (lazyMux be (muxBVal be)) ((2 ^ AIG.length bs) - 1) bs (lookupBStream xs) + v -> fail (unlines ["Verifier.SAW.Simulator.BitBlast.streamGetOp", "Expected Nat value", show v]) + + +lookupBStream :: BValue l -> Natural -> IO (BValue l) +lookupBStream (VExtra (BStream f r)) n = do + m <- readIORef r + case Map.lookup n m of + Just v -> return v + Nothing -> do v <- f n + writeIORef r (Map.insert n v m) + return v +lookupBStream _ _ = fail "Verifier.SAW.Simulator.BitBlast.lookupBStream: expected Stream" + +------------------------------------------------------------ +-- Generating variables for arguments + +newVars :: AIG.IsAIG l g => g s -> FiniteType -> IO (BValue (l s)) +newVars be FTBit = vBool <$> AIG.newInput be +newVars be (FTVec n tp) = VVector <$> V.replicateM (fromIntegral n) (newVars' be tp) +newVars be (FTTuple ts) = vTuple <$> traverse (newVars' be) ts +newVars be (FTRec tm) = vRecord <$> traverse (newVars' be) tm + +newVars' :: AIG.IsAIG l g => g s -> FiniteType -> IO (BThunk (l s)) +newVars' be shape = ready <$> newVars be shape + +------------------------------------------------------------ +-- Bit-blasting primitives. +-- +-- NB: It doesn't make sense to bit blast more than one term using the +-- same bit engine, so the primitives 'withBitBlasted*' create their +-- own bit engine internally, instead of receiving it from the caller, +-- and pass it to the caller-provided continuation. + +type PrimMap l g = forall s. g s -> Map Ident (BValue (l s)) + +bitBlastBasic :: AIG.IsAIG l g + => g s + -> ModuleMap + -> PrimMap l g + -> Map VarIndex (BValue (l s)) + -> Term + -> IO (BValue (l s)) +bitBlastBasic be m addlPrims ecMap t = do + cfg <- Sim.evalGlobal m (Map.union (beConstMap be) (addlPrims be)) + (bitBlastExtCns ecMap) + (const Nothing) + Sim.evalSharedTerm cfg t + +bitBlastExtCns :: + Map VarIndex (BValue (l s)) -> ExtCns (TValue (BitBlast (l s))) -> + IO (BValue (l s)) +bitBlastExtCns ecMap (EC idx name _v) = + case Map.lookup idx ecMap of + Just var -> return var + Nothing -> fail $ + "Verifier.SAW.Simulator.BitBlast: can't translate variable " ++ + show name ++ "(index: " ++ show idx ++ ")" + +asAIGType :: SharedContext -> Term -> IO [(String, Term)] +asAIGType sc t = do + t' <- scWhnf sc t + case t' of + (R.asPi -> Just (n, t1, t2)) -> ((Text.unpack n, t1) :) <$> asAIGType sc t2 + (R.asBoolType -> Just ()) -> return [] + (R.asVecType -> Just _) -> return [] + (R.asTupleType -> Just _) -> return [] + (R.asRecordType -> Just _) -> return [] + _ -> fail $ "Verifier.SAW.Simulator.BitBlast.adAIGType: invalid AIG type: " + ++ scPrettyTerm defaultPPOpts t' + +bitBlastTerm :: + AIG.IsAIG l g => + g s -> + SharedContext -> + PrimMap l g -> + Term -> + IO (BValue (l s), [(String, FiniteType)]) +bitBlastTerm be sc addlPrims t = do + ty <- scTypeOf sc t + args <- asAIGType sc ty + let ecs = getAllExts t + argShapes <- traverse (asFiniteType sc) (map snd args) + ecShapes <- traverse (asFiniteType sc) (map ecType ecs) + argVars <- traverse (newVars' be) argShapes + ecVars <- traverse (newVars be) ecShapes + let ecMap = Map.fromList $ zip (map ecVarIndex ecs) ecVars + modmap <- scGetModuleMap sc + bval <- bitBlastBasic be modmap addlPrims ecMap t + bval' <- applyAll bval argVars + let names = map fst args ++ map (Text.unpack . toShortName . ecName) ecs + shapes = argShapes ++ ecShapes + return (bval', zip names shapes) + +-- | Bitblast a term and apply a function to the result. +withBitBlastedTerm :: AIG.IsAIG l g => AIG.Proxy l g -> + SharedContext -> + PrimMap l g -> + Term -> + (forall s. g s -> LitVector (l s) -> IO a) -> IO a +withBitBlastedTerm proxy sc addlPrims t c = AIG.withNewGraph proxy $ \be -> do + (bval, _) <- bitBlastTerm be sc addlPrims t + v <- flattenBValue bval + c be v + +asFiniteType :: SharedContext -> Term -> IO FiniteType +asFiniteType sc t = + scGetModuleMap sc >>= \modmap -> + case asFiniteTypeValue (Concrete.evalSharedTerm modmap Map.empty Map.empty t) of + Just ft -> return ft + Nothing -> + fail $ "asFiniteType: unsupported type " ++ scPrettyTerm defaultPPOpts t + +processVar :: + (ExtCns Term, FirstOrderType) -> + IO (ExtCns Term, FiniteType) +processVar (ec, fot) = + case toFiniteType fot of + Nothing -> fail ("ABC solver does not support variables of type " ++ show fot) + Just ft -> pure (ec, ft) + + +withBitBlastedSATQuery :: + AIG.IsAIG l g => + AIG.Proxy l g -> + SharedContext -> + PrimMap l g -> + SATQuery -> + (forall s. g s -> l s -> [(ExtCns Term, FiniteType)] -> IO a) -> + IO a +withBitBlastedSATQuery proxy sc addlPrims satq cont = + do unless (Set.null (satUninterp satq)) $ fail + "RME prover does not support uninterpreted symbols" + t <- satQueryAsTerm sc satq + varShapes <- mapM processVar (Map.toList (satVariables satq)) + modmap <- scGetModuleMap sc + AIG.withNewGraph proxy $ \be -> + do vars <- traverse (traverse (newVars be)) varShapes + let varMap = Map.fromList [ (ecVarIndex ec, v) | (ec,v) <- vars ] + x <- bitBlastBasic be modmap addlPrims varMap t + case x of + VBool l -> cont be l varShapes + _ -> fail "Verifier.SAW.Simulator.BitBlast.withBitBlastedSATQuery: non-boolean result type." diff --git a/saw-core-coq/.gitignore b/saw-core-coq/.gitignore new file mode 100644 index 0000000000..159b7da69f --- /dev/null +++ b/saw-core-coq/.gitignore @@ -0,0 +1,5 @@ +/saw/saw +.stack-work +*.v.d +*.vok +*.vos diff --git a/saw-core-coq/LICENSE b/saw-core-coq/LICENSE new file mode 100644 index 0000000000..966cdbe18a --- /dev/null +++ b/saw-core-coq/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2018, 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 names of the authors nor the names of other + 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/saw-core-coq/README.md b/saw-core-coq/README.md new file mode 100644 index 0000000000..49338979c8 --- /dev/null +++ b/saw-core-coq/README.md @@ -0,0 +1,134 @@ +# Overview + +This repository contains a backend for the `saw-core` library that outputs terms +in the syntax of Coq. The Coq files generated by this backend depend on the Coq +support libraries described below, which must be compiled in Coq in order to be +used. + + +# The Coq Support Libraries + +The Coq files that are generated by the `saw-core-coq` backend rely on a number +of support libraries, some of which are generated from the SAW core prelude +files and some of which are hand-written extensions of those libraries. These +support libraries must be compiled by Coq in order to use them. + + +## Installing Dependencies + +To compile the Coq support libraries, Coq must be installed, as must the +following Coq library: + +* [bits](https://github.com/coq-community/bits) + +The recommended way to install Coq and these dependencies is using opam. This +can be done with the following steps, which will not only install opam, Coq, and +the above mentioned Coq libraries, but will make sure to install the proper +version of Coq needed for those libraries: + +``` +sh <(curl -sL https://raw.githubusercontent.com/ocaml/opam/master/shell/install.sh) +opam init +opam repo add coq-released https://coq.inria.fr/opam/released +opam install coq-bits +``` + +If you run into any issue that is probably due to the version mismatch between the `ocamlc` +and the `ocaml` base system installed on your machine and it can be fixed as explained +[here](https://github.com/ocaml/opam/issues/3708). + + +## Building the and Using the Coq Support Libraries + +The `coq/` directory contains the Coq support libraries for the `saw-core-coq` +backend, as well as a number of example Coq files that have been generated from +existing SAW proofs. In order to build just the Coq support libraries, the +following commands can be used: + +``` +cd coq +make generated/CryptolToCoq/SAWCorePrelude.vo +``` + +To use these libraries, the following lines can be added to a `_CoqProject` +file, where PATH_TO_SAW is replaced by the path to the `saw-script` directory: + +``` +-Q PATH_TO_SAW/saw-core-coq/coq/generated/CryptolToCoq CryptolToCoq +-Q PATH_TO_SAW/saw-core-coq/coq/handwritten/CryptolToCoq CryptolToCoq +``` + + +## Generating the Coq Support Libraries + +The Coq support libraries can be re-generated from their SAWCore/Cryptol +counterparts if these modules change. This can be done in the `saw/` directory, +by running the scripts there with an appropriate version of the `saw` +executable. The output of such files are currently being version-controlled, as +a way of keeping track of their evolution. + +``` +/path/to/saw generate_scaffolding.saw +``` + + +# Directory Structure + +* `coq/` contains handwritten Coq files in `handwritten/` and generated ones in + `generated/`, as well as some files needed to build the Coq files. + +* `cryptol/` contains some Cryptol files that we care about extracting. + +* `saw/` contains SAW scripts that generate the Coq files. + + +## Coq Files Organization + +The Coq files have a somewhat complex organization. We demonstrate the current +dependencies, ignoring transitive dependencies for clarity: + +``` + SAWCoreScaffolding (H) + / \ +SAWCoreVectorsAsCoqVectors (H) SAWCoreVectorsAsCoqLists (H) + \ / + CoqVectorsExtra (H) SAWCorePrelude (G) + \ / \ + CryptolPrimitivesForSAWCore (G) SAWCorePreludeExtra (H) + \ / + CryptolPrimitivesForSAWCoreExtra (H) + +``` + +(G) stands for generated files, while (H) stands for handwritten files. + +* `SAWCoreScaffolding` defines some of SAW core primitive types and values. + +* `SAWCoreVectorsAsCoqVectors` and `SAWCoreVectorsAsCoqLists` are two + realizations of the vector type, the latter ignoring the type index. In + practice, we have found that the latter is a no-go for proofs unless + values are packaged with a proof that their length is equal to the index. + +* `SAWCorePrelude` is generated from `Prelude.sawcore`, available in the + `saw-core` project. + +* `CoqVectorsExtra` contains facts about vectors that the Coq standard library + does not provide. + +* `CryptolPrimitivesForSAWCore` is generated from `Cryptol.sawcore`, available + in the `cryptol-saw-core` project. + +* `SAWCorePreludeExtra` defines useful functions for + `CryptolPrimitivesForSAWCoreExtra` to use. + +* `CryptolPrimitivesForSAWCoreExtra` contains some additional useful + definitions. + + +# Acknowledgements + +This material is based upon work supported by the Office of Naval +Research under Contract No. N68335-17-C-0452. Any opinions, findings and +conclusions or recommendations expressed in this material are those of +the author(s) and do not necessarily reflect the views of the Office of +Naval Research. diff --git a/saw-core-coq/coq/.gitignore b/saw-core-coq/coq/.gitignore new file mode 100644 index 0000000000..43212752cc --- /dev/null +++ b/saw-core-coq/coq/.gitignore @@ -0,0 +1,8 @@ +*.aux +*.coqdeps.d +*.glob +*.vo +/default.nix +/Makefile.coq +/Makefile.coq.conf +/saw diff --git a/saw-core-coq/coq/Makefile b/saw-core-coq/coq/Makefile new file mode 100644 index 0000000000..4cc4a0f4d2 --- /dev/null +++ b/saw-core-coq/coq/Makefile @@ -0,0 +1,13 @@ +all: build + +Makefile.coq: _CoqProject + coq_makefile -f $< -o $@ + +build: Makefile.coq + make -f Makefile.coq + +clean: Makefile.coq + make -f Makefile.coq clean + +%.vo: Makefile.coq + make -f Makefile.coq $@ diff --git a/saw-core-coq/coq/_CoqProject b/saw-core-coq/coq/_CoqProject new file mode 100644 index 0000000000..05fc311a82 --- /dev/null +++ b/saw-core-coq/coq/_CoqProject @@ -0,0 +1,15 @@ +-Q generated/CryptolToCoq CryptolToCoq +-Q handwritten/CryptolToCoq CryptolToCoq + +generated/CryptolToCoq/CryptolPrimitivesForSAWCore.v +generated/CryptolToCoq/SAWCorePrelude.v + +handwritten/CryptolToCoq/CompM.v +handwritten/CryptolToCoq/CompMExtra.v +handwritten/CryptolToCoq/CoqVectorsExtra.v +handwritten/CryptolToCoq/CryptolPrimitivesForSAWCoreExtra.v +handwritten/CryptolToCoq/SAWCoreBitvectors.v +handwritten/CryptolToCoq/SAWCorePrelude_proofs.v +handwritten/CryptolToCoq/SAWCorePreludeExtra.v +handwritten/CryptolToCoq/SAWCoreScaffolding.v +handwritten/CryptolToCoq/SAWCoreVectorsAsCoqVectors.v diff --git a/saw-core-coq/coq/generated/CryptolToCoq/CryptolPrelude.v b/saw-core-coq/coq/generated/CryptolToCoq/CryptolPrelude.v new file mode 100644 index 0000000000..5e8cbaf0c5 --- /dev/null +++ b/saw-core-coq/coq/generated/CryptolToCoq/CryptolPrelude.v @@ -0,0 +1,153 @@ +From Coq Require Import Lists.List. +Import ListNotations. +From Coq Require Import String. +From Coq Require Import Vectors.Vector. +From CryptolToCoq Require Import SAWCoreScaffolding. +From CryptolToCoq Require Import SAWCoreVectorsAsCoqVectors. +From Records Require Import Records. + + + +From CryptolToCoq Require Import SAWCorePrelude. +Import SAWCorePrelude. +From CryptolToCoq Require Import CryptolPrimitivesForSAWCore. +Import CryptolPrimitives. +From CryptolToCoq Require Import CryptolPrimitivesForSAWCoreExtra. + +Definition demote (val : (@Num)) (rep : Type) (_P : (@CryptolPrimitives.PLiteral (rep))) := + (@CryptolPrimitives.ecNumber (val) (rep) (_P)). + +Definition === (a : Type) (b : Type) (_P : (@CryptolPrimitives.PCmp (b))) (f : (a) -> b) (g : (a) -> b) (x : a) := + (@CryptolPrimitives.ecEq (b) (_P) ((f (x))) ((g (x)))). + +Definition !== (a : Type) (b : Type) (_P : (@CryptolPrimitives.PCmp (b))) (f : (a) -> b) (g : (a) -> b) (x : a) := + (@CryptolPrimitives.ecNotEq (b) (_P) ((f (x))) ((g (x)))). + +Definition min (a : Type) (_P : (@CryptolPrimitives.PCmp (a))) (x : a) (y : a) := + if (@CryptolPrimitives.ecLt (a) (_P) (x) (y)) then x else y. + +Definition max (a : Type) (_P : (@CryptolPrimitives.PCmp (a))) (x : a) (y : a) := + if (@CryptolPrimitives.ecGt (a) (_P) (x) (y)) then x else y. + +Definition >$ (a : Type) (_P : (@CryptolPrimitives.PSignedCmp (a))) (x : a) (y : a) := + (@CryptolPrimitives.ecSLt (a) (_P) (y) (x)). + +Definition <=$ (a : Type) (_P : (@CryptolPrimitives.PSignedCmp (a))) (x : a) (y : a) := + (@CryptolPrimitives.ecCompl (@SAWCoreScaffolding.Bool) (@CryptolPrimitives.PLogicBit) ((@CryptolPrimitives.ecSLt (a) (_P) (y) (x)))). + +Definition >=$ (a : Type) (_P : (@CryptolPrimitives.PSignedCmp (a))) (x : a) (y : a) := + (@CryptolPrimitives.ecCompl (@SAWCoreScaffolding.Bool) (@CryptolPrimitives.PLogicBit) ((@CryptolPrimitives.ecSLt (a) (_P) (x) (y)))). + +Definition sborrow (n : (@Num)) (x : (@CryptolPrimitives.seq (n) (@SAWCoreScaffolding.Bool))) (y : (@CryptolPrimitives.seq (n) (@SAWCoreScaffolding.Bool))) := + (@CryptolPrimitives.ecXor (@SAWCoreScaffolding.Bool) (@CryptolPrimitives.PLogicBit) ((@CryptolPrimitives.ecSLt ((@CryptolPrimitives.seq (n) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.PSignedCmpWord (n))) (x) ((@CryptolPrimitives.ecMinus ((@CryptolPrimitives.seq (n) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.PArithSeqBool (n))) (x) (y))))) ((@CryptolPrimitives.ecAt (n) (@SAWCoreScaffolding.Bool) ((@TCNum (0))) (y) ((@CryptolPrimitives.ecNumber ((@TCNum (0))) ((@CryptolPrimitives.seq ((@TCNum (0))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.PLiteralSeqBool ((@TCNum (0)))))))))). + +Definition zext (m : (@Num)) (n : (@Num)) (x : (@CryptolPrimitives.seq (n) (@SAWCoreScaffolding.Bool))) := + (@SAWCoreScaffolding.coerce ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@CryptolPrimitives.tcSub (m) (n))) (n))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.seq (m) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.seq_cong1 ((@CryptolPrimitives.tcAdd ((@CryptolPrimitives.tcSub (m) (n))) (n))) (m) (@SAWCoreScaffolding.Bool) ((@SAWCorePrelude.sawUnsafeAssert ((@Num)) ((@CryptolPrimitives.tcAdd ((@CryptolPrimitives.tcSub (m) (n))) (n))) (m))))) ((@CryptolPrimitives.ecCat ((@CryptolPrimitives.tcSub (m) (n))) (n) (@SAWCoreScaffolding.Bool) ((@CryptolPrimitives.ecZero ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcSub (m) (n))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.PZeroSeqBool ((@CryptolPrimitives.tcSub (m) (n))))))) (x)))). + +Definition sext (m : (@Num)) (n : (@Num)) (x : (@CryptolPrimitives.seq (n) (@SAWCoreScaffolding.Bool))) := + (@SAWCoreScaffolding.coerce ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@CryptolPrimitives.tcSub (m) (n))) (n))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.seq (m) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.seq_cong1 ((@CryptolPrimitives.tcAdd ((@CryptolPrimitives.tcSub (m) (n))) (n))) (m) (@SAWCoreScaffolding.Bool) ((@SAWCorePrelude.sawUnsafeAssert ((@Num)) ((@CryptolPrimitives.tcAdd ((@CryptolPrimitives.tcSub (m) (n))) (n))) (m))))) ((@CryptolPrimitives.ecCat ((@CryptolPrimitives.tcSub (m) (n))) (n) (@SAWCoreScaffolding.Bool) (if (@CryptolPrimitives.ecAt (n) (@SAWCoreScaffolding.Bool) ((@TCNum (0))) (x) ((@CryptolPrimitives.ecNumber ((@TCNum (0))) ((@CryptolPrimitives.seq ((@TCNum (0))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.PLiteralSeqBool ((@TCNum (0)))))))) then (@CryptolPrimitives.ecCompl ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcSub (m) (n))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.PLogicSeqBool ((@CryptolPrimitives.tcSub (m) (n))))) ((@CryptolPrimitives.ecZero ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcSub (m) (n))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.PZeroSeqBool ((@CryptolPrimitives.tcSub (m) (n)))))))) else (@CryptolPrimitives.ecZero ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcSub (m) (n))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.PZeroSeqBool ((@CryptolPrimitives.tcSub (m) (n))))))) (x)))). + +Definition and (x : @SAWCoreScaffolding.Bool) (y : @SAWCoreScaffolding.Bool) := + if x then y else @SAWCoreScaffolding.False. + +Definition \/ (x : @SAWCoreScaffolding.Bool) (y : @SAWCoreScaffolding.Bool) := + if x then @SAWCoreScaffolding.True else y. + +Definition ==> (a : @SAWCoreScaffolding.Bool) (b : @SAWCoreScaffolding.Bool) := + if a then b else @SAWCoreScaffolding.True. + +Definition @@ (n : (@Num)) (k : (@Num)) (ix : (@Num)) (a : Type) (xs : (@CryptolPrimitives.seq (n) (a))) (is : (@CryptolPrimitives.seq (k) ((@CryptolPrimitives.seq (ix) (@SAWCoreScaffolding.Bool))))) := + (@CryptolPrimitives.seqMap ((@CryptolPrimitives.seq (ix) (@SAWCoreScaffolding.Bool))) (a) (k) ((fun (i : (@CryptolPrimitives.seq (ix) (@SAWCoreScaffolding.Bool))) => (@CryptolPrimitives.ecAt (n) (a) (ix) (xs) (i)))) (is)). + +Definition !! (n : (@Num)) (k : (@Num)) (ix : (@Num)) (a : Type) (xs : (@CryptolPrimitives.seq (n) (a))) (is : (@CryptolPrimitives.seq (k) ((@CryptolPrimitives.seq (ix) (@SAWCoreScaffolding.Bool))))) := + (@CryptolPrimitives.seqMap ((@CryptolPrimitives.seq (ix) (@SAWCoreScaffolding.Bool))) (a) (k) ((fun (i : (@CryptolPrimitives.seq (ix) (@SAWCoreScaffolding.Bool))) => (@CryptolPrimitives.ecAtBack (n) (a) (ix) (xs) (i)))) (is)). + +Definition updates (n : (@Num)) (k : (@Num)) (ix : (@Num)) (a : Type) (xs0 : (@CryptolPrimitives.seq (n) (a))) (idxs : (@CryptolPrimitives.seq (k) ((@CryptolPrimitives.seq (ix) (@SAWCoreScaffolding.Bool))))) (vals : (@CryptolPrimitives.seq (k) (a))) := + (@CryptolPrimitives.ecAtBack ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (k))) ((@CryptolPrimitives.seq (n) (a))) ((@TCNum (0))) ((iter ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (k))) ((fun (xss : (@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (k))) ((@CryptolPrimitives.seq (n) (a))))) => (@CryptolPrimitives.ecCat ((@TCNum (1))) (k) ((@CryptolPrimitives.seq (n) (a))) ((Vector.cons (_) (xs0) (_) ((Vector.nil (_))))) ((@SAWCoreScaffolding.coerce ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcMin ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (k))) ((@CryptolPrimitives.tcMin (k) (k))))) ((@CryptolPrimitives.seq (n) (a))))) ((@CryptolPrimitives.seq (k) ((@CryptolPrimitives.seq (n) (a))))) ((@CryptolPrimitives.seq_cong1 ((@CryptolPrimitives.tcMin ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (k))) ((@CryptolPrimitives.tcMin (k) (k))))) (k) ((@CryptolPrimitives.seq (n) (a))) ((@SAWCorePrelude.sawUnsafeAssert ((@Num)) ((@CryptolPrimitives.tcMin ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (k))) ((@CryptolPrimitives.tcMin (k) (k))))) (k))))) ((@CryptolPrimitives.seqMap ((prod ((@CryptolPrimitives.seq (n) (a))) ((prod ((@CryptolPrimitives.seq (ix) (@SAWCoreScaffolding.Bool))) (a))))) ((@CryptolPrimitives.seq (n) (a))) ((@CryptolPrimitives.tcMin ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (k))) ((@CryptolPrimitives.tcMin (k) (k))))) ((@SAWCorePrelude.uncurry ((@CryptolPrimitives.seq (n) (a))) ((prod ((@CryptolPrimitives.seq (ix) (@SAWCoreScaffolding.Bool))) (a))) ((@CryptolPrimitives.seq (n) (a))) ((fun (xs : (@CryptolPrimitives.seq (n) (a))) => (@SAWCorePrelude.uncurry ((@CryptolPrimitives.seq (ix) (@SAWCoreScaffolding.Bool))) (a) ((@CryptolPrimitives.seq (n) (a))) ((fun (i : (@CryptolPrimitives.seq (ix) (@SAWCoreScaffolding.Bool))) (b : a) => (@CryptolPrimitives.ecUpdate (n) (a) (ix) (xs) (i) (b))))))))) ((@CryptolPrimitives.seqZip ((@CryptolPrimitives.seq (n) (a))) ((prod ((@CryptolPrimitives.seq (ix) (@SAWCoreScaffolding.Bool))) (a))) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (k))) ((@CryptolPrimitives.tcMin (k) (k))) (xss) ((@CryptolPrimitives.seqZip ((@CryptolPrimitives.seq (ix) (@SAWCoreScaffolding.Bool))) (a) (k) (k) (idxs) (vals)))))))))))) ((CryptolPrimitives.seqConst ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (k))) ((@CryptolPrimitives.seq (n) (a))) ((CryptolPrimitives.seqConst (n) (a) ((error ("Could not generate default value of type !3"))))))))) ((@CryptolPrimitives.ecNumber ((@TCNum (0))) ((@CryptolPrimitives.seq ((@TCNum (0))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.PLiteralSeqBool ((@TCNum (0)))))))). + +Definition updatesEnd (n : (@Num)) (k : (@Num)) (ix : (@Num)) (a : Type) (xs0 : (@CryptolPrimitives.seq (n) (a))) (idxs : (@CryptolPrimitives.seq (k) ((@CryptolPrimitives.seq (ix) (@SAWCoreScaffolding.Bool))))) (vals : (@CryptolPrimitives.seq (k) (a))) := + (@CryptolPrimitives.ecAtBack ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (k))) ((@CryptolPrimitives.seq (n) (a))) ((@TCNum (0))) ((iter ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (k))) ((fun (xss : (@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (k))) ((@CryptolPrimitives.seq (n) (a))))) => (@CryptolPrimitives.ecCat ((@TCNum (1))) (k) ((@CryptolPrimitives.seq (n) (a))) ((Vector.cons (_) (xs0) (_) ((Vector.nil (_))))) ((@SAWCoreScaffolding.coerce ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcMin ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (k))) ((@CryptolPrimitives.tcMin (k) (k))))) ((@CryptolPrimitives.seq (n) (a))))) ((@CryptolPrimitives.seq (k) ((@CryptolPrimitives.seq (n) (a))))) ((@CryptolPrimitives.seq_cong1 ((@CryptolPrimitives.tcMin ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (k))) ((@CryptolPrimitives.tcMin (k) (k))))) (k) ((@CryptolPrimitives.seq (n) (a))) ((@SAWCorePrelude.sawUnsafeAssert ((@Num)) ((@CryptolPrimitives.tcMin ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (k))) ((@CryptolPrimitives.tcMin (k) (k))))) (k))))) ((@CryptolPrimitives.seqMap ((prod ((@CryptolPrimitives.seq (n) (a))) ((prod ((@CryptolPrimitives.seq (ix) (@SAWCoreScaffolding.Bool))) (a))))) ((@CryptolPrimitives.seq (n) (a))) ((@CryptolPrimitives.tcMin ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (k))) ((@CryptolPrimitives.tcMin (k) (k))))) ((@SAWCorePrelude.uncurry ((@CryptolPrimitives.seq (n) (a))) ((prod ((@CryptolPrimitives.seq (ix) (@SAWCoreScaffolding.Bool))) (a))) ((@CryptolPrimitives.seq (n) (a))) ((fun (xs : (@CryptolPrimitives.seq (n) (a))) => (@SAWCorePrelude.uncurry ((@CryptolPrimitives.seq (ix) (@SAWCoreScaffolding.Bool))) (a) ((@CryptolPrimitives.seq (n) (a))) ((fun (i : (@CryptolPrimitives.seq (ix) (@SAWCoreScaffolding.Bool))) (b : a) => (@CryptolPrimitives.ecUpdateEnd (n) (a) (ix) (xs) (i) (b))))))))) ((@CryptolPrimitives.seqZip ((@CryptolPrimitives.seq (n) (a))) ((prod ((@CryptolPrimitives.seq (ix) (@SAWCoreScaffolding.Bool))) (a))) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (k))) ((@CryptolPrimitives.tcMin (k) (k))) (xss) ((@CryptolPrimitives.seqZip ((@CryptolPrimitives.seq (ix) (@SAWCoreScaffolding.Bool))) (a) (k) (k) (idxs) (vals)))))))))))) ((CryptolPrimitives.seqConst ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (k))) ((@CryptolPrimitives.seq (n) (a))) ((CryptolPrimitives.seqConst (n) (a) ((error ("Could not generate default value of type !3"))))))))) ((@CryptolPrimitives.ecNumber ((@TCNum (0))) ((@CryptolPrimitives.seq ((@TCNum (0))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.PLiteralSeqBool ((@TCNum (0)))))))). + +Definition last (n : (@Num)) (a : Type) (xs : (@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (n))) (a))) := + (@CryptolPrimitives.ecAtBack ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (n))) (a) ((@TCNum (0))) (xs) ((@CryptolPrimitives.ecNumber ((@TCNum (0))) ((@CryptolPrimitives.seq ((@TCNum (0))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.PLiteralSeqBool ((@TCNum (0)))))))). + +Definition pmult (u : (@Num)) (v : (@Num)) (x : (@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (u))) (@SAWCoreScaffolding.Bool))) (y : (@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))) (@SAWCoreScaffolding.Bool))) := + (last ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@CryptolPrimitives.tcAdd (u) (v))))) (@SAWCoreScaffolding.Bool))) ((@SAWCoreScaffolding.coerce ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (2))) (v))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@CryptolPrimitives.tcAdd (u) (v))))) (@SAWCoreScaffolding.Bool))))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@CryptolPrimitives.tcAdd (u) (v))))) (@SAWCoreScaffolding.Bool))))) ((@CryptolPrimitives.seq_cong1 ((@CryptolPrimitives.tcAdd ((@TCNum (2))) (v))) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@CryptolPrimitives.tcAdd (u) (v))))) (@SAWCoreScaffolding.Bool))) ((@SAWCorePrelude.sawUnsafeAssert ((@Num)) ((@CryptolPrimitives.tcAdd ((@TCNum (2))) (v))) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))))))))) ((iter ((@CryptolPrimitives.tcAdd ((@TCNum (2))) (v))) ((fun (zs : (@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (2))) (v))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@CryptolPrimitives.tcAdd (u) (v))))) (@SAWCoreScaffolding.Bool))))) => (@SAWCoreScaffolding.coerce ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@CryptolPrimitives.tcAdd (u) (v))))) (@SAWCoreScaffolding.Bool))))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (2))) (v))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@CryptolPrimitives.tcAdd (u) (v))))) (@SAWCoreScaffolding.Bool))))) ((@CryptolPrimitives.seq_cong1 ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))))) ((@CryptolPrimitives.tcAdd ((@TCNum (2))) (v))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@CryptolPrimitives.tcAdd (u) (v))))) (@SAWCoreScaffolding.Bool))) ((@SAWCorePrelude.sawUnsafeAssert ((@Num)) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))))) ((@CryptolPrimitives.tcAdd ((@TCNum (2))) (v))))))) ((@CryptolPrimitives.ecCat ((@TCNum (1))) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@CryptolPrimitives.tcAdd (u) (v))))) (@SAWCoreScaffolding.Bool))) ((Vector.cons (_) ((@CryptolPrimitives.ecNumber ((@TCNum (0))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@CryptolPrimitives.tcAdd (u) (v))))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.PLiteralSeqBool ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@CryptolPrimitives.tcAdd (u) (v))))))))) (_) ((Vector.nil (_))))) ((@SAWCoreScaffolding.coerce ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcMin ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))) ((@CryptolPrimitives.tcAdd ((@TCNum (2))) (v))))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@CryptolPrimitives.tcAdd (u) (v))))) (@SAWCoreScaffolding.Bool))))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@CryptolPrimitives.tcAdd (u) (v))))) (@SAWCoreScaffolding.Bool))))) ((@CryptolPrimitives.seq_cong1 ((@CryptolPrimitives.tcMin ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))) ((@CryptolPrimitives.tcAdd ((@TCNum (2))) (v))))) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@CryptolPrimitives.tcAdd (u) (v))))) (@SAWCoreScaffolding.Bool))) ((@SAWCorePrelude.sawUnsafeAssert ((@Num)) ((@CryptolPrimitives.tcMin ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))) ((@CryptolPrimitives.tcAdd ((@TCNum (2))) (v))))) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))))))) ((@CryptolPrimitives.seqMap ((prod (@SAWCoreScaffolding.Bool) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@CryptolPrimitives.tcAdd (u) (v))))) (@SAWCoreScaffolding.Bool))))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@CryptolPrimitives.tcAdd (u) (v))))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.tcMin ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))) ((@CryptolPrimitives.tcAdd ((@TCNum (2))) (v))))) ((@SAWCorePrelude.uncurry (@SAWCoreScaffolding.Bool) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@CryptolPrimitives.tcAdd (u) (v))))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@CryptolPrimitives.tcAdd (u) (v))))) (@SAWCoreScaffolding.Bool))) ((fun (yi : @SAWCoreScaffolding.Bool) (z : (@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@CryptolPrimitives.tcAdd (u) (v))))) (@SAWCoreScaffolding.Bool))) => (@CryptolPrimitives.ecXor ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@CryptolPrimitives.tcAdd (u) (v))))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.PLogicSeqBool ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@CryptolPrimitives.tcAdd (u) (v))))))) ((@CryptolPrimitives.ecShiftL ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@CryptolPrimitives.tcAdd (u) (v))))) ((@TCNum (1))) (@SAWCoreScaffolding.Bool) (@CryptolPrimitives.PZeroBit) (z) ((@CryptolPrimitives.ecNumber ((@TCNum (1))) ((@CryptolPrimitives.seq ((@TCNum (1))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.PLiteralSeqBool ((@TCNum (1))))))))) (if yi then (@SAWCoreScaffolding.coerce ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd (v) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (u))))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@CryptolPrimitives.tcAdd (u) (v))))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.seq_cong1 ((@CryptolPrimitives.tcAdd (v) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (u))))) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@CryptolPrimitives.tcAdd (u) (v))))) (@SAWCoreScaffolding.Bool) ((@SAWCorePrelude.sawUnsafeAssert ((@Num)) ((@CryptolPrimitives.tcAdd (v) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (u))))) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@CryptolPrimitives.tcAdd (u) (v))))))))) ((@CryptolPrimitives.ecCat (v) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (u))) (@SAWCoreScaffolding.Bool) ((@CryptolPrimitives.ecNumber ((@TCNum (0))) ((@CryptolPrimitives.seq (v) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.PLiteralSeqBool (v))))) (x)))) else (@CryptolPrimitives.ecNumber ((@TCNum (0))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@CryptolPrimitives.tcAdd (u) (v))))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.PLiteralSeqBool ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@CryptolPrimitives.tcAdd (u) (v)))))))))))))) ((@CryptolPrimitives.seqZip (@SAWCoreScaffolding.Bool) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@CryptolPrimitives.tcAdd (u) (v))))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))) ((@CryptolPrimitives.tcAdd ((@TCNum (2))) (v))) (y) (zs)))))))))))) ((CryptolPrimitives.seqConst ((@CryptolPrimitives.tcAdd ((@TCNum (2))) (v))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@CryptolPrimitives.tcAdd (u) (v))))) (@SAWCoreScaffolding.Bool))) ((CryptolPrimitives.seqConst ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@CryptolPrimitives.tcAdd (u) (v))))) (@SAWCoreScaffolding.Bool) (SAWCoreScaffolding.False)))))))))). + +Definition drop (front : (@Num)) (back : (@Num)) (a : Type) (__p4 : (@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd (front) (back))) (a))) := + (snd ((@CryptolPrimitives.ecSplitAt (front) (back) (a) (__p4)))). + +Definition tail (n : (@Num)) (a : Type) (xs : (@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (n))) (a))) := + (drop ((@TCNum (1))) (n) (a) (xs)). + +Definition pdiv (u : (@Num)) (v : (@Num)) (x : (@CryptolPrimitives.seq (u) (@SAWCoreScaffolding.Bool))) (y : (@CryptolPrimitives.seq (v) (@SAWCoreScaffolding.Bool))) := + (@CryptolPrimitives.seqMap ((@CryptolPrimitives.seq (v) (@SAWCoreScaffolding.Bool))) (@SAWCoreScaffolding.Bool) (u) ((fun (z : (@CryptolPrimitives.seq (v) (@SAWCoreScaffolding.Bool))) => (@CryptolPrimitives.ecAtBack (v) (@SAWCoreScaffolding.Bool) ((@CryptolPrimitives.tcWidth (v))) (z) ((last (v) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((iter ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))) ((fun (ds : (@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))))) => (@CryptolPrimitives.ecCat ((@TCNum (1))) (v) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((Vector.cons (_) ((@CryptolPrimitives.ecDiv ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.PArithSeqBool ((@CryptolPrimitives.tcWidth (v))))) ((@CryptolPrimitives.ecNumber ((@TCNum (0))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.PLiteralSeqBool ((@CryptolPrimitives.tcWidth (v))))))) ((@CryptolPrimitives.ecNumber ((@TCNum (0))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.PLiteralSeqBool ((@CryptolPrimitives.tcWidth (v))))))))) (_) ((Vector.nil (_))))) ((@SAWCoreScaffolding.coerce ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcMin (v) ((@CryptolPrimitives.tcMin ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@CryptolPrimitives.tcSub (v) ((@TCNum (0))))))) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))))))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))))) ((@CryptolPrimitives.seq (v) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))))) ((@CryptolPrimitives.seq_cong1 ((@CryptolPrimitives.tcMin (v) ((@CryptolPrimitives.tcMin ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@CryptolPrimitives.tcSub (v) ((@TCNum (0))))))) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))))))) (v) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((@SAWCorePrelude.sawUnsafeAssert ((@Num)) ((@CryptolPrimitives.tcMin (v) ((@CryptolPrimitives.tcMin ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@CryptolPrimitives.tcSub (v) ((@TCNum (0))))))) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))))))) (v))))) ((@CryptolPrimitives.seqMap ((prod (@SAWCoreScaffolding.Bool) ((prod ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))))))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.tcMin (v) ((@CryptolPrimitives.tcMin ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@CryptolPrimitives.tcSub (v) ((@TCNum (0))))))) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))))))) ((@SAWCorePrelude.uncurry (@SAWCoreScaffolding.Bool) ((prod ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((fun (yi : @SAWCoreScaffolding.Bool) => (@SAWCorePrelude.uncurry ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((fun (i : (@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) (d : (@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) => if yi then i else d))))))) ((@CryptolPrimitives.seqZip (@SAWCoreScaffolding.Bool) ((prod ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))))) (v) ((@CryptolPrimitives.tcMin ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@CryptolPrimitives.tcSub (v) ((@TCNum (0))))))) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))))) ((@CryptolPrimitives.ecReverse (v) (@SAWCoreScaffolding.Bool) (y))) ((@CryptolPrimitives.seqZip ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@CryptolPrimitives.tcSub (v) ((@TCNum (0))))))) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))) ((@CryptolPrimitives.ecFromTo ((@TCNum (0))) (v) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.PLiteralSeqBool ((@CryptolPrimitives.tcWidth (v))))))) (ds)))))))))))) ((CryptolPrimitives.seqConst ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((CryptolPrimitives.seqConst ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool) (SAWCoreScaffolding.False)))))))))))) ((iter (u) ((fun (zs : (@CryptolPrimitives.seq (u) ((@CryptolPrimitives.seq (v) (@SAWCoreScaffolding.Bool))))) => (@SAWCoreScaffolding.coerce ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcMin ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (u))) (u))) ((@CryptolPrimitives.seq (v) (@SAWCoreScaffolding.Bool))))) ((@CryptolPrimitives.seq (u) ((@CryptolPrimitives.seq (v) (@SAWCoreScaffolding.Bool))))) ((@CryptolPrimitives.seq_cong1 ((@CryptolPrimitives.tcMin ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (u))) (u))) (u) ((@CryptolPrimitives.seq (v) (@SAWCoreScaffolding.Bool))) ((@SAWCorePrelude.sawUnsafeAssert ((@Num)) ((@CryptolPrimitives.tcMin ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (u))) (u))) (u))))) ((@CryptolPrimitives.seqMap ((prod ((@CryptolPrimitives.seq (v) (@SAWCoreScaffolding.Bool))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.seq (v) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.tcMin ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (u))) (u))) ((@SAWCorePrelude.uncurry ((@CryptolPrimitives.seq (v) (@SAWCoreScaffolding.Bool))) (@SAWCoreScaffolding.Bool) ((@CryptolPrimitives.seq (v) (@SAWCoreScaffolding.Bool))) ((fun (z : (@CryptolPrimitives.seq (v) (@SAWCoreScaffolding.Bool))) (xi : @SAWCoreScaffolding.Bool) => (tail (v) (@SAWCoreScaffolding.Bool) ((@SAWCoreScaffolding.coerce ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd (v) ((@TCNum (1))))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.seq_cong1 ((@CryptolPrimitives.tcAdd (v) ((@TCNum (1))))) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))) (@SAWCoreScaffolding.Bool) ((@SAWCorePrelude.sawUnsafeAssert ((@Num)) ((@CryptolPrimitives.tcAdd (v) ((@TCNum (1))))) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))))))) ((@CryptolPrimitives.ecCat (v) ((@TCNum (1))) (@SAWCoreScaffolding.Bool) (((fun (u : (@CryptolPrimitives.seq (v) (@SAWCoreScaffolding.Bool))) => if (@CryptolPrimitives.ecAtBack (v) (@SAWCoreScaffolding.Bool) ((@CryptolPrimitives.tcWidth (v))) (u) ((last (v) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((iter ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))) ((fun (ds : (@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))))) => (@CryptolPrimitives.ecCat ((@TCNum (1))) (v) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((Vector.cons (_) ((@CryptolPrimitives.ecDiv ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.PArithSeqBool ((@CryptolPrimitives.tcWidth (v))))) ((@CryptolPrimitives.ecNumber ((@TCNum (0))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.PLiteralSeqBool ((@CryptolPrimitives.tcWidth (v))))))) ((@CryptolPrimitives.ecNumber ((@TCNum (0))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.PLiteralSeqBool ((@CryptolPrimitives.tcWidth (v))))))))) (_) ((Vector.nil (_))))) ((@SAWCoreScaffolding.coerce ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcMin (v) ((@CryptolPrimitives.tcMin ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@CryptolPrimitives.tcSub (v) ((@TCNum (0))))))) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))))))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))))) ((@CryptolPrimitives.seq (v) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))))) ((@CryptolPrimitives.seq_cong1 ((@CryptolPrimitives.tcMin (v) ((@CryptolPrimitives.tcMin ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@CryptolPrimitives.tcSub (v) ((@TCNum (0))))))) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))))))) (v) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((@SAWCorePrelude.sawUnsafeAssert ((@Num)) ((@CryptolPrimitives.tcMin (v) ((@CryptolPrimitives.tcMin ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@CryptolPrimitives.tcSub (v) ((@TCNum (0))))))) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))))))) (v))))) ((@CryptolPrimitives.seqMap ((prod (@SAWCoreScaffolding.Bool) ((prod ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))))))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.tcMin (v) ((@CryptolPrimitives.tcMin ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@CryptolPrimitives.tcSub (v) ((@TCNum (0))))))) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))))))) ((@SAWCorePrelude.uncurry (@SAWCoreScaffolding.Bool) ((prod ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((fun (yi : @SAWCoreScaffolding.Bool) => (@SAWCorePrelude.uncurry ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((fun (i : (@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) (d : (@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) => if yi then i else d))))))) ((@CryptolPrimitives.seqZip (@SAWCoreScaffolding.Bool) ((prod ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))))) (v) ((@CryptolPrimitives.tcMin ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@CryptolPrimitives.tcSub (v) ((@TCNum (0))))))) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))))) ((@CryptolPrimitives.ecReverse (v) (@SAWCoreScaffolding.Bool) (y))) ((@CryptolPrimitives.seqZip ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@CryptolPrimitives.tcSub (v) ((@TCNum (0))))))) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))) ((@CryptolPrimitives.ecFromTo ((@TCNum (0))) (v) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.PLiteralSeqBool ((@CryptolPrimitives.tcWidth (v))))))) (ds)))))))))))) ((CryptolPrimitives.seqConst ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((CryptolPrimitives.seqConst ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool) (SAWCoreScaffolding.False)))))))))) then (@CryptolPrimitives.ecXor ((@CryptolPrimitives.seq (v) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.PLogicSeqBool (v))) (u) (y)) else u) (z))) ((Vector.cons (_) (xi) (_) ((Vector.nil (_)))))))))))))) ((@CryptolPrimitives.seqZip ((@CryptolPrimitives.seq (v) (@SAWCoreScaffolding.Bool))) (@SAWCoreScaffolding.Bool) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (u))) (u) ((@CryptolPrimitives.ecCat ((@TCNum (1))) (u) ((@CryptolPrimitives.seq (v) (@SAWCoreScaffolding.Bool))) ((Vector.cons (_) ((@CryptolPrimitives.ecNumber ((@TCNum (0))) ((@CryptolPrimitives.seq (v) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.PLiteralSeqBool (v))))) (_) ((Vector.nil (_))))) (zs))) (x)))))))) ((CryptolPrimitives.seqConst (u) ((@CryptolPrimitives.seq (v) (@SAWCoreScaffolding.Bool))) ((CryptolPrimitives.seqConst (v) (@SAWCoreScaffolding.Bool) (SAWCoreScaffolding.False)))))))). + +Definition pmod (u : (@Num)) (v : (@Num)) (x : (@CryptolPrimitives.seq (u) (@SAWCoreScaffolding.Bool))) (y : (@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))) (@SAWCoreScaffolding.Bool))) := + if (@CryptolPrimitives.ecEq ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.PCmpSeqBool ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))))) (y) ((@CryptolPrimitives.ecNumber ((@TCNum (0))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.PLiteralSeqBool ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v)))))))) then (@CryptolPrimitives.ecDiv ((@CryptolPrimitives.seq (v) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.PArithSeqBool (v))) ((@CryptolPrimitives.ecNumber ((@TCNum (0))) ((@CryptolPrimitives.seq (v) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.PLiteralSeqBool (v))))) ((@CryptolPrimitives.ecNumber ((@TCNum (0))) ((@CryptolPrimitives.seq (v) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.PLiteralSeqBool (v)))))) else (last (u) ((@CryptolPrimitives.seq (v) (@SAWCoreScaffolding.Bool))) ((iter ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (u))) ((fun (zs : (@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (u))) ((@CryptolPrimitives.seq (v) (@SAWCoreScaffolding.Bool))))) => (@CryptolPrimitives.ecCat ((@TCNum (1))) (u) ((@CryptolPrimitives.seq (v) (@SAWCoreScaffolding.Bool))) ((Vector.cons (_) ((@CryptolPrimitives.ecNumber ((@TCNum (0))) ((@CryptolPrimitives.seq (v) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.PLiteralSeqBool (v))))) (_) ((Vector.nil (_))))) ((@SAWCoreScaffolding.coerce ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcMin (u) ((@CryptolPrimitives.tcMin ((@TCInf)) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (u))))))) ((@CryptolPrimitives.seq (v) (@SAWCoreScaffolding.Bool))))) ((@CryptolPrimitives.seq (u) ((@CryptolPrimitives.seq (v) (@SAWCoreScaffolding.Bool))))) ((@CryptolPrimitives.seq_cong1 ((@CryptolPrimitives.tcMin (u) ((@CryptolPrimitives.tcMin ((@TCInf)) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (u))))))) (u) ((@CryptolPrimitives.seq (v) (@SAWCoreScaffolding.Bool))) ((@SAWCorePrelude.sawUnsafeAssert ((@Num)) ((@CryptolPrimitives.tcMin (u) ((@CryptolPrimitives.tcMin ((@TCInf)) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (u))))))) (u))))) ((@CryptolPrimitives.seqMap ((prod (@SAWCoreScaffolding.Bool) ((prod ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.seq (v) (@SAWCoreScaffolding.Bool))))))) ((@CryptolPrimitives.seq (v) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.tcMin (u) ((@CryptolPrimitives.tcMin ((@TCInf)) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (u))))))) ((@SAWCorePrelude.uncurry (@SAWCoreScaffolding.Bool) ((prod ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.seq (v) (@SAWCoreScaffolding.Bool))))) ((@CryptolPrimitives.seq (v) (@SAWCoreScaffolding.Bool))) ((fun (xi : @SAWCoreScaffolding.Bool) => (@SAWCorePrelude.uncurry ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.seq (v) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.seq (v) (@SAWCoreScaffolding.Bool))) ((fun (p : (@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))) (@SAWCoreScaffolding.Bool))) (z : (@CryptolPrimitives.seq (v) (@SAWCoreScaffolding.Bool))) => (@CryptolPrimitives.ecXor ((@CryptolPrimitives.seq (v) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.PLogicSeqBool (v))) (z) (if xi then (tail (v) (@SAWCoreScaffolding.Bool) (p)) else (@CryptolPrimitives.ecNumber ((@TCNum (0))) ((@CryptolPrimitives.seq (v) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.PLiteralSeqBool (v))))))))))))) ((@CryptolPrimitives.seqZip (@SAWCoreScaffolding.Bool) ((prod ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.seq (v) (@SAWCoreScaffolding.Bool))))) (u) ((@CryptolPrimitives.tcMin ((@TCInf)) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (u))))) ((@CryptolPrimitives.ecReverse (u) (@SAWCoreScaffolding.Bool) (x))) ((@CryptolPrimitives.seqZip ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.seq (v) (@SAWCoreScaffolding.Bool))) ((@TCInf)) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (u))) ((iter ((@TCInf)) ((fun (powers : (@CryptolPrimitives.seq ((@TCInf)) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))) (@SAWCoreScaffolding.Bool))))) => (@SAWCoreScaffolding.coerce ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@TCInf)))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))) (@SAWCoreScaffolding.Bool))))) ((@CryptolPrimitives.seq ((@TCInf)) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))) (@SAWCoreScaffolding.Bool))))) ((@CryptolPrimitives.seq_cong1 ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@TCInf)))) ((@TCInf)) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))) (@SAWCoreScaffolding.Bool))) ((@SAWCorePrelude.sawUnsafeAssert ((@Num)) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@TCInf)))) ((@TCInf)))))) ((@CryptolPrimitives.ecCat ((@TCNum (1))) ((@TCInf)) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))) (@SAWCoreScaffolding.Bool))) ((Vector.cons (_) (((fun (u : (@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))) (@SAWCoreScaffolding.Bool))) => if (@CryptolPrimitives.ecAtBack ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))) (@SAWCoreScaffolding.Bool) ((@CryptolPrimitives.tcWidth (v))) (u) ((last ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((@SAWCoreScaffolding.coerce ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (2))) (v))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))))) ((@CryptolPrimitives.seq_cong1 ((@CryptolPrimitives.tcAdd ((@TCNum (2))) (v))) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((@SAWCorePrelude.sawUnsafeAssert ((@Num)) ((@CryptolPrimitives.tcAdd ((@TCNum (2))) (v))) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))))))))) ((iter ((@CryptolPrimitives.tcAdd ((@TCNum (2))) (v))) ((fun (ds : (@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (2))) (v))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))))) => (@SAWCoreScaffolding.coerce ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (2))) (v))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))))) ((@CryptolPrimitives.seq_cong1 ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))))) ((@CryptolPrimitives.tcAdd ((@TCNum (2))) (v))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((@SAWCorePrelude.sawUnsafeAssert ((@Num)) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))))) ((@CryptolPrimitives.tcAdd ((@TCNum (2))) (v))))))) ((@CryptolPrimitives.ecCat ((@TCNum (1))) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((Vector.cons (_) ((@CryptolPrimitives.ecDiv ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.PArithSeqBool ((@CryptolPrimitives.tcWidth (v))))) ((@CryptolPrimitives.ecNumber ((@TCNum (0))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.PLiteralSeqBool ((@CryptolPrimitives.tcWidth (v))))))) ((@CryptolPrimitives.ecNumber ((@TCNum (0))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.PLiteralSeqBool ((@CryptolPrimitives.tcWidth (v))))))))) (_) ((Vector.nil (_))))) ((@SAWCoreScaffolding.coerce ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcMin ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))) ((@CryptolPrimitives.tcMin ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@CryptolPrimitives.tcSub (v) ((@TCNum (0))))))) ((@CryptolPrimitives.tcAdd ((@TCNum (2))) (v))))))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))))) ((@CryptolPrimitives.seq_cong1 ((@CryptolPrimitives.tcMin ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))) ((@CryptolPrimitives.tcMin ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@CryptolPrimitives.tcSub (v) ((@TCNum (0))))))) ((@CryptolPrimitives.tcAdd ((@TCNum (2))) (v))))))) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((@SAWCorePrelude.sawUnsafeAssert ((@Num)) ((@CryptolPrimitives.tcMin ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))) ((@CryptolPrimitives.tcMin ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@CryptolPrimitives.tcSub (v) ((@TCNum (0))))))) ((@CryptolPrimitives.tcAdd ((@TCNum (2))) (v))))))) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))))))) ((@CryptolPrimitives.seqMap ((prod (@SAWCoreScaffolding.Bool) ((prod ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))))))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.tcMin ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))) ((@CryptolPrimitives.tcMin ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@CryptolPrimitives.tcSub (v) ((@TCNum (0))))))) ((@CryptolPrimitives.tcAdd ((@TCNum (2))) (v))))))) ((@SAWCorePrelude.uncurry (@SAWCoreScaffolding.Bool) ((prod ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((fun (yi : @SAWCoreScaffolding.Bool) => (@SAWCorePrelude.uncurry ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((fun (i : (@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) (d : (@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) => if yi then i else d))))))) ((@CryptolPrimitives.seqZip (@SAWCoreScaffolding.Bool) ((prod ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))))) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))) ((@CryptolPrimitives.tcMin ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@CryptolPrimitives.tcSub (v) ((@TCNum (0))))))) ((@CryptolPrimitives.tcAdd ((@TCNum (2))) (v))))) ((@CryptolPrimitives.ecReverse ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))) (@SAWCoreScaffolding.Bool) (y))) ((@CryptolPrimitives.seqZip ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@CryptolPrimitives.tcSub (v) ((@TCNum (0))))))) ((@CryptolPrimitives.tcAdd ((@TCNum (2))) (v))) ((@CryptolPrimitives.ecFromTo ((@TCNum (0))) (v) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.PLiteralSeqBool ((@CryptolPrimitives.tcWidth (v))))))) (ds)))))))))))))) ((CryptolPrimitives.seqConst ((@CryptolPrimitives.tcAdd ((@TCNum (2))) (v))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((CryptolPrimitives.seqConst ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool) (SAWCoreScaffolding.False)))))))))))) then (@CryptolPrimitives.ecXor ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.PLogicSeqBool ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))))) (u) (y)) else u) ((@CryptolPrimitives.ecNumber ((@TCNum (1))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.PLiteralSeqBool ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))))))))) (_) ((Vector.nil (_))))) ((@CryptolPrimitives.seqMap ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))) (@SAWCoreScaffolding.Bool))) ((@TCInf)) ((fun (p : (@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))) (@SAWCoreScaffolding.Bool))) => ((fun (u : (@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))) (@SAWCoreScaffolding.Bool))) => if (@CryptolPrimitives.ecAtBack ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))) (@SAWCoreScaffolding.Bool) ((@CryptolPrimitives.tcWidth (v))) (u) ((last ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((@SAWCoreScaffolding.coerce ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (2))) (v))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))))) ((@CryptolPrimitives.seq_cong1 ((@CryptolPrimitives.tcAdd ((@TCNum (2))) (v))) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((@SAWCorePrelude.sawUnsafeAssert ((@Num)) ((@CryptolPrimitives.tcAdd ((@TCNum (2))) (v))) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))))))))) ((iter ((@CryptolPrimitives.tcAdd ((@TCNum (2))) (v))) ((fun (ds : (@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (2))) (v))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))))) => (@SAWCoreScaffolding.coerce ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (2))) (v))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))))) ((@CryptolPrimitives.seq_cong1 ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))))) ((@CryptolPrimitives.tcAdd ((@TCNum (2))) (v))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((@SAWCorePrelude.sawUnsafeAssert ((@Num)) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))))) ((@CryptolPrimitives.tcAdd ((@TCNum (2))) (v))))))) ((@CryptolPrimitives.ecCat ((@TCNum (1))) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((Vector.cons (_) ((@CryptolPrimitives.ecDiv ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.PArithSeqBool ((@CryptolPrimitives.tcWidth (v))))) ((@CryptolPrimitives.ecNumber ((@TCNum (0))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.PLiteralSeqBool ((@CryptolPrimitives.tcWidth (v))))))) ((@CryptolPrimitives.ecNumber ((@TCNum (0))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.PLiteralSeqBool ((@CryptolPrimitives.tcWidth (v))))))))) (_) ((Vector.nil (_))))) ((@SAWCoreScaffolding.coerce ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcMin ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))) ((@CryptolPrimitives.tcMin ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@CryptolPrimitives.tcSub (v) ((@TCNum (0))))))) ((@CryptolPrimitives.tcAdd ((@TCNum (2))) (v))))))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))))) ((@CryptolPrimitives.seq_cong1 ((@CryptolPrimitives.tcMin ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))) ((@CryptolPrimitives.tcMin ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@CryptolPrimitives.tcSub (v) ((@TCNum (0))))))) ((@CryptolPrimitives.tcAdd ((@TCNum (2))) (v))))))) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((@SAWCorePrelude.sawUnsafeAssert ((@Num)) ((@CryptolPrimitives.tcMin ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))) ((@CryptolPrimitives.tcMin ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@CryptolPrimitives.tcSub (v) ((@TCNum (0))))))) ((@CryptolPrimitives.tcAdd ((@TCNum (2))) (v))))))) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))))))) ((@CryptolPrimitives.seqMap ((prod (@SAWCoreScaffolding.Bool) ((prod ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))))))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.tcMin ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))) ((@CryptolPrimitives.tcMin ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@CryptolPrimitives.tcSub (v) ((@TCNum (0))))))) ((@CryptolPrimitives.tcAdd ((@TCNum (2))) (v))))))) ((@SAWCorePrelude.uncurry (@SAWCoreScaffolding.Bool) ((prod ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((fun (yi : @SAWCoreScaffolding.Bool) => (@SAWCorePrelude.uncurry ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((fun (i : (@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) (d : (@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) => if yi then i else d))))))) ((@CryptolPrimitives.seqZip (@SAWCoreScaffolding.Bool) ((prod ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))))) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))) ((@CryptolPrimitives.tcMin ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@CryptolPrimitives.tcSub (v) ((@TCNum (0))))))) ((@CryptolPrimitives.tcAdd ((@TCNum (2))) (v))))) ((@CryptolPrimitives.ecReverse ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))) (@SAWCoreScaffolding.Bool) (y))) ((@CryptolPrimitives.seqZip ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) ((@CryptolPrimitives.tcSub (v) ((@TCNum (0))))))) ((@CryptolPrimitives.tcAdd ((@TCNum (2))) (v))) ((@CryptolPrimitives.ecFromTo ((@TCNum (0))) (v) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.PLiteralSeqBool ((@CryptolPrimitives.tcWidth (v))))))) (ds)))))))))))))) ((CryptolPrimitives.seqConst ((@CryptolPrimitives.tcAdd ((@TCNum (2))) (v))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool))) ((CryptolPrimitives.seqConst ((@CryptolPrimitives.tcWidth (v))) (@SAWCoreScaffolding.Bool) (SAWCoreScaffolding.False)))))))))))) then (@CryptolPrimitives.ecXor ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.PLogicSeqBool ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))))) (u) (y)) else u) ((@CryptolPrimitives.ecShiftL ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))) ((@TCNum (1))) (@SAWCoreScaffolding.Bool) (@CryptolPrimitives.PZeroBit) (p) ((@CryptolPrimitives.ecNumber ((@TCNum (1))) ((@CryptolPrimitives.seq ((@TCNum (1))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.PLiteralSeqBool ((@TCNum (1)))))))))))) (powers)))))))) ((CryptolPrimitives.seqConst ((@TCInf)) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))) (@SAWCoreScaffolding.Bool))) ((CryptolPrimitives.seqConst ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (v))) (@SAWCoreScaffolding.Bool) (SAWCoreScaffolding.False))))))) (zs)))))))))))) ((CryptolPrimitives.seqConst ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (u))) ((@CryptolPrimitives.seq (v) (@SAWCoreScaffolding.Bool))) ((CryptolPrimitives.seqConst (v) (@SAWCoreScaffolding.Bool) (SAWCoreScaffolding.False)))))))). + +Definition take (front : (@Num)) (back : (@Num)) (a : Type) (__p1 : (@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd (front) (back))) (a))) := + (fst ((@CryptolPrimitives.ecSplitAt (front) (back) (a) (__p1)))). + +Definition head (n : (@Num)) (a : Type) (xs : (@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (n))) (a))) := + (@CryptolPrimitives.ecAt ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (n))) (a) ((@TCNum (0))) (xs) ((@CryptolPrimitives.ecNumber ((@TCNum (0))) ((@CryptolPrimitives.seq ((@TCNum (0))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.PLiteralSeqBool ((@TCNum (0)))))))). + +Definition length (n : (@Num)) (a : Type) (b : Type) (_P : (@CryptolPrimitives.PLiteral (b))) (__p6 : (@CryptolPrimitives.seq (n) (a))) := + (@CryptolPrimitives.ecNumber (n) (b) (_P)). + +Definition undefined (a : Type) := + (@CryptolPrimitives.ecError (a) ((@TCNum (9))) ((Vector.cons (_) ((@CryptolPrimitives.ecNumber ((@TCNum (117))) ((@CryptolPrimitives.seq ((@TCNum (8))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.PLiteralSeqBool ((@TCNum (8))))))) (_) ((Vector.cons (_) ((@CryptolPrimitives.ecNumber ((@TCNum (110))) ((@CryptolPrimitives.seq ((@TCNum (8))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.PLiteralSeqBool ((@TCNum (8))))))) (_) ((Vector.cons (_) ((@CryptolPrimitives.ecNumber ((@TCNum (100))) ((@CryptolPrimitives.seq ((@TCNum (8))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.PLiteralSeqBool ((@TCNum (8))))))) (_) ((Vector.cons (_) ((@CryptolPrimitives.ecNumber ((@TCNum (101))) ((@CryptolPrimitives.seq ((@TCNum (8))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.PLiteralSeqBool ((@TCNum (8))))))) (_) ((Vector.cons (_) ((@CryptolPrimitives.ecNumber ((@TCNum (102))) ((@CryptolPrimitives.seq ((@TCNum (8))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.PLiteralSeqBool ((@TCNum (8))))))) (_) ((Vector.cons (_) ((@CryptolPrimitives.ecNumber ((@TCNum (105))) ((@CryptolPrimitives.seq ((@TCNum (8))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.PLiteralSeqBool ((@TCNum (8))))))) (_) ((Vector.cons (_) ((@CryptolPrimitives.ecNumber ((@TCNum (110))) ((@CryptolPrimitives.seq ((@TCNum (8))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.PLiteralSeqBool ((@TCNum (8))))))) (_) ((Vector.cons (_) ((@CryptolPrimitives.ecNumber ((@TCNum (101))) ((@CryptolPrimitives.seq ((@TCNum (8))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.PLiteralSeqBool ((@TCNum (8))))))) (_) ((Vector.cons (_) ((@CryptolPrimitives.ecNumber ((@TCNum (100))) ((@CryptolPrimitives.seq ((@TCNum (8))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.PLiteralSeqBool ((@TCNum (8))))))) (_) ((Vector.nil (_)))))))))))))))))))))). + +Definition groupBy (each : (@Num)) (parts : (@Num)) (a : Type) := + (@SAWCoreScaffolding.coerce (((@CryptolPrimitives.seq ((@CryptolPrimitives.tcMul (parts) (each))) (a))) -> (@CryptolPrimitives.seq (parts) ((@CryptolPrimitives.seq (each) (a))))) (((@CryptolPrimitives.seq ((@CryptolPrimitives.tcMul (each) (parts))) (a))) -> (@CryptolPrimitives.seq (parts) ((@CryptolPrimitives.seq (each) (a))))) ((@CryptolPrimitives.fun_cong ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcMul (parts) (each))) (a))) ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcMul (each) (parts))) (a))) ((@CryptolPrimitives.seq (parts) ((@CryptolPrimitives.seq (each) (a))))) ((@CryptolPrimitives.seq (parts) ((@CryptolPrimitives.seq (each) (a))))) ((@CryptolPrimitives.seq_cong1 ((@CryptolPrimitives.tcMul (parts) (each))) ((@CryptolPrimitives.tcMul (each) (parts))) (a) ((@SAWCorePrelude.sawUnsafeAssert ((@Num)) ((@CryptolPrimitives.tcMul (parts) (each))) ((@CryptolPrimitives.tcMul (each) (parts))))))) ((@Refl (Type) ((@CryptolPrimitives.seq (parts) ((@CryptolPrimitives.seq (each) (a))))))))) ((@CryptolPrimitives.ecSplit (parts) (each) (a)))). + +Definition traceVal (n : (@Num)) (a : Type) (msg : (@CryptolPrimitives.seq (n) ((@CryptolPrimitives.seq ((@TCNum (8))) (@SAWCoreScaffolding.Bool))))) (x : a) := + (@CryptolPrimitives.ecTrace (n) (a) (a) (msg) (x) (x)). + +Definition or (n : (@Num)) (xs : (@CryptolPrimitives.seq (n) (@SAWCoreScaffolding.Bool))) := + (@CryptolPrimitives.ecNotEq ((@CryptolPrimitives.seq (n) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.PCmpSeqBool (n))) ((@CryptolPrimitives.ecZero ((@CryptolPrimitives.seq (n) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.PZeroSeqBool (n))))) (xs)). + +Definition map (n : (@Num)) (a : Type) (b : Type) (f : (a) -> b) (xs : (@CryptolPrimitives.seq (n) (a))) := + (@CryptolPrimitives.seqMap (a) (b) (n) ((fun (x : a) => (f (x)))) (xs)). + +Definition all (n : (@Num)) (a : Type) (f : (a) -> @SAWCoreScaffolding.Bool) (xs : (@CryptolPrimitives.seq (n) (a))) := + (and (n) ((map (n) (a) (@SAWCoreScaffolding.Bool) (f) (xs)))). + +Definition any (n : (@Num)) (a : Type) (f : (a) -> @SAWCoreScaffolding.Bool) (xs : (@CryptolPrimitives.seq (n) (a))) := + (or (n) ((map (n) (a) (@SAWCoreScaffolding.Bool) (f) (xs)))). + +Definition foldl (n : (@Num)) (a : Type) (b : Type) (f : (a) -> (b) -> a) (acc : a) (xs : (@CryptolPrimitives.seq (n) (b))) := + (@CryptolPrimitives.ecAtBack ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (n))) (a) ((@TCNum (0))) ((iter ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (n))) ((fun (ys : (@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (n))) (a))) => (@CryptolPrimitives.ecCat ((@TCNum (1))) (n) (a) ((Vector.cons (_) (acc) (_) ((Vector.nil (_))))) ((@SAWCoreScaffolding.coerce ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcMin ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (n))) (n))) (a))) ((@CryptolPrimitives.seq (n) (a))) ((@CryptolPrimitives.seq_cong1 ((@CryptolPrimitives.tcMin ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (n))) (n))) (n) (a) ((@SAWCorePrelude.sawUnsafeAssert ((@Num)) ((@CryptolPrimitives.tcMin ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (n))) (n))) (n))))) ((@CryptolPrimitives.seqMap ((prod (a) (b))) (a) ((@CryptolPrimitives.tcMin ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (n))) (n))) ((@SAWCorePrelude.uncurry (a) (b) (a) ((fun (a : a) (x : b) => (f (a) (x)))))) ((@CryptolPrimitives.seqZip (a) (b) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (n))) (n) (ys) (xs)))))))))) ((CryptolPrimitives.seqConst ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (n))) (a) ((error ("Could not generate default value of type !4"))))))) ((@CryptolPrimitives.ecNumber ((@TCNum (0))) ((@CryptolPrimitives.seq ((@TCNum (0))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.PLiteralSeqBool ((@TCNum (0)))))))). + +Definition foldr (n : (@Num)) (a : Type) (b : Type) (f : (a) -> (b) -> b) (acc : b) (xs : (@CryptolPrimitives.seq (n) (a))) := + (@CryptolPrimitives.ecAtBack ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (n))) (b) ((@TCNum (0))) ((iter ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (n))) ((fun (ys : (@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (n))) (b))) => (@CryptolPrimitives.ecCat ((@TCNum (1))) (n) (b) ((Vector.cons (_) (acc) (_) ((Vector.nil (_))))) ((@SAWCoreScaffolding.coerce ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcMin ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (n))) (n))) (b))) ((@CryptolPrimitives.seq (n) (b))) ((@CryptolPrimitives.seq_cong1 ((@CryptolPrimitives.tcMin ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (n))) (n))) (n) (b) ((@SAWCorePrelude.sawUnsafeAssert ((@Num)) ((@CryptolPrimitives.tcMin ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (n))) (n))) (n))))) ((@CryptolPrimitives.seqMap ((prod (b) (a))) (b) ((@CryptolPrimitives.tcMin ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (n))) (n))) ((@SAWCorePrelude.uncurry (b) (a) (b) ((fun (a : b) (x : a) => (f (x) (a)))))) ((@CryptolPrimitives.seqZip (b) (a) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (n))) (n) (ys) ((@CryptolPrimitives.ecReverse (n) (a) (xs)))))))))))) ((CryptolPrimitives.seqConst ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (n))) (b) ((error ("Could not generate default value of type !3"))))))) ((@CryptolPrimitives.ecNumber ((@TCNum (0))) ((@CryptolPrimitives.seq ((@TCNum (0))) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.PLiteralSeqBool ((@TCNum (0)))))))). + +Definition sum (n : (@Num)) (a : Type) (_P : (@CryptolPrimitives.PArith (a))) (xs : (@CryptolPrimitives.seq (n) (a))) := + (foldl (n) (a) (a) ((@CryptolPrimitives.ecPlus (a) (_P))) ((@CryptolPrimitives.ecFromInteger (a) (_P) ((@CryptolPrimitives.ecNumber ((@TCNum (0))) (@SAWCorePrelude.Integer) (@CryptolPrimitives.PLiteralInteger))))) (xs)). + +Definition scanl (n : (@Num)) (b : Type) (a : Type) (f : (b) -> (a) -> b) (acc : b) (xs : (@CryptolPrimitives.seq (n) (a))) := + (iter ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (n))) ((fun (ys : (@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (n))) (b))) => (@CryptolPrimitives.ecCat ((@TCNum (1))) (n) (b) ((Vector.cons (_) (acc) (_) ((Vector.nil (_))))) ((@SAWCoreScaffolding.coerce ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcMin ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (n))) (n))) (b))) ((@CryptolPrimitives.seq (n) (b))) ((@CryptolPrimitives.seq_cong1 ((@CryptolPrimitives.tcMin ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (n))) (n))) (n) (b) ((@SAWCorePrelude.sawUnsafeAssert ((@Num)) ((@CryptolPrimitives.tcMin ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (n))) (n))) (n))))) ((@CryptolPrimitives.seqMap ((prod (b) (a))) (b) ((@CryptolPrimitives.tcMin ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (n))) (n))) ((@SAWCorePrelude.uncurry (b) (a) (b) ((fun (a : b) (x : a) => (f (a) (x)))))) ((@CryptolPrimitives.seqZip (b) (a) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (n))) (n) (ys) (xs)))))))))) ((CryptolPrimitives.seqConst ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (n))) (b) ((error ("Could not generate default value of type !4")))))). + +Definition scanr (n : (@Num)) (a : Type) (b : Type) (f : (a) -> (b) -> b) (acc : b) (xs : (@CryptolPrimitives.seq (n) (a))) := + (@CryptolPrimitives.ecReverse ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (n))) (b) ((iter ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (n))) ((fun (ys : (@CryptolPrimitives.seq ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (n))) (b))) => (@CryptolPrimitives.ecCat ((@TCNum (1))) (n) (b) ((Vector.cons (_) (acc) (_) ((Vector.nil (_))))) ((@SAWCoreScaffolding.coerce ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcMin ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (n))) (n))) (b))) ((@CryptolPrimitives.seq (n) (b))) ((@CryptolPrimitives.seq_cong1 ((@CryptolPrimitives.tcMin ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (n))) (n))) (n) (b) ((@SAWCorePrelude.sawUnsafeAssert ((@Num)) ((@CryptolPrimitives.tcMin ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (n))) (n))) (n))))) ((@CryptolPrimitives.seqMap ((prod (b) (a))) (b) ((@CryptolPrimitives.tcMin ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (n))) (n))) ((@SAWCorePrelude.uncurry (b) (a) (b) ((fun (a : b) (x : a) => (f (x) (a)))))) ((@CryptolPrimitives.seqZip (b) (a) ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (n))) (n) (ys) ((@CryptolPrimitives.ecReverse (n) (a) (xs)))))))))))) ((CryptolPrimitives.seqConst ((@CryptolPrimitives.tcAdd ((@TCNum (1))) (n))) (b) ((error ("Could not generate default value of type !3")))))))). + +Definition repeat (n : (@Num)) (a : Type) (x : a) := + (@CryptolPrimitives.seqMap (@SAWCoreScaffolding.Bool) (a) (n) ((fun (__p7 : @SAWCoreScaffolding.Bool) => x)) ((@CryptolPrimitives.ecZero ((@CryptolPrimitives.seq (n) (@SAWCoreScaffolding.Bool))) ((@CryptolPrimitives.PZeroSeqBool (n)))))). + +Definition elem (n : (@Num)) (a : Type) (_P : (@CryptolPrimitives.PCmp (a))) (a : a) (xs : (@CryptolPrimitives.seq (n) (a))) := + (any (n) (a) ((fun (x : a) => (@CryptolPrimitives.ecEq (a) (_P) (x) (a)))) (xs)). + +Definition zip (n : (@Num)) (a : Type) (b : Type) (xs : (@CryptolPrimitives.seq (n) (a))) (ys : (@CryptolPrimitives.seq (n) (b))) := + (@SAWCoreScaffolding.coerce ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcMin (n) (n))) ((prod (a) (b))))) ((@CryptolPrimitives.seq (n) ((prod (a) (b))))) ((@CryptolPrimitives.seq_cong1 ((@CryptolPrimitives.tcMin (n) (n))) (n) ((prod (a) (b))) ((@SAWCorePrelude.sawUnsafeAssert ((@Num)) ((@CryptolPrimitives.tcMin (n) (n))) (n))))) ((@CryptolPrimitives.seqMap ((prod (a) (b))) ((prod (a) (b))) ((@CryptolPrimitives.tcMin (n) (n))) ((@SAWCorePrelude.uncurry (a) (b) ((prod (a) (b))) ((fun (x : a) (y : b) => (pair (x) (y)))))) ((@CryptolPrimitives.seqZip (a) (b) (n) (n) (xs) (ys)))))). + +Definition zipWith (n : (@Num)) (a : Type) (b : Type) (c : Type) (f : (a) -> (b) -> c) (xs : (@CryptolPrimitives.seq (n) (a))) (ys : (@CryptolPrimitives.seq (n) (b))) := + (@SAWCoreScaffolding.coerce ((@CryptolPrimitives.seq ((@CryptolPrimitives.tcMin (n) (n))) (c))) ((@CryptolPrimitives.seq (n) (c))) ((@CryptolPrimitives.seq_cong1 ((@CryptolPrimitives.tcMin (n) (n))) (n) (c) ((@SAWCorePrelude.sawUnsafeAssert ((@Num)) ((@CryptolPrimitives.tcMin (n) (n))) (n))))) ((@CryptolPrimitives.seqMap ((prod (a) (b))) (c) ((@CryptolPrimitives.tcMin (n) (n))) ((@SAWCorePrelude.uncurry (a) (b) (c) ((fun (x : a) (y : b) => (f (x) (y)))))) ((@CryptolPrimitives.seqZip (a) (b) (n) (n) (xs) (ys)))))). + +Definition uncurry (a : Type) (b : Type) (c : Type) (f : (a) -> (b) -> c) (__p8 : (prod (a) (b))) := + (f ((fst (__p8))) ((snd (__p8)))). + +Definition curry (a : Type) (b : Type) (c : Type) (f : ((prod (a) (b))) -> c) (a : a) (b : b) := + (f ((pair (a) (b)))). + +Definition iterate := + (error ("Not supported")). diff --git a/saw-core-coq/coq/generated/CryptolToCoq/CryptolPrimitivesForSAWCore.v b/saw-core-coq/coq/generated/CryptolToCoq/CryptolPrimitivesForSAWCore.v new file mode 100644 index 0000000000..cf2950a91f --- /dev/null +++ b/saw-core-coq/coq/generated/CryptolToCoq/CryptolPrimitivesForSAWCore.v @@ -0,0 +1,767 @@ + +(** Mandatory imports from saw-core-coq *) +From Coq Require Import Lists.List. +From Coq Require Import String. +From Coq Require Import Vectors.Vector. +From CryptolToCoq Require Import SAWCoreScaffolding. +From CryptolToCoq Require Import SAWCoreVectorsAsCoqVectors. +Import ListNotations. + +(** Post-preamble section specified by you *) +From CryptolToCoq Require Import SAWCorePrelude. +Import SAWCorePrelude. + + +(** Code generated by saw-core-coq *) + +Module CryptolPrimitivesForSAWCore. + +Definition const : forall (a : Type), forall (b : Type), a -> b -> a := + fun (a : Type) (b : Type) (x : a) (y : b) => x. + +Definition compose : forall (a : Type), forall (b : Type), forall (c : Type), (b -> c) -> (a -> b) -> a -> c := + fun (_1 : Type) (_2 : Type) (_3 : Type) (f : _2 -> _3) (g : _1 -> _2) (x : _1) => f (g x). + +Definition bvExp : forall (n : @SAWCoreScaffolding.Nat), @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool) -> @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool) -> @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool) := + fun (n : @SAWCoreScaffolding.Nat) (x : @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool)) (y : @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool)) => @SAWCoreVectorsAsCoqVectors.foldr (@SAWCoreScaffolding.Bool) (@SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool)) n (fun (b : @SAWCoreScaffolding.Bool) (a : @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool)) => if b then @SAWCoreVectorsAsCoqVectors.bvMul n x (@SAWCoreVectorsAsCoqVectors.bvMul n a a) else @SAWCoreVectorsAsCoqVectors.bvMul n a a) (@SAWCoreVectorsAsCoqVectors.bvNat n 1) (@SAWCorePrelude.reverse n (@SAWCoreScaffolding.Bool) y). + +Definition updFst : forall (a : Type), forall (b : Type), (a -> a) -> prod a b -> prod a b := + fun (a : Type) (b : Type) (f : a -> a) (x : prod a b) => pair (f (SAWCoreScaffolding.fst x)) (SAWCoreScaffolding.snd x). + +Definition updSnd : forall (a : Type), forall (b : Type), (b -> b) -> prod a b -> prod a b := + fun (a : Type) (b : Type) (f : b -> b) (x : prod a b) => pair (SAWCoreScaffolding.fst x) (f (SAWCoreScaffolding.snd x)). + +Inductive Num : Type := +| TCNum : @SAWCoreScaffolding.Nat -> @Num +| TCInf : @Num +. + +(* Cryptol.Num_rec was skipped *) + +Definition getFinNat : forall (n : @Num), @SAWCoreScaffolding.Nat := + fun (n : @Num) => CryptolPrimitivesForSAWCore.Num_rect (fun (n1 : @Num) => @SAWCoreScaffolding.Nat) (fun (n1 : @SAWCoreScaffolding.Nat) => n1) (@SAWCoreScaffolding.error (@SAWCoreScaffolding.Nat) "Unexpected Fin constraint violation!"%string) n. + +Definition finNumRec : forall (p : @Num -> Type), (forall (n : @SAWCoreScaffolding.Nat), p (@TCNum n)) -> forall (n : @Num), p n := + fun (p : @Num -> Type) (f : forall (n : @SAWCoreScaffolding.Nat), p (@TCNum n)) (n : @Num) => CryptolPrimitivesForSAWCore.Num_rect p f (@SAWCoreScaffolding.error (p (@TCInf)) "Unexpected Fin constraint violation!"%string) n. + +Definition finNumRec2 : forall (p : @Num -> @Num -> Type), (forall (m : @SAWCoreScaffolding.Nat), forall (n : @SAWCoreScaffolding.Nat), p (@TCNum m) (@TCNum n)) -> forall (m : @Num), forall (n : @Num), p m n := + fun (p : @Num -> @Num -> Type) (f : forall (m : @SAWCoreScaffolding.Nat), forall (n : @SAWCoreScaffolding.Nat), p (@TCNum m) (@TCNum n)) => @finNumRec (fun (m : @Num) => forall (n : @Num), p m n) (fun (m : @SAWCoreScaffolding.Nat) => @finNumRec (p (@TCNum m)) (f m)). + +Definition binaryNumFun : (@SAWCoreScaffolding.Nat -> @SAWCoreScaffolding.Nat -> @SAWCoreScaffolding.Nat) -> (@SAWCoreScaffolding.Nat -> @Num) -> (@SAWCoreScaffolding.Nat -> @Num) -> @Num -> @Num -> @Num -> @Num := + fun (f1 : @SAWCoreScaffolding.Nat -> @SAWCoreScaffolding.Nat -> @SAWCoreScaffolding.Nat) (f2 : @SAWCoreScaffolding.Nat -> @Num) (f3 : @SAWCoreScaffolding.Nat -> @Num) (f4 : @Num) (num1 : @Num) (num2 : @Num) => CryptolPrimitivesForSAWCore.Num_rect (fun (num1' : @Num) => @Num) (fun (n1 : @SAWCoreScaffolding.Nat) => CryptolPrimitivesForSAWCore.Num_rect (fun (num2' : @Num) => @Num) (fun (n2 : @SAWCoreScaffolding.Nat) => @TCNum (f1 n1 n2)) (f2 n1) num2) (CryptolPrimitivesForSAWCore.Num_rect (fun (num2' : @Num) => @Num) f3 f4 num2) num1. + +Definition ternaryNumFun : (@SAWCoreScaffolding.Nat -> @SAWCoreScaffolding.Nat -> @SAWCoreScaffolding.Nat -> @SAWCoreScaffolding.Nat) -> @Num -> @Num -> @Num -> @Num -> @Num := + fun (f1 : @SAWCoreScaffolding.Nat -> @SAWCoreScaffolding.Nat -> @SAWCoreScaffolding.Nat -> @SAWCoreScaffolding.Nat) (f2 : @Num) (num1 : @Num) (num2 : @Num) (num3 : @Num) => CryptolPrimitivesForSAWCore.Num_rect (fun (num1' : @Num) => @Num) (fun (n1 : @SAWCoreScaffolding.Nat) => CryptolPrimitivesForSAWCore.Num_rect (fun (num2' : @Num) => @Num) (fun (n2 : @SAWCoreScaffolding.Nat) => CryptolPrimitivesForSAWCore.Num_rect (fun (num3' : @Num) => @Num) (fun (n3 : @SAWCoreScaffolding.Nat) => @TCNum (f1 n1 n2 n3)) f2 num3) f2 num2) f2 num1. + +Definition tcWidth : @Num -> @Num := + fun (n : @Num) => CryptolPrimitivesForSAWCore.Num_rect (fun (n1 : @Num) => @Num) (fun (x : @SAWCoreScaffolding.Nat) => @TCNum (@SAWCoreScaffolding.widthNat x)) (@TCInf) n. + +Definition tcAdd : @Num -> @Num -> @Num := + @binaryNumFun addNat (fun (x : @SAWCoreScaffolding.Nat) => @TCInf) (fun (y : @SAWCoreScaffolding.Nat) => @TCInf) (@TCInf). + +Definition tcSub : @Num -> @Num -> @Num := + @binaryNumFun subNat (fun (x : @SAWCoreScaffolding.Nat) => @TCNum 0) (fun (y : @SAWCoreScaffolding.Nat) => @TCInf) (@TCNum 0). + +Definition tcMul : @Num -> @Num -> @Num := + @binaryNumFun mulNat (fun (x : @SAWCoreScaffolding.Nat) => @SAWCorePrelude.if0Nat (@Num) x (@TCNum 0) (@TCInf)) (fun (y : @SAWCoreScaffolding.Nat) => @SAWCorePrelude.if0Nat (@Num) y (@TCNum 0) (@TCInf)) (@TCInf). + +Definition tcDiv : @Num -> @Num -> @Num := + @binaryNumFun (fun (x : @SAWCoreScaffolding.Nat) (y : @SAWCoreScaffolding.Nat) => @SAWCorePrelude.divNat x y) (fun (x : @SAWCoreScaffolding.Nat) => @TCNum 0) (fun (y : @SAWCoreScaffolding.Nat) => @TCInf) (@TCNum 1). + +Definition tcMod : @Num -> @Num -> @Num := + @binaryNumFun (fun (x : @SAWCoreScaffolding.Nat) (y : @SAWCoreScaffolding.Nat) => @SAWCorePrelude.modNat x y) (fun (x : @SAWCoreScaffolding.Nat) => @TCNum 0) (fun (y : @SAWCoreScaffolding.Nat) => @TCNum 0) (@TCNum 0). + +Definition tcExp : @Num -> @Num -> @Num := + @binaryNumFun expNat (fun (x : @SAWCoreScaffolding.Nat) => @SAWCorePrelude.natCase (fun (_1 : @SAWCoreScaffolding.Nat) => @Num) (@TCNum 0) (fun (x_minus_1 : @SAWCoreScaffolding.Nat) => @SAWCorePrelude.if0Nat (@Num) x_minus_1 (@TCNum 1) (@TCInf)) x) (fun (y : @SAWCoreScaffolding.Nat) => @SAWCorePrelude.if0Nat (@Num) y (@TCNum 1) (@TCInf)) (@TCInf). + +Definition tcMin : @Num -> @Num -> @Num := + @binaryNumFun minNat (fun (x : @SAWCoreScaffolding.Nat) => @TCNum x) (fun (y : @SAWCoreScaffolding.Nat) => @TCNum y) (@TCInf). + +Definition tcMax : @Num -> @Num -> @Num := + @binaryNumFun maxNat (fun (x : @SAWCoreScaffolding.Nat) => @TCInf) (fun (y : @SAWCoreScaffolding.Nat) => @TCInf) (@TCInf). + +Definition ceilDivNat : @SAWCoreScaffolding.Nat -> @SAWCoreScaffolding.Nat -> @SAWCoreScaffolding.Nat := + fun (x : @SAWCoreScaffolding.Nat) (y : @SAWCoreScaffolding.Nat) => @SAWCorePrelude.divNat (@SAWCorePrelude.addNat x (@SAWCorePrelude.subNat y 1)) y. + +Definition ceilModNat : @SAWCoreScaffolding.Nat -> @SAWCoreScaffolding.Nat -> @SAWCoreScaffolding.Nat := + fun (x : @SAWCoreScaffolding.Nat) (y : @SAWCoreScaffolding.Nat) => @SAWCorePrelude.subNat (@SAWCorePrelude.mulNat (@ceilDivNat x y) y) x. + +Definition tcCeilDiv : @Num -> @Num -> @Num := + @binaryNumFun ceilDivNat (fun (x : @SAWCoreScaffolding.Nat) => @TCNum 0) (fun (y : @SAWCoreScaffolding.Nat) => @TCInf) (@TCInf). + +Definition tcCeilMod : @Num -> @Num -> @Num := + @binaryNumFun ceilModNat (fun (x : @SAWCoreScaffolding.Nat) => @TCNum 0) (fun (y : @SAWCoreScaffolding.Nat) => @TCInf) (@TCInf). + +Definition tcLenFromThenTo_Nat : @SAWCoreScaffolding.Nat -> @SAWCoreScaffolding.Nat -> @SAWCoreScaffolding.Nat -> @SAWCoreScaffolding.Nat := + fun (x : @SAWCoreScaffolding.Nat) (y : @SAWCoreScaffolding.Nat) (z : @SAWCoreScaffolding.Nat) => if @SAWCorePrelude.ltNat x y then if @SAWCorePrelude.ltNat z x then 0 else @SAWCorePrelude.addNat (@SAWCorePrelude.divNat (@SAWCorePrelude.subNat z x) (@SAWCorePrelude.subNat y x)) 1 else if @SAWCorePrelude.ltNat x z then 0 else @SAWCorePrelude.addNat (@SAWCorePrelude.divNat (@SAWCorePrelude.subNat x z) (@SAWCorePrelude.subNat x y)) 1. + +Definition tcLenFromThenTo : @Num -> @Num -> @Num -> @Num := + @ternaryNumFun tcLenFromThenTo_Nat (@TCInf). + +Definition seq : @Num -> Type -> Type := + fun (num : @Num) (a : Type) => CryptolPrimitivesForSAWCore.Num_rect (fun (num1 : @Num) => Type) (fun (n : @SAWCoreScaffolding.Nat) => @SAWCoreVectorsAsCoqVectors.Vec n a) (@SAWCorePrelude.Stream a) num. + +Definition seq_TCNum : forall (n : @SAWCoreScaffolding.Nat), forall (a : Type), @SAWCoreScaffolding.Eq Type (@seq (@TCNum n) a) (@SAWCoreVectorsAsCoqVectors.Vec n a) := + fun (n : @SAWCoreScaffolding.Nat) (a : Type) => @SAWCoreScaffolding.Refl Type (@SAWCoreVectorsAsCoqVectors.Vec n a). + +Definition seq_TCInf : forall (a : Type), @SAWCoreScaffolding.Eq Type (@seq (@TCInf) a) (@SAWCorePrelude.Stream a) := + fun (a : Type) => @SAWCoreScaffolding.Refl Type (@SAWCorePrelude.Stream a). + +Definition seqMap : forall (a : Type), forall (b : Type), forall (n : @Num), (a -> b) -> @seq n a -> @seq n b := + fun (a : Type) (b : Type) (num : @Num) (f : a -> b) => CryptolPrimitivesForSAWCore.Num_rect (fun (n : @Num) => @seq n a -> @seq n b) (@SAWCorePrelude.map a b f) (@SAWCorePrelude.streamMap a b f) num. + +Definition seqConst : forall (n : @Num), forall (a : Type), a -> @seq n a := + fun (n : @Num) => CryptolPrimitivesForSAWCore.Num_rect (fun (n1 : @Num) => forall (a : Type), a -> @seq n1 a) replicate streamConst n. + +Definition IntModNum : forall (num : @Num), Type := + fun (num : @Num) => CryptolPrimitivesForSAWCore.Num_rect (fun (n : @Num) => Type) (@SAWCoreScaffolding.IntMod) (@SAWCoreScaffolding.Integer) num. + +Definition Rational : Type := + unit. + +Definition ecRatio : @SAWCoreScaffolding.Integer -> @SAWCoreScaffolding.Integer -> Rational := + fun (x : @SAWCoreScaffolding.Integer) (y : @SAWCoreScaffolding.Integer) => tt. + +Definition eqRational : Rational -> Rational -> @SAWCoreScaffolding.Bool := + fun (x : unit) (y : unit) => @SAWCoreScaffolding.error (@SAWCoreScaffolding.Bool) "Unimplemented: (==) Rational"%string. + +Definition ltRational : Rational -> Rational -> @SAWCoreScaffolding.Bool := + fun (x : unit) (y : unit) => @SAWCoreScaffolding.error (@SAWCoreScaffolding.Bool) "Unimplemented: (<) Rational"%string. + +Definition addRational : Rational -> Rational -> Rational := + fun (x : unit) (y : unit) => @SAWCoreScaffolding.error Rational "Unimplemented: (+) Rational"%string. + +Definition subRational : Rational -> Rational -> Rational := + fun (x : unit) (y : unit) => @SAWCoreScaffolding.error Rational "Unimplemented: (-) Rational"%string. + +Definition mulRational : Rational -> Rational -> Rational := + fun (x : unit) (y : unit) => @SAWCoreScaffolding.error Rational "Unimplemented: (*) Rational"%string. + +Definition negRational : Rational -> Rational := + fun (x : unit) => @SAWCoreScaffolding.error Rational "Unimplemented: negate Rational"%string. + +Definition integerToRational : @SAWCoreScaffolding.Integer -> Rational := + fun (x : @SAWCoreScaffolding.Integer) => @SAWCoreScaffolding.error Rational "Unimplemented: fromInteger Rational"%string. + +Definition seq_cong : forall (m : @Num), forall (n : @Num), forall (a : Type), forall (b : Type), @SAWCoreScaffolding.Eq (@Num) m n -> @SAWCoreScaffolding.Eq Type a b -> @SAWCoreScaffolding.Eq Type (@seq m a) (@seq n b) := + fun (m : @Num) (n : @Num) (a : Type) (b : Type) (eq_mn : @SAWCoreScaffolding.Eq (@Num) m n) (eq_ab : @SAWCoreScaffolding.Eq Type a b) => @SAWCorePrelude.trans Type (@seq m a) (@seq n a) (@seq n b) (@SAWCorePrelude.eq_cong (@Num) m n eq_mn Type (fun (x : @Num) => @seq x a)) (@SAWCorePrelude.eq_cong Type a b eq_ab Type (fun (x : Type) => @seq n x)). + +Definition seq_cong1 : forall (m : @Num), forall (n : @Num), forall (a : Type), @SAWCoreScaffolding.Eq (@Num) m n -> @SAWCoreScaffolding.Eq Type (@seq m a) (@seq n a) := + fun (m : @Num) (n : @Num) (a : Type) (eq_mn : @SAWCoreScaffolding.Eq (@Num) m n) => @SAWCorePrelude.eq_cong (@Num) m n eq_mn Type (fun (x : @Num) => @seq x a). + +Definition IntModNum_cong : forall (m : @Num), forall (n : @Num), @SAWCoreScaffolding.Eq (@Num) m n -> @SAWCoreScaffolding.Eq Type (@IntModNum m) (@IntModNum n) := + fun (m : @Num) (n : @Num) (eq_mn : @SAWCoreScaffolding.Eq (@Num) m n) => @SAWCorePrelude.eq_cong (@Num) m n eq_mn Type IntModNum. + +Definition fun_cong : forall (a : Type), forall (b : Type), forall (c : Type), forall (d : Type), @SAWCoreScaffolding.Eq Type a b -> @SAWCoreScaffolding.Eq Type c d -> @SAWCoreScaffolding.Eq Type (a -> c) (b -> d) := + fun (a : Type) (b : Type) (c : Type) (d : Type) (eq_ab : @SAWCoreScaffolding.Eq Type a b) (eq_cd : @SAWCoreScaffolding.Eq Type c d) => @SAWCorePrelude.trans Type (a -> c) (b -> c) (b -> d) (@SAWCorePrelude.eq_cong Type a b eq_ab Type (fun (x : Type) => x -> c)) (@SAWCorePrelude.eq_cong Type c d eq_cd Type (fun (x : Type) => b -> x)). + +Definition pair_cong : forall (a : Type), forall (a' : Type), forall (b : Type), forall (b' : Type), @SAWCoreScaffolding.Eq Type a a' -> @SAWCoreScaffolding.Eq Type b b' -> @SAWCoreScaffolding.Eq Type (prod a b) (prod a' b') := + fun (a : Type) (a' : Type) (b : Type) (b' : Type) (eq_a : @SAWCoreScaffolding.Eq Type a a') (eq_b : @SAWCoreScaffolding.Eq Type b b') => @SAWCorePrelude.trans Type (prod a b) (prod a' b) (prod a' b') (@SAWCorePrelude.eq_cong Type a a' eq_a Type (fun (x : Type) => prod x b)) (@SAWCorePrelude.eq_cong Type b b' eq_b Type (fun (x : Type) => prod a' x)). + +Definition pair_cong1 : forall (a : Type), forall (a' : Type), forall (b : Type), @SAWCoreScaffolding.Eq Type a a' -> @SAWCoreScaffolding.Eq Type (prod a b) (prod a' b) := + fun (a : Type) (a' : Type) (b : Type) (eq_a : @SAWCoreScaffolding.Eq Type a a') => @SAWCorePrelude.eq_cong Type a a' eq_a Type (fun (x : Type) => prod x b). + +Definition pair_cong2 : forall (a : Type), forall (b : Type), forall (b' : Type), @SAWCoreScaffolding.Eq Type b b' -> @SAWCoreScaffolding.Eq Type (prod a b) (prod a b') := + fun (a : Type) (b : Type) (b' : Type) (eq_b : @SAWCoreScaffolding.Eq Type b b') => @SAWCorePrelude.eq_cong Type b b' eq_b Type (fun (x : Type) => prod a x). + +(* Cryptol.unsafeAssert_same_Num was skipped *) + +Definition eListSel : forall (a : Type), forall (n : @Num), @seq n a -> @SAWCoreScaffolding.Nat -> a := + fun (a : Type) (n : @Num) => CryptolPrimitivesForSAWCore.Num_rect (fun (num : @Num) => @seq num a -> @SAWCoreScaffolding.Nat -> a) (fun (n1 : @SAWCoreScaffolding.Nat) => @SAWCorePrelude.sawAt n1 a) (@SAWCorePrelude.streamGet a) n. + +Definition from : forall (a : Type), forall (b : Type), forall (m : @Num), forall (n : @Num), @seq m a -> (a -> @seq n b) -> @seq (@tcMul m n) (prod a b) := + fun (a : Type) (b : Type) (m : @Num) (n : @Num) => CryptolPrimitivesForSAWCore.Num_rect (fun (m1 : @Num) => @seq m1 a -> (a -> @seq n b) -> @seq (@tcMul m1 n) (prod a b)) (fun (m1 : @SAWCoreScaffolding.Nat) => CryptolPrimitivesForSAWCore.Num_rect (fun (n1 : @Num) => @SAWCoreVectorsAsCoqVectors.Vec m1 a -> (a -> @seq n1 b) -> @seq (@tcMul (@TCNum m1) n1) (prod a b)) (fun (n1 : @SAWCoreScaffolding.Nat) (xs : @SAWCoreVectorsAsCoqVectors.Vec m1 a) (k : a -> @SAWCoreVectorsAsCoqVectors.Vec n1 b) => @SAWCorePrelude.join m1 n1 (prod a b) (@SAWCorePrelude.map a (@SAWCoreVectorsAsCoqVectors.Vec n1 (prod a b)) (fun (x : a) => @SAWCorePrelude.map b (prod a b) (fun (y : b) => pair x y) n1 (k x)) m1 xs)) (@SAWCorePrelude.natCase (fun (m' : @SAWCoreScaffolding.Nat) => @SAWCoreVectorsAsCoqVectors.Vec m' a -> (a -> @SAWCorePrelude.Stream b) -> @seq (@SAWCorePrelude.if0Nat (@Num) m' (@TCNum 0) (@TCInf)) (prod a b)) (fun (xs : @SAWCoreVectorsAsCoqVectors.Vec 0 a) (k : a -> @SAWCorePrelude.Stream b) => @SAWCoreVectorsAsCoqVectors.EmptyVec (prod a b)) (fun (m' : @SAWCoreScaffolding.Nat) (xs : @SAWCoreVectorsAsCoqVectors.Vec (@SAWCoreScaffolding.Succ m') a) (k : a -> @SAWCorePrelude.Stream b) => (fun (x : a) => @SAWCorePrelude.streamMap b (prod a b) (fun (y : b) => pair x y) (k x)) (@SAWCorePrelude.sawAt (@SAWCoreScaffolding.Succ m') a xs 0)) m1) n) (CryptolPrimitivesForSAWCore.Num_rect (fun (n1 : @Num) => @SAWCorePrelude.Stream a -> (a -> @seq n1 b) -> @seq (@tcMul (@TCInf) n1) (prod a b)) (fun (n1 : @SAWCoreScaffolding.Nat) => @SAWCorePrelude.natCase (fun (n' : @SAWCoreScaffolding.Nat) => @SAWCorePrelude.Stream a -> (a -> @SAWCoreVectorsAsCoqVectors.Vec n' b) -> @seq (@SAWCorePrelude.if0Nat (@Num) n' (@TCNum 0) (@TCInf)) (prod a b)) (fun (xs : @SAWCorePrelude.Stream a) (k : a -> @SAWCoreVectorsAsCoqVectors.Vec 0 b) => @SAWCoreVectorsAsCoqVectors.EmptyVec (prod a b)) (fun (n' : @SAWCoreScaffolding.Nat) (xs : @SAWCorePrelude.Stream a) (k : a -> @SAWCoreVectorsAsCoqVectors.Vec (@SAWCoreScaffolding.Succ n') b) => @SAWCorePrelude.streamJoin (prod a b) n' (@SAWCorePrelude.streamMap a (@SAWCoreVectorsAsCoqVectors.Vec (@SAWCoreScaffolding.Succ n') (prod a b)) (fun (x : a) => @SAWCorePrelude.map b (prod a b) (fun (y : b) => pair x y) (@SAWCoreScaffolding.Succ n') (k x)) xs)) n1) (fun (xs : @SAWCorePrelude.Stream a) (k : a -> @SAWCorePrelude.Stream b) => (fun (x : a) => @SAWCorePrelude.streamMap b (prod a b) (fun (y : b) => pair x y) (k x)) (@SAWCorePrelude.streamGet a xs 0)) n) m. + +Definition mlet : forall (a : Type), forall (b : Type), forall (n : @Num), a -> (a -> @seq n b) -> @seq n (prod a b) := + fun (a : Type) (b : Type) (n : @Num) => CryptolPrimitivesForSAWCore.Num_rect (fun (n1 : @Num) => a -> (a -> @seq n1 b) -> @seq n1 (prod a b)) (fun (n1 : @SAWCoreScaffolding.Nat) (x : a) (f : a -> @SAWCoreVectorsAsCoqVectors.Vec n1 b) => @SAWCorePrelude.map b (prod a b) (fun (y : b) => pair x y) n1 (f x)) (fun (x : a) (f : a -> @SAWCorePrelude.Stream b) => @SAWCorePrelude.streamMap b (prod a b) (fun (y : b) => pair x y) (f x)) n. + +Definition seqZip : forall (a : Type), forall (b : Type), forall (m : @Num), forall (n : @Num), @seq m a -> @seq n b -> @seq (@tcMin m n) (prod a b) := + fun (a : Type) (b : Type) (m : @Num) (n : @Num) => CryptolPrimitivesForSAWCore.Num_rect (fun (m1 : @Num) => @seq m1 a -> @seq n b -> @seq (@tcMin m1 n) (prod a b)) (fun (m1 : @SAWCoreScaffolding.Nat) => CryptolPrimitivesForSAWCore.Num_rect (fun (n1 : @Num) => @SAWCoreVectorsAsCoqVectors.Vec m1 a -> @seq n1 b -> @seq (@tcMin (@TCNum m1) n1) (prod a b)) (fun (n1 : @SAWCoreScaffolding.Nat) => @SAWCorePrelude.zip a b m1 n1) (fun (xs : @SAWCoreVectorsAsCoqVectors.Vec m1 a) (ys : @SAWCorePrelude.Stream b) => @SAWCoreVectorsAsCoqVectors.gen m1 (prod a b) (fun (i : @SAWCoreScaffolding.Nat) => pair (@SAWCorePrelude.sawAt m1 a xs i) (@SAWCorePrelude.streamGet b ys i))) n) (CryptolPrimitivesForSAWCore.Num_rect (fun (n1 : @Num) => @SAWCorePrelude.Stream a -> @seq n1 b -> @seq (@tcMin (@TCInf) n1) (prod a b)) (fun (n1 : @SAWCoreScaffolding.Nat) (xs : @SAWCorePrelude.Stream a) (ys : @SAWCoreVectorsAsCoqVectors.Vec n1 b) => @SAWCoreVectorsAsCoqVectors.gen n1 (prod a b) (fun (i : @SAWCoreScaffolding.Nat) => pair (@SAWCorePrelude.streamGet a xs i) (@SAWCorePrelude.sawAt n1 b ys i))) (@SAWCorePrelude.streamMap2 a b (prod a b) (fun (x : a) (y : b) => pair x y)) n) m. + +Definition seqBinary : forall (n : @Num), forall (a : Type), (a -> a -> a) -> @seq n a -> @seq n a -> @seq n a := + fun (num : @Num) (a : Type) (f : a -> a -> a) => CryptolPrimitivesForSAWCore.Num_rect (fun (n : @Num) => @seq n a -> @seq n a -> @seq n a) (fun (n : @SAWCoreScaffolding.Nat) => @SAWCorePrelude.zipWith a a a f n) (@SAWCorePrelude.streamMap2 a a a f) num. + +Definition unitUnary : unit -> unit := + fun (_1 : unit) => tt. + +Definition unitBinary : unit -> unit -> unit := + fun (_1 : unit) (_2 : unit) => tt. + +Definition pairUnary : forall (a : Type), forall (b : Type), (a -> a) -> (b -> b) -> prod a b -> prod a b := + fun (a : Type) (b : Type) (f : a -> a) (g : b -> b) (xy : prod a b) => pair (f (@SAWCoreScaffolding.fst a b xy)) (g (@SAWCoreScaffolding.snd a b xy)). + +Definition pairBinary : forall (a : Type), forall (b : Type), (a -> a -> a) -> (b -> b -> b) -> prod a b -> prod a b -> prod a b := + fun (a : Type) (b : Type) (f : a -> a -> a) (g : b -> b -> b) (x12 : prod a b) (y12 : prod a b) => pair (f (@SAWCoreScaffolding.fst a b x12) (@SAWCoreScaffolding.fst a b y12)) (g (@SAWCoreScaffolding.snd a b x12) (@SAWCoreScaffolding.snd a b y12)). + +Definition funBinary : forall (a : Type), forall (b : Type), (b -> b -> b) -> (a -> b) -> (a -> b) -> a -> b := + fun (a : Type) (b : Type) (op : b -> b -> b) (f : a -> b) (g : a -> b) (x : a) => op (f x) (g x). + +Definition errorUnary : forall (s : @SAWCoreScaffolding.String), forall (a : Type), a -> a := + fun (s : @SAWCoreScaffolding.String) (a : Type) (_1 : a) => @SAWCoreScaffolding.error a s. + +Definition errorBinary : forall (s : @SAWCoreScaffolding.String), forall (a : Type), a -> a -> a := + fun (s : @SAWCoreScaffolding.String) (a : Type) (_1 : a) (_2 : a) => @SAWCoreScaffolding.error a s. + +Definition boolCmp : @SAWCoreScaffolding.Bool -> @SAWCoreScaffolding.Bool -> @SAWCoreScaffolding.Bool -> @SAWCoreScaffolding.Bool := + fun (x : @SAWCoreScaffolding.Bool) (y : @SAWCoreScaffolding.Bool) (k : @SAWCoreScaffolding.Bool) => if x then @SAWCoreScaffolding.and y k else @SAWCoreScaffolding.or y k. + +Definition integerCmp : @SAWCoreScaffolding.Integer -> @SAWCoreScaffolding.Integer -> @SAWCoreScaffolding.Bool -> @SAWCoreScaffolding.Bool := + fun (x : @SAWCoreScaffolding.Integer) (y : @SAWCoreScaffolding.Integer) (k : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.or (@SAWCoreScaffolding.intLt x y) (@SAWCoreScaffolding.and (@SAWCoreScaffolding.intEq x y) k). + +Definition rationalCmp : Rational -> Rational -> @SAWCoreScaffolding.Bool -> @SAWCoreScaffolding.Bool := + fun (x : unit) (y : unit) (k : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.or (@ltRational x y) (@SAWCoreScaffolding.and (@eqRational x y) k). + +Definition bvCmp : forall (n : @SAWCoreScaffolding.Nat), @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool) -> @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool) -> @SAWCoreScaffolding.Bool -> @SAWCoreScaffolding.Bool := + fun (n : @SAWCoreScaffolding.Nat) (x : @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool)) (y : @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool)) (k : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.or (@SAWCoreVectorsAsCoqVectors.bvult n x y) (@SAWCoreScaffolding.and (@SAWCorePrelude.bvEq n x y) k). + +Definition bvSCmp : forall (n : @SAWCoreScaffolding.Nat), @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool) -> @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool) -> @SAWCoreScaffolding.Bool -> @SAWCoreScaffolding.Bool := + fun (n : @SAWCoreScaffolding.Nat) (x : @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool)) (y : @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool)) (k : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.or (@SAWCoreVectorsAsCoqVectors.bvslt n x y) (@SAWCoreScaffolding.and (@SAWCorePrelude.bvEq n x y) k). + +Definition vecCmp : forall (n : @SAWCoreScaffolding.Nat), forall (a : Type), (a -> a -> @SAWCoreScaffolding.Bool -> @SAWCoreScaffolding.Bool) -> @SAWCoreVectorsAsCoqVectors.Vec n a -> @SAWCoreVectorsAsCoqVectors.Vec n a -> @SAWCoreScaffolding.Bool -> @SAWCoreScaffolding.Bool := + fun (n : @SAWCoreScaffolding.Nat) (a : Type) (f : a -> a -> @SAWCoreScaffolding.Bool -> @SAWCoreScaffolding.Bool) (xs : @SAWCoreVectorsAsCoqVectors.Vec n a) (ys : @SAWCoreVectorsAsCoqVectors.Vec n a) (k : @SAWCoreScaffolding.Bool) => @SAWCoreVectorsAsCoqVectors.foldr (@SAWCoreScaffolding.Bool -> @SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.Bool) n (fun (f1 : @SAWCoreScaffolding.Bool -> @SAWCoreScaffolding.Bool) => f1) k (@SAWCorePrelude.zipWith a a (@SAWCoreScaffolding.Bool -> @SAWCoreScaffolding.Bool) f n xs ys). + +Definition unitCmp : unit -> unit -> @SAWCoreScaffolding.Bool -> @SAWCoreScaffolding.Bool := + fun (_1 : unit) (_2 : unit) (_3 : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.false. + +Definition pairCmp : forall (a : Type), forall (b : Type), (a -> a -> @SAWCoreScaffolding.Bool -> @SAWCoreScaffolding.Bool) -> (b -> b -> @SAWCoreScaffolding.Bool -> @SAWCoreScaffolding.Bool) -> prod a b -> prod a b -> @SAWCoreScaffolding.Bool -> @SAWCoreScaffolding.Bool := + fun (a : Type) (b : Type) (f : a -> a -> @SAWCoreScaffolding.Bool -> @SAWCoreScaffolding.Bool) (g : b -> b -> @SAWCoreScaffolding.Bool -> @SAWCoreScaffolding.Bool) (x12 : prod a b) (y12 : prod a b) (k : @SAWCoreScaffolding.Bool) => f (@SAWCoreScaffolding.fst a b x12) (@SAWCoreScaffolding.fst a b y12) (g (@SAWCoreScaffolding.snd a b x12) (@SAWCoreScaffolding.snd a b y12) k). + +Definition PEq : Type -> Type := + fun (a : Type) => RecordTypeCons "eq" (a -> a -> @SAWCoreScaffolding.Bool) RecordTypeNil. + +Definition PEqBit : @PEq (@SAWCoreScaffolding.Bool) := + RecordCons "eq" (@SAWCoreScaffolding.boolEq) RecordNil. + +Definition PEqInteger : @PEq (@SAWCoreScaffolding.Integer) := + RecordCons "eq" (@SAWCoreScaffolding.intEq) RecordNil. + +Definition PEqRational : @PEq Rational := + RecordCons "eq" eqRational RecordNil. + +Definition PEqIntMod : forall (n : @SAWCoreScaffolding.Nat), @PEq (@SAWCoreScaffolding.IntMod n) := + fun (n : @SAWCoreScaffolding.Nat) => RecordCons "eq" (@SAWCoreScaffolding.intModEq n) RecordNil. + +Definition PEqIntModNum : forall (num : @Num), @PEq (@IntModNum num) := + fun (num : @Num) => CryptolPrimitivesForSAWCore.Num_rect (fun (n : @Num) => @PEq (@IntModNum n)) PEqIntMod PEqInteger num. + +Definition PEqVec : forall (n : @SAWCoreScaffolding.Nat), forall (a : Type), @PEq a -> @PEq (@SAWCoreVectorsAsCoqVectors.Vec n a) := + fun (n : @SAWCoreScaffolding.Nat) (a : Type) (pa : RecordTypeCons "eq" (a -> a -> @SAWCoreScaffolding.Bool) RecordTypeNil) => RecordCons "eq" (@SAWCorePrelude.vecEq n a (RecordProj pa "eq")) RecordNil. + +Definition PEqSeq : forall (n : @Num), forall (a : Type), @PEq a -> @PEq (@seq n a) := + fun (n : @Num) => CryptolPrimitivesForSAWCore.Num_rect (fun (n1 : @Num) => forall (a : Type), @PEq a -> @PEq (@seq n1 a)) (fun (n1 : @SAWCoreScaffolding.Nat) => @PEqVec n1) (fun (a : Type) (pa : RecordTypeCons "eq" (a -> a -> @SAWCoreScaffolding.Bool) RecordTypeNil) => @SAWCoreScaffolding.error (@PEq (@SAWCorePrelude.Stream a)) "invalid Eq instance"%string) n. + +Definition PEqWord : forall (n : @SAWCoreScaffolding.Nat), @PEq (@SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool)) := + fun (n : @SAWCoreScaffolding.Nat) => RecordCons "eq" (@SAWCorePrelude.bvEq n) RecordNil. + +Definition PEqSeqBool : forall (n : @Num), @PEq (@seq n (@SAWCoreScaffolding.Bool)) := + fun (n : @Num) => CryptolPrimitivesForSAWCore.Num_rect (fun (n1 : @Num) => @PEq (@seq n1 (@SAWCoreScaffolding.Bool))) (fun (n1 : @SAWCoreScaffolding.Nat) => @PEqWord n1) (@SAWCoreScaffolding.error (@PEq (@SAWCorePrelude.Stream (@SAWCoreScaffolding.Bool))) "invalid Eq instance"%string) n. + +Definition PEqUnit : @PEq unit := + RecordCons "eq" (fun (x : unit) (y : unit) => @SAWCoreScaffolding.true) RecordNil. + +Definition PEqPair : forall (a : Type), forall (b : Type), @PEq a -> @PEq b -> @PEq (prod a b) := + fun (a : Type) (b : Type) (pa : RecordTypeCons "eq" (a -> a -> @SAWCoreScaffolding.Bool) RecordTypeNil) (pb : RecordTypeCons "eq" (b -> b -> @SAWCoreScaffolding.Bool) RecordTypeNil) => RecordCons "eq" (@SAWCorePrelude.pairEq a b (RecordProj pa "eq") (RecordProj pb "eq")) RecordNil. + +Definition PCmp : Type -> Type := + fun (a : Type) => RecordTypeCons "cmp" (a -> a -> @SAWCoreScaffolding.Bool -> @SAWCoreScaffolding.Bool) (RecordTypeCons "cmpEq" (@PEq a) RecordTypeNil). + +Definition PCmpBit : @PCmp (@SAWCoreScaffolding.Bool) := + RecordCons "cmp" boolCmp (RecordCons "cmpEq" PEqBit RecordNil). + +Definition PCmpInteger : @PCmp (@SAWCoreScaffolding.Integer) := + RecordCons "cmp" integerCmp (RecordCons "cmpEq" PEqInteger RecordNil). + +Definition PCmpRational : @PCmp Rational := + RecordCons "cmp" rationalCmp (RecordCons "cmpEq" PEqRational RecordNil). + +Definition PCmpVec : forall (n : @SAWCoreScaffolding.Nat), forall (a : Type), @PCmp a -> @PCmp (@SAWCoreVectorsAsCoqVectors.Vec n a) := + fun (n : @SAWCoreScaffolding.Nat) (a : Type) (pa : RecordTypeCons "cmp" (a -> a -> @SAWCoreScaffolding.Bool -> @SAWCoreScaffolding.Bool) (RecordTypeCons "cmpEq" (RecordTypeCons "eq" (a -> a -> @SAWCoreScaffolding.Bool) RecordTypeNil) RecordTypeNil)) => RecordCons "cmp" (@vecCmp n a (RecordProj pa "cmp")) (RecordCons "cmpEq" (@PEqVec n a (RecordProj pa "cmpEq")) RecordNil). + +Definition PCmpSeq : forall (n : @Num), forall (a : Type), @PCmp a -> @PCmp (@seq n a) := + fun (n : @Num) => CryptolPrimitivesForSAWCore.Num_rect (fun (n1 : @Num) => forall (a : Type), @PCmp a -> @PCmp (@seq n1 a)) (fun (n1 : @SAWCoreScaffolding.Nat) => @PCmpVec n1) (fun (a : Type) (pa : RecordTypeCons "cmp" (a -> a -> @SAWCoreScaffolding.Bool -> @SAWCoreScaffolding.Bool) (RecordTypeCons "cmpEq" (RecordTypeCons "eq" (a -> a -> @SAWCoreScaffolding.Bool) RecordTypeNil) RecordTypeNil)) => @SAWCoreScaffolding.error (@PCmp (@SAWCorePrelude.Stream a)) "invalid Cmp instance"%string) n. + +Definition PCmpWord : forall (n : @SAWCoreScaffolding.Nat), @PCmp (@SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool)) := + fun (n : @SAWCoreScaffolding.Nat) => RecordCons "cmp" (@bvCmp n) (RecordCons "cmpEq" (@PEqWord n) RecordNil). + +Definition PCmpSeqBool : forall (n : @Num), @PCmp (@seq n (@SAWCoreScaffolding.Bool)) := + fun (n : @Num) => CryptolPrimitivesForSAWCore.Num_rect (fun (n1 : @Num) => @PCmp (@seq n1 (@SAWCoreScaffolding.Bool))) (fun (n1 : @SAWCoreScaffolding.Nat) => @PCmpWord n1) (@SAWCoreScaffolding.error (@PCmp (@SAWCorePrelude.Stream (@SAWCoreScaffolding.Bool))) "invalid Cmp instance"%string) n. + +Definition PCmpUnit : @PCmp unit := + RecordCons "cmp" unitCmp (RecordCons "cmpEq" PEqUnit RecordNil). + +Definition PCmpPair : forall (a : Type), forall (b : Type), @PCmp a -> @PCmp b -> @PCmp (prod a b) := + fun (a : Type) (b : Type) (pa : RecordTypeCons "cmp" (a -> a -> @SAWCoreScaffolding.Bool -> @SAWCoreScaffolding.Bool) (RecordTypeCons "cmpEq" (RecordTypeCons "eq" (a -> a -> @SAWCoreScaffolding.Bool) RecordTypeNil) RecordTypeNil)) (pb : RecordTypeCons "cmp" (b -> b -> @SAWCoreScaffolding.Bool -> @SAWCoreScaffolding.Bool) (RecordTypeCons "cmpEq" (RecordTypeCons "eq" (b -> b -> @SAWCoreScaffolding.Bool) RecordTypeNil) RecordTypeNil)) => RecordCons "cmp" (@pairCmp a b (RecordProj pa "cmp") (RecordProj pb "cmp")) (RecordCons "cmpEq" (@PEqPair a b (RecordProj pa "cmpEq") (RecordProj pb "cmpEq")) RecordNil). + +Definition PSignedCmp : Type -> Type := + fun (a : Type) => RecordTypeCons "scmp" (a -> a -> @SAWCoreScaffolding.Bool -> @SAWCoreScaffolding.Bool) (RecordTypeCons "signedCmpEq" (@PEq a) RecordTypeNil). + +Definition PSignedCmpVec : forall (n : @SAWCoreScaffolding.Nat), forall (a : Type), @PSignedCmp a -> @PSignedCmp (@SAWCoreVectorsAsCoqVectors.Vec n a) := + fun (n : @SAWCoreScaffolding.Nat) (a : Type) (pa : RecordTypeCons "scmp" (a -> a -> @SAWCoreScaffolding.Bool -> @SAWCoreScaffolding.Bool) (RecordTypeCons "signedCmpEq" (RecordTypeCons "eq" (a -> a -> @SAWCoreScaffolding.Bool) RecordTypeNil) RecordTypeNil)) => RecordCons "scmp" (@vecCmp n a (RecordProj pa "scmp")) (RecordCons "signedCmpEq" (@PEqVec n a (RecordProj pa "signedCmpEq")) RecordNil). + +Definition PSignedCmpSeq : forall (n : @Num), forall (a : Type), @PSignedCmp a -> @PSignedCmp (@seq n a) := + fun (n : @Num) => CryptolPrimitivesForSAWCore.Num_rect (fun (n1 : @Num) => forall (a : Type), @PSignedCmp a -> @PSignedCmp (@seq n1 a)) (fun (n1 : @SAWCoreScaffolding.Nat) => @PSignedCmpVec n1) (fun (a : Type) (pa : RecordTypeCons "scmp" (a -> a -> @SAWCoreScaffolding.Bool -> @SAWCoreScaffolding.Bool) (RecordTypeCons "signedCmpEq" (RecordTypeCons "eq" (a -> a -> @SAWCoreScaffolding.Bool) RecordTypeNil) RecordTypeNil)) => @SAWCoreScaffolding.error (@PSignedCmp (@SAWCorePrelude.Stream a)) "invalid SignedCmp instance"%string) n. + +Definition PSignedCmpWord : forall (n : @SAWCoreScaffolding.Nat), @PSignedCmp (@SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool)) := + fun (n : @SAWCoreScaffolding.Nat) => RecordCons "scmp" (@bvSCmp n) (RecordCons "signedCmpEq" (@PEqWord n) RecordNil). + +Definition PSignedCmpSeqBool : forall (n : @Num), @PSignedCmp (@seq n (@SAWCoreScaffolding.Bool)) := + fun (n : @Num) => CryptolPrimitivesForSAWCore.Num_rect (fun (n1 : @Num) => @PSignedCmp (@seq n1 (@SAWCoreScaffolding.Bool))) (fun (n1 : @SAWCoreScaffolding.Nat) => @PSignedCmpWord n1) (@SAWCoreScaffolding.error (@PSignedCmp (@SAWCorePrelude.Stream (@SAWCoreScaffolding.Bool))) "invalid SignedCmp instance"%string) n. + +Definition PSignedCmpUnit : @PSignedCmp unit := + RecordCons "scmp" unitCmp (RecordCons "signedCmpEq" PEqUnit RecordNil). + +Definition PSignedCmpPair : forall (a : Type), forall (b : Type), @PSignedCmp a -> @PSignedCmp b -> @PSignedCmp (prod a b) := + fun (a : Type) (b : Type) (pa : RecordTypeCons "scmp" (a -> a -> @SAWCoreScaffolding.Bool -> @SAWCoreScaffolding.Bool) (RecordTypeCons "signedCmpEq" (RecordTypeCons "eq" (a -> a -> @SAWCoreScaffolding.Bool) RecordTypeNil) RecordTypeNil)) (pb : RecordTypeCons "scmp" (b -> b -> @SAWCoreScaffolding.Bool -> @SAWCoreScaffolding.Bool) (RecordTypeCons "signedCmpEq" (RecordTypeCons "eq" (b -> b -> @SAWCoreScaffolding.Bool) RecordTypeNil) RecordTypeNil)) => RecordCons "scmp" (@pairCmp a b (RecordProj pa "scmp") (RecordProj pb "scmp")) (RecordCons "signedCmpEq" (@PEqPair a b (RecordProj pa "signedCmpEq") (RecordProj pb "signedCmpEq")) RecordNil). + +Definition PZero : Type -> Type := + fun (a : Type) => a. + +Definition PZeroBit : @PZero (@SAWCoreScaffolding.Bool) := + @SAWCoreScaffolding.false. + +Definition PZeroInteger : @PZero (@SAWCoreScaffolding.Integer) := + 0%Z. + +Definition PZeroIntMod : forall (n : @SAWCoreScaffolding.Nat), @PZero (@SAWCoreScaffolding.IntMod n) := + fun (n : @SAWCoreScaffolding.Nat) => @SAWCoreScaffolding.toIntMod n 0%Z. + +Definition PZeroRational : @PZero Rational := + @integerToRational 0%Z. + +Definition PZeroIntModNum : forall (num : @Num), @PZero (@IntModNum num) := + fun (num : @Num) => CryptolPrimitivesForSAWCore.Num_rect (fun (n : @Num) => @PZero (@IntModNum n)) PZeroIntMod PZeroInteger num. + +Definition PZeroSeq : forall (n : @Num), forall (a : Type), @PZero a -> @PZero (@seq n a) := + fun (n : @Num) (a : Type) (pa : a) => @seqConst n a pa. + +Definition PZeroSeqBool : forall (n : @Num), @PZero (@seq n (@SAWCoreScaffolding.Bool)) := + fun (n : @Num) => CryptolPrimitivesForSAWCore.Num_rect (fun (n1 : @Num) => @PZero (@seq n1 (@SAWCoreScaffolding.Bool))) (fun (n1 : @SAWCoreScaffolding.Nat) => @SAWCoreVectorsAsCoqVectors.bvNat n1 0) (@SAWCorePrelude.streamConst (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.false)) n. + +Definition PZeroFun : forall (a : Type), forall (b : Type), @PZero b -> @PZero (a -> b) := + fun (a : Type) (b : Type) (pb : b) (_1 : a) => pb. + +Definition PLogic : Type -> Type := + fun (a : Type) => RecordTypeCons "and" (a -> a -> a) (RecordTypeCons "logicZero" (@PZero a) (RecordTypeCons "not" (a -> a) (RecordTypeCons "or" (a -> a -> a) (RecordTypeCons "xor" (a -> a -> a) RecordTypeNil)))). + +Definition PLogicBit : @PLogic (@SAWCoreScaffolding.Bool) := + RecordCons "and" (@SAWCoreScaffolding.and) (RecordCons "logicZero" PZeroBit (RecordCons "not" (@SAWCoreScaffolding.not) (RecordCons "or" (@SAWCoreScaffolding.or) (RecordCons "xor" (@SAWCoreScaffolding.xor) RecordNil)))). + +Definition PLogicVec : forall (n : @SAWCoreScaffolding.Nat), forall (a : Type), @PLogic a -> @PLogic (@SAWCoreVectorsAsCoqVectors.Vec n a) := + fun (n : @SAWCoreScaffolding.Nat) (a : Type) (pa : RecordTypeCons "and" (a -> a -> a) (RecordTypeCons "logicZero" a (RecordTypeCons "not" (a -> a) (RecordTypeCons "or" (a -> a -> a) (RecordTypeCons "xor" (a -> a -> a) RecordTypeNil))))) => RecordCons "and" (@SAWCorePrelude.zipWith a a a (RecordProj pa "and") n) (RecordCons "logicZero" (@SAWCorePrelude.replicate n a (RecordProj pa "logicZero")) (RecordCons "not" (@SAWCorePrelude.map a a (RecordProj pa "not") n) (RecordCons "or" (@SAWCorePrelude.zipWith a a a (RecordProj pa "or") n) (RecordCons "xor" (@SAWCorePrelude.zipWith a a a (RecordProj pa "xor") n) RecordNil)))). + +Definition PLogicStream : forall (a : Type), @PLogic a -> @PLogic (@SAWCorePrelude.Stream a) := + fun (a : Type) (pa : RecordTypeCons "and" (a -> a -> a) (RecordTypeCons "logicZero" a (RecordTypeCons "not" (a -> a) (RecordTypeCons "or" (a -> a -> a) (RecordTypeCons "xor" (a -> a -> a) RecordTypeNil))))) => RecordCons "and" (@SAWCorePrelude.streamMap2 a a a (RecordProj pa "and")) (RecordCons "logicZero" (@SAWCorePrelude.streamConst a (RecordProj pa "logicZero")) (RecordCons "not" (@SAWCorePrelude.streamMap a a (RecordProj pa "not")) (RecordCons "or" (@SAWCorePrelude.streamMap2 a a a (RecordProj pa "or")) (RecordCons "xor" (@SAWCorePrelude.streamMap2 a a a (RecordProj pa "xor")) RecordNil)))). + +Definition PLogicSeq : forall (n : @Num), forall (a : Type), @PLogic a -> @PLogic (@seq n a) := + fun (n : @Num) => CryptolPrimitivesForSAWCore.Num_rect (fun (n1 : @Num) => forall (a : Type), @PLogic a -> @PLogic (@seq n1 a)) (fun (n1 : @SAWCoreScaffolding.Nat) => @PLogicVec n1) PLogicStream n. + +Definition PLogicWord : forall (n : @SAWCoreScaffolding.Nat), @PLogic (@SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool)) := + fun (n : @SAWCoreScaffolding.Nat) => RecordCons "and" (@SAWCorePrelude.bvAnd n) (RecordCons "logicZero" (@SAWCoreVectorsAsCoqVectors.bvNat n 0) (RecordCons "not" (@SAWCorePrelude.bvNot n) (RecordCons "or" (@SAWCorePrelude.bvOr n) (RecordCons "xor" (@SAWCorePrelude.bvXor n) RecordNil)))). + +Definition PLogicSeqBool : forall (n : @Num), @PLogic (@seq n (@SAWCoreScaffolding.Bool)) := + fun (n : @Num) => CryptolPrimitivesForSAWCore.Num_rect (fun (n1 : @Num) => @PLogic (@seq n1 (@SAWCoreScaffolding.Bool))) (fun (n1 : @SAWCoreScaffolding.Nat) => @PLogicWord n1) (@PLogicStream (@SAWCoreScaffolding.Bool) PLogicBit) n. + +Definition PLogicFun : forall (a : Type), forall (b : Type), @PLogic b -> @PLogic (a -> b) := + fun (a : Type) (b : Type) (pb : RecordTypeCons "and" (b -> b -> b) (RecordTypeCons "logicZero" b (RecordTypeCons "not" (b -> b) (RecordTypeCons "or" (b -> b -> b) (RecordTypeCons "xor" (b -> b -> b) RecordTypeNil))))) => RecordCons "and" (@funBinary a b (RecordProj pb "and")) (RecordCons "logicZero" (@PZeroFun a b (RecordProj pb "logicZero")) (RecordCons "not" (@compose a b b (RecordProj pb "not")) (RecordCons "or" (@funBinary a b (RecordProj pb "or")) (RecordCons "xor" (@funBinary a b (RecordProj pb "xor")) RecordNil)))). + +Definition PLogicUnit : @PLogic unit := + RecordCons "and" unitBinary (RecordCons "logicZero" tt (RecordCons "not" unitUnary (RecordCons "or" unitBinary (RecordCons "xor" unitBinary RecordNil)))). + +Definition PLogicPair : forall (a : Type), forall (b : Type), @PLogic a -> @PLogic b -> @PLogic (prod a b) := + fun (a : Type) (b : Type) (pa : RecordTypeCons "and" (a -> a -> a) (RecordTypeCons "logicZero" a (RecordTypeCons "not" (a -> a) (RecordTypeCons "or" (a -> a -> a) (RecordTypeCons "xor" (a -> a -> a) RecordTypeNil))))) (pb : RecordTypeCons "and" (b -> b -> b) (RecordTypeCons "logicZero" b (RecordTypeCons "not" (b -> b) (RecordTypeCons "or" (b -> b -> b) (RecordTypeCons "xor" (b -> b -> b) RecordTypeNil))))) => RecordCons "and" (@pairBinary a b (RecordProj pa "and") (RecordProj pb "and")) (RecordCons "logicZero" (pair (RecordProj pa "logicZero") (RecordProj pb "logicZero")) (RecordCons "not" (@pairUnary a b (RecordProj pa "not") (RecordProj pb "not")) (RecordCons "or" (@pairBinary a b (RecordProj pa "or") (RecordProj pb "or")) (RecordCons "xor" (@pairBinary a b (RecordProj pa "xor") (RecordProj pb "xor")) RecordNil)))). + +Definition PRing : Type -> Type := + fun (a : Type) => RecordTypeCons "add" (a -> a -> a) (RecordTypeCons "int" (@SAWCoreScaffolding.Integer -> a) (RecordTypeCons "mul" (a -> a -> a) (RecordTypeCons "neg" (a -> a) (RecordTypeCons "ringZero" (@PZero a) (RecordTypeCons "sub" (a -> a -> a) RecordTypeNil))))). + +Definition PRingInteger : @PRing (@SAWCoreScaffolding.Integer) := + RecordCons "add" (@SAWCoreScaffolding.intAdd) (RecordCons "int" (fun (i : @SAWCoreScaffolding.Integer) => i) (RecordCons "mul" (@SAWCoreScaffolding.intMul) (RecordCons "neg" (@SAWCoreScaffolding.intNeg) (RecordCons "ringZero" PZeroInteger (RecordCons "sub" (@SAWCoreScaffolding.intSub) RecordNil))))). + +Definition PRingIntMod : forall (n : @SAWCoreScaffolding.Nat), @PRing (@SAWCoreScaffolding.IntMod n) := + fun (n : @SAWCoreScaffolding.Nat) => RecordCons "add" (@SAWCoreScaffolding.intModAdd n) (RecordCons "int" (@SAWCoreScaffolding.toIntMod n) (RecordCons "mul" (@SAWCoreScaffolding.intModMul n) (RecordCons "neg" (@SAWCoreScaffolding.intModNeg n) (RecordCons "ringZero" (@PZeroIntMod n) (RecordCons "sub" (@SAWCoreScaffolding.intModSub n) RecordNil))))). + +Definition PRingIntModNum : forall (num : @Num), @PRing (@IntModNum num) := + fun (num : @Num) => CryptolPrimitivesForSAWCore.Num_rect (fun (n : @Num) => @PRing (@IntModNum n)) PRingIntMod PRingInteger num. + +Definition PRingRational : @PRing Rational := + RecordCons "add" addRational (RecordCons "int" integerToRational (RecordCons "mul" mulRational (RecordCons "neg" negRational (RecordCons "ringZero" PZeroRational (RecordCons "sub" subRational RecordNil))))). + +Definition PRingVec : forall (n : @SAWCoreScaffolding.Nat), forall (a : Type), @PRing a -> @PRing (@SAWCoreVectorsAsCoqVectors.Vec n a) := + fun (n : @SAWCoreScaffolding.Nat) (a : Type) (pa : RecordTypeCons "add" (a -> a -> a) (RecordTypeCons "int" (@SAWCoreScaffolding.Integer -> a) (RecordTypeCons "mul" (a -> a -> a) (RecordTypeCons "neg" (a -> a) (RecordTypeCons "ringZero" a (RecordTypeCons "sub" (a -> a -> a) RecordTypeNil)))))) => RecordCons "add" (@SAWCorePrelude.zipWith a a a (RecordProj pa "add") n) (RecordCons "int" (fun (i : @SAWCoreScaffolding.Integer) => @SAWCorePrelude.replicate n a (RecordProj pa "int" i)) (RecordCons "mul" (@SAWCorePrelude.zipWith a a a (RecordProj pa "mul") n) (RecordCons "neg" (@SAWCorePrelude.map a a (RecordProj pa "neg") n) (RecordCons "ringZero" (@SAWCorePrelude.replicate n a (RecordProj pa "ringZero")) (RecordCons "sub" (@SAWCorePrelude.zipWith a a a (RecordProj pa "sub") n) RecordNil))))). + +Definition PRingStream : forall (a : Type), @PRing a -> @PRing (@SAWCorePrelude.Stream a) := + fun (a : Type) (pa : RecordTypeCons "add" (a -> a -> a) (RecordTypeCons "int" (@SAWCoreScaffolding.Integer -> a) (RecordTypeCons "mul" (a -> a -> a) (RecordTypeCons "neg" (a -> a) (RecordTypeCons "ringZero" a (RecordTypeCons "sub" (a -> a -> a) RecordTypeNil)))))) => RecordCons "add" (@SAWCorePrelude.streamMap2 a a a (RecordProj pa "add")) (RecordCons "int" (fun (i : @SAWCoreScaffolding.Integer) => @SAWCorePrelude.streamConst a (RecordProj pa "int" i)) (RecordCons "mul" (@SAWCorePrelude.streamMap2 a a a (RecordProj pa "mul")) (RecordCons "neg" (@SAWCorePrelude.streamMap a a (RecordProj pa "neg")) (RecordCons "ringZero" (@SAWCorePrelude.streamConst a (RecordProj pa "ringZero")) (RecordCons "sub" (@SAWCorePrelude.streamMap2 a a a (RecordProj pa "sub")) RecordNil))))). + +Definition PRingSeq : forall (n : @Num), forall (a : Type), @PRing a -> @PRing (@seq n a) := + fun (n : @Num) => CryptolPrimitivesForSAWCore.Num_rect (fun (n1 : @Num) => forall (a : Type), @PRing a -> @PRing (@seq n1 a)) (fun (n1 : @SAWCoreScaffolding.Nat) => @PRingVec n1) PRingStream n. + +Definition PRingWord : forall (n : @SAWCoreScaffolding.Nat), @PRing (@SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool)) := + fun (n : @SAWCoreScaffolding.Nat) => RecordCons "add" (@SAWCoreVectorsAsCoqVectors.bvAdd n) (RecordCons "int" (@SAWCoreVectorsAsCoqVectors.intToBv n) (RecordCons "mul" (@SAWCoreVectorsAsCoqVectors.bvMul n) (RecordCons "neg" (@SAWCoreVectorsAsCoqVectors.bvNeg n) (RecordCons "ringZero" (@SAWCoreVectorsAsCoqVectors.bvNat n 0) (RecordCons "sub" (@SAWCoreVectorsAsCoqVectors.bvSub n) RecordNil))))). + +Definition PRingSeqBool : forall (n : @Num), @PRing (@seq n (@SAWCoreScaffolding.Bool)) := + fun (n : @Num) => CryptolPrimitivesForSAWCore.Num_rect (fun (n1 : @Num) => @PRing (@seq n1 (@SAWCoreScaffolding.Bool))) (fun (n1 : @SAWCoreScaffolding.Nat) => @PRingWord n1) (@SAWCoreScaffolding.error (@PRing (@SAWCorePrelude.Stream (@SAWCoreScaffolding.Bool))) "PRingSeqBool: no instance for streams"%string) n. + +Definition PRingFun : forall (a : Type), forall (b : Type), @PRing b -> @PRing (a -> b) := + fun (a : Type) (b : Type) (pb : RecordTypeCons "add" (b -> b -> b) (RecordTypeCons "int" (@SAWCoreScaffolding.Integer -> b) (RecordTypeCons "mul" (b -> b -> b) (RecordTypeCons "neg" (b -> b) (RecordTypeCons "ringZero" b (RecordTypeCons "sub" (b -> b -> b) RecordTypeNil)))))) => RecordCons "add" (@funBinary a b (RecordProj pb "add")) (RecordCons "int" (fun (i : @SAWCoreScaffolding.Integer) (_1 : a) => RecordProj pb "int" i) (RecordCons "mul" (@funBinary a b (RecordProj pb "mul")) (RecordCons "neg" (@compose a b b (RecordProj pb "neg")) (RecordCons "ringZero" (@PZeroFun a b (RecordProj pb "ringZero")) (RecordCons "sub" (@funBinary a b (RecordProj pb "sub")) RecordNil))))). + +Definition PRingUnit : @PRing unit := + RecordCons "add" unitBinary (RecordCons "int" (fun (i : @SAWCoreScaffolding.Integer) => tt) (RecordCons "mul" unitBinary (RecordCons "neg" unitUnary (RecordCons "ringZero" tt (RecordCons "sub" unitBinary RecordNil))))). + +Definition PRingPair : forall (a : Type), forall (b : Type), @PRing a -> @PRing b -> @PRing (prod a b) := + fun (a : Type) (b : Type) (pa : RecordTypeCons "add" (a -> a -> a) (RecordTypeCons "int" (@SAWCoreScaffolding.Integer -> a) (RecordTypeCons "mul" (a -> a -> a) (RecordTypeCons "neg" (a -> a) (RecordTypeCons "ringZero" a (RecordTypeCons "sub" (a -> a -> a) RecordTypeNil)))))) (pb : RecordTypeCons "add" (b -> b -> b) (RecordTypeCons "int" (@SAWCoreScaffolding.Integer -> b) (RecordTypeCons "mul" (b -> b -> b) (RecordTypeCons "neg" (b -> b) (RecordTypeCons "ringZero" b (RecordTypeCons "sub" (b -> b -> b) RecordTypeNil)))))) => RecordCons "add" (@pairBinary a b (RecordProj pa "add") (RecordProj pb "add")) (RecordCons "int" (fun (i : @SAWCoreScaffolding.Integer) => pair (RecordProj pa "int" i) (RecordProj pb "int" i)) (RecordCons "mul" (@pairBinary a b (RecordProj pa "mul") (RecordProj pb "mul")) (RecordCons "neg" (@pairUnary a b (RecordProj pa "neg") (RecordProj pb "neg")) (RecordCons "ringZero" (pair (RecordProj pa "ringZero") (RecordProj pb "ringZero")) (RecordCons "sub" (@pairBinary a b (RecordProj pa "sub") (RecordProj pb "sub")) RecordNil))))). + +Definition PIntegral : Type -> Type := + fun (a : Type) => RecordTypeCons "div" (a -> a -> a) (RecordTypeCons "integralRing" (@PRing a) (RecordTypeCons "mod" (a -> a -> a) (RecordTypeCons "posNegCases" (forall (r : Type), (@SAWCoreScaffolding.Nat -> r) -> (@SAWCoreScaffolding.Nat -> r) -> a -> r) (RecordTypeCons "toInt" (a -> @SAWCoreScaffolding.Integer) RecordTypeNil)))). + +Definition PIntegralInteger : @PIntegral (@SAWCoreScaffolding.Integer) := + RecordCons "div" (@SAWCoreScaffolding.intDiv) (RecordCons "integralRing" PRingInteger (RecordCons "mod" (@SAWCoreScaffolding.intMod) (RecordCons "posNegCases" (fun (r : Type) (pos : @SAWCoreScaffolding.Nat -> r) (neg : @SAWCoreScaffolding.Nat -> r) (i : @SAWCoreScaffolding.Integer) => if @SAWCoreScaffolding.intLe 0%Z i then pos (@SAWCoreScaffolding.intToNat i) else neg (@SAWCoreScaffolding.intToNat (@SAWCoreScaffolding.intNeg i))) (RecordCons "toInt" (fun (i : @SAWCoreScaffolding.Integer) => i) RecordNil)))). + +Definition PIntegralWord : forall (n : @SAWCoreScaffolding.Nat), @PIntegral (@SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool)) := + fun (n : @SAWCoreScaffolding.Nat) => RecordCons "div" (@SAWCoreVectorsAsCoqVectors.bvUDiv n) (RecordCons "integralRing" (@PRingWord n) (RecordCons "mod" (@SAWCoreVectorsAsCoqVectors.bvURem n) (RecordCons "posNegCases" (fun (r : Type) (pos : @SAWCoreScaffolding.Nat -> r) (neg : @SAWCoreScaffolding.Nat -> r) (i : @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool)) => pos (@SAWCoreVectorsAsCoqVectors.bvToNat n i)) (RecordCons "toInt" (@SAWCoreVectorsAsCoqVectors.bvToInt n) RecordNil)))). + +Definition PIntegralSeqBool : forall (n : @Num), @PIntegral (@seq n (@SAWCoreScaffolding.Bool)) := + fun (n : @Num) => CryptolPrimitivesForSAWCore.Num_rect (fun (n1 : @Num) => @PIntegral (@seq n1 (@SAWCoreScaffolding.Bool))) (fun (n1 : @SAWCoreScaffolding.Nat) => @PIntegralWord n1) (@SAWCoreScaffolding.error (@PIntegral (@SAWCorePrelude.Stream (@SAWCoreScaffolding.Bool))) "PIntegralSeqBool: no instance for streams"%string) n. + +Definition PField : Type -> Type := + fun (a : Type) => RecordTypeCons "fieldDiv" (a -> a -> a) (RecordTypeCons "fieldRing" (@PRing a) (RecordTypeCons "recip" (a -> a) RecordTypeNil)). + +Definition PFieldRational : @PField Rational := + RecordCons "fieldDiv" (fun (x : unit) (y : unit) => @SAWCoreScaffolding.error Rational "Unimplemented: (/.) Rational"%string) (RecordCons "fieldRing" PRingRational (RecordCons "recip" (fun (x : unit) => @SAWCoreScaffolding.error Rational "Unimplemented: recip Rational"%string) RecordNil)). + +Definition PFieldIntMod : forall (n : @SAWCoreScaffolding.Nat), @PField (@SAWCoreScaffolding.IntMod n) := + fun (n : @SAWCoreScaffolding.Nat) => RecordCons "fieldDiv" (fun (x : @SAWCoreScaffolding.IntMod n) (y : @SAWCoreScaffolding.IntMod n) => @SAWCoreScaffolding.error (@SAWCoreScaffolding.IntMod n) "Unimplemented: (/.) IntMod"%string) (RecordCons "fieldRing" (@PRingIntMod n) (RecordCons "recip" (fun (x : @SAWCoreScaffolding.IntMod n) => @SAWCoreScaffolding.error (@SAWCoreScaffolding.IntMod n) "Unimplemented: recip IntMod"%string) RecordNil)). + +Definition PFieldIntModNum : forall (n : @Num), @PField (@IntModNum n) := + fun (num : @Num) => CryptolPrimitivesForSAWCore.Num_rect (fun (n : @Num) => @PField (@IntModNum n)) PFieldIntMod (@SAWCoreScaffolding.error (@PField (@IntModNum (@TCInf))) "PFieldIntModNum: no instance for inf"%string) num. + +Definition PRound : Type -> Type := + fun (a : Type) => RecordTypeCons "ceiling" (a -> @SAWCoreScaffolding.Integer) (RecordTypeCons "floor" (a -> @SAWCoreScaffolding.Integer) (RecordTypeCons "roundAway" (a -> @SAWCoreScaffolding.Integer) (RecordTypeCons "roundCmp" (@PCmp a) (RecordTypeCons "roundField" (@PField a) (RecordTypeCons "roundToEven" (a -> @SAWCoreScaffolding.Integer) (RecordTypeCons "trunc" (a -> @SAWCoreScaffolding.Integer) RecordTypeNil)))))). + +Definition PRoundRational : @PRound Rational := + RecordCons "ceiling" (fun (x : unit) => @SAWCoreScaffolding.error (@SAWCoreScaffolding.Integer) "Unimplemented: ceiling Rational"%string) (RecordCons "floor" (fun (x : unit) => @SAWCoreScaffolding.error (@SAWCoreScaffolding.Integer) "Unimplemented: floor Rational"%string) (RecordCons "roundAway" (fun (x : unit) => @SAWCoreScaffolding.error (@SAWCoreScaffolding.Integer) "Unimplemented: roundAway Rational"%string) (RecordCons "roundCmp" PCmpRational (RecordCons "roundField" PFieldRational (RecordCons "roundToEven" (fun (x : unit) => @SAWCoreScaffolding.error (@SAWCoreScaffolding.Integer) "Unimplemented: roundToEven Rational"%string) (RecordCons "trunc" (fun (x : unit) => @SAWCoreScaffolding.error (@SAWCoreScaffolding.Integer) "Unimplemented: trunc Rational"%string) RecordNil)))))). + +Definition PLiteral : forall (a : Type), Type := + fun (a : Type) => @SAWCoreScaffolding.Nat -> a. + +Definition PLiteralLessThan : forall (a : Type), Type := + fun (a : Type) => @SAWCoreScaffolding.Nat -> a. + +Definition PLiteralSeqBool : forall (n : @Num), @PLiteral (@seq n (@SAWCoreScaffolding.Bool)) := + fun (n : @Num) => CryptolPrimitivesForSAWCore.Num_rect (fun (n1 : @Num) => @PLiteral (@seq n1 (@SAWCoreScaffolding.Bool))) (@SAWCoreVectorsAsCoqVectors.bvNat) (@SAWCoreScaffolding.error (@PLiteral (@SAWCorePrelude.Stream (@SAWCoreScaffolding.Bool))) "PLiteralSeqBool: no instance for streams"%string) n. + +Definition PLiteralBit : @PLiteral (@SAWCoreScaffolding.Bool) := + @SAWCorePrelude.Nat_cases (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.false) (fun (n : @SAWCoreScaffolding.Nat) (b : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.true). + +Definition PLiteralInteger : @PLiteral (@SAWCoreScaffolding.Integer) := + @SAWCoreScaffolding.natToInt. + +Definition PLiteralIntMod : forall (n : @SAWCoreScaffolding.Nat), @PLiteral (@SAWCoreScaffolding.IntMod n) := + fun (n : @SAWCoreScaffolding.Nat) (x : @SAWCoreScaffolding.Nat) => @SAWCoreScaffolding.toIntMod n (@SAWCoreScaffolding.natToInt x). + +Definition PLiteralIntModNum : forall (num : @Num), @PLiteral (@IntModNum num) := + fun (num : @Num) => CryptolPrimitivesForSAWCore.Num_rect (fun (n : @Num) => @PLiteral (@IntModNum n)) PLiteralIntMod PLiteralInteger num. + +Definition PLiteralRational : @PLiteral Rational := + fun (x : @SAWCoreScaffolding.Nat) => @SAWCoreScaffolding.error Rational "Unimplemented: Literal Rational"%string. + +Definition ecNumber : forall (val : @Num), forall (a : Type), @PLiteral a -> a := + fun (val : @Num) (a : Type) (pa : @SAWCoreScaffolding.Nat -> a) => CryptolPrimitivesForSAWCore.Num_rect (fun (_1 : @Num) => a) pa (pa 0) val. + +Definition ecFromZ : forall (n : @Num), @IntModNum n -> @SAWCoreScaffolding.Integer := + fun (n : @Num) => CryptolPrimitivesForSAWCore.Num_rect (fun (n1 : @Num) => @IntModNum n1 -> @SAWCoreScaffolding.Integer) (@SAWCoreScaffolding.fromIntMod) (fun (x : @SAWCoreScaffolding.Integer) => x) n. + +Definition ecFromInteger : forall (a : Type), @PRing a -> @SAWCoreScaffolding.Integer -> a := + fun (a : Type) (pa : RecordTypeCons "add" (a -> a -> a) (RecordTypeCons "int" (@SAWCoreScaffolding.Integer -> a) (RecordTypeCons "mul" (a -> a -> a) (RecordTypeCons "neg" (a -> a) (RecordTypeCons "ringZero" a (RecordTypeCons "sub" (a -> a -> a) RecordTypeNil)))))) => RecordProj pa "int". + +Definition ecPlus : forall (a : Type), @PRing a -> a -> a -> a := + fun (a : Type) (pa : RecordTypeCons "add" (a -> a -> a) (RecordTypeCons "int" (@SAWCoreScaffolding.Integer -> a) (RecordTypeCons "mul" (a -> a -> a) (RecordTypeCons "neg" (a -> a) (RecordTypeCons "ringZero" a (RecordTypeCons "sub" (a -> a -> a) RecordTypeNil)))))) => RecordProj pa "add". + +Definition ecMinus : forall (a : Type), @PRing a -> a -> a -> a := + fun (a : Type) (pa : RecordTypeCons "add" (a -> a -> a) (RecordTypeCons "int" (@SAWCoreScaffolding.Integer -> a) (RecordTypeCons "mul" (a -> a -> a) (RecordTypeCons "neg" (a -> a) (RecordTypeCons "ringZero" a (RecordTypeCons "sub" (a -> a -> a) RecordTypeNil)))))) => RecordProj pa "sub". + +Definition ecMul : forall (a : Type), @PRing a -> a -> a -> a := + fun (a : Type) (pa : RecordTypeCons "add" (a -> a -> a) (RecordTypeCons "int" (@SAWCoreScaffolding.Integer -> a) (RecordTypeCons "mul" (a -> a -> a) (RecordTypeCons "neg" (a -> a) (RecordTypeCons "ringZero" a (RecordTypeCons "sub" (a -> a -> a) RecordTypeNil)))))) => RecordProj pa "mul". + +Definition ecNeg : forall (a : Type), @PRing a -> a -> a := + fun (a : Type) (pa : RecordTypeCons "add" (a -> a -> a) (RecordTypeCons "int" (@SAWCoreScaffolding.Integer -> a) (RecordTypeCons "mul" (a -> a -> a) (RecordTypeCons "neg" (a -> a) (RecordTypeCons "ringZero" a (RecordTypeCons "sub" (a -> a -> a) RecordTypeNil)))))) => RecordProj pa "neg". + +Definition ecToInteger : forall (a : Type), @PIntegral a -> a -> @SAWCoreScaffolding.Integer := + fun (a : Type) (pa : RecordTypeCons "div" (a -> a -> a) (RecordTypeCons "integralRing" (RecordTypeCons "add" (a -> a -> a) (RecordTypeCons "int" (@SAWCoreScaffolding.Integer -> a) (RecordTypeCons "mul" (a -> a -> a) (RecordTypeCons "neg" (a -> a) (RecordTypeCons "ringZero" a (RecordTypeCons "sub" (a -> a -> a) RecordTypeNil)))))) (RecordTypeCons "mod" (a -> a -> a) (RecordTypeCons "posNegCases" (forall (r : Type), (@SAWCoreScaffolding.Nat -> r) -> (@SAWCoreScaffolding.Nat -> r) -> a -> r) (RecordTypeCons "toInt" (a -> @SAWCoreScaffolding.Integer) RecordTypeNil))))) => RecordProj pa "toInt". + +Definition ecDiv : forall (a : Type), @PIntegral a -> a -> a -> a := + fun (a : Type) (pi : RecordTypeCons "div" (a -> a -> a) (RecordTypeCons "integralRing" (RecordTypeCons "add" (a -> a -> a) (RecordTypeCons "int" (@SAWCoreScaffolding.Integer -> a) (RecordTypeCons "mul" (a -> a -> a) (RecordTypeCons "neg" (a -> a) (RecordTypeCons "ringZero" a (RecordTypeCons "sub" (a -> a -> a) RecordTypeNil)))))) (RecordTypeCons "mod" (a -> a -> a) (RecordTypeCons "posNegCases" (forall (r : Type), (@SAWCoreScaffolding.Nat -> r) -> (@SAWCoreScaffolding.Nat -> r) -> a -> r) (RecordTypeCons "toInt" (a -> @SAWCoreScaffolding.Integer) RecordTypeNil))))) => RecordProj pi "div". + +Definition ecMod : forall (a : Type), @PIntegral a -> a -> a -> a := + fun (a : Type) (pi : RecordTypeCons "div" (a -> a -> a) (RecordTypeCons "integralRing" (RecordTypeCons "add" (a -> a -> a) (RecordTypeCons "int" (@SAWCoreScaffolding.Integer -> a) (RecordTypeCons "mul" (a -> a -> a) (RecordTypeCons "neg" (a -> a) (RecordTypeCons "ringZero" a (RecordTypeCons "sub" (a -> a -> a) RecordTypeNil)))))) (RecordTypeCons "mod" (a -> a -> a) (RecordTypeCons "posNegCases" (forall (r : Type), (@SAWCoreScaffolding.Nat -> r) -> (@SAWCoreScaffolding.Nat -> r) -> a -> r) (RecordTypeCons "toInt" (a -> @SAWCoreScaffolding.Integer) RecordTypeNil))))) => RecordProj pi "mod". + +Definition ecExp : forall (a : Type), forall (b : Type), @PRing a -> @PIntegral b -> a -> b -> a := + fun (a : Type) (b : Type) (pa : RecordTypeCons "add" (a -> a -> a) (RecordTypeCons "int" (@SAWCoreScaffolding.Integer -> a) (RecordTypeCons "mul" (a -> a -> a) (RecordTypeCons "neg" (a -> a) (RecordTypeCons "ringZero" a (RecordTypeCons "sub" (a -> a -> a) RecordTypeNil)))))) (pi : RecordTypeCons "div" (b -> b -> b) (RecordTypeCons "integralRing" (RecordTypeCons "add" (b -> b -> b) (RecordTypeCons "int" (@SAWCoreScaffolding.Integer -> b) (RecordTypeCons "mul" (b -> b -> b) (RecordTypeCons "neg" (b -> b) (RecordTypeCons "ringZero" b (RecordTypeCons "sub" (b -> b -> b) RecordTypeNil)))))) (RecordTypeCons "mod" (b -> b -> b) (RecordTypeCons "posNegCases" (forall (r : Type), (@SAWCoreScaffolding.Nat -> r) -> (@SAWCoreScaffolding.Nat -> r) -> b -> r) (RecordTypeCons "toInt" (b -> @SAWCoreScaffolding.Integer) RecordTypeNil))))) (x : a) => RecordProj pi "posNegCases" a (@SAWCorePrelude.expByNat a (RecordProj pa "int" 1%Z) (RecordProj pa "mul") x) (fun (_1 : @SAWCoreScaffolding.Nat) => RecordProj pa "int" 1%Z). + +Definition ecRecip : forall (a : Type), @PField a -> a -> a := + fun (a : Type) (pf : RecordTypeCons "fieldDiv" (a -> a -> a) (RecordTypeCons "fieldRing" (RecordTypeCons "add" (a -> a -> a) (RecordTypeCons "int" (@SAWCoreScaffolding.Integer -> a) (RecordTypeCons "mul" (a -> a -> a) (RecordTypeCons "neg" (a -> a) (RecordTypeCons "ringZero" a (RecordTypeCons "sub" (a -> a -> a) RecordTypeNil)))))) (RecordTypeCons "recip" (a -> a) RecordTypeNil))) => RecordProj pf "recip". + +Definition ecFieldDiv : forall (a : Type), @PField a -> a -> a -> a := + fun (a : Type) (pf : RecordTypeCons "fieldDiv" (a -> a -> a) (RecordTypeCons "fieldRing" (RecordTypeCons "add" (a -> a -> a) (RecordTypeCons "int" (@SAWCoreScaffolding.Integer -> a) (RecordTypeCons "mul" (a -> a -> a) (RecordTypeCons "neg" (a -> a) (RecordTypeCons "ringZero" a (RecordTypeCons "sub" (a -> a -> a) RecordTypeNil)))))) (RecordTypeCons "recip" (a -> a) RecordTypeNil))) => RecordProj pf "fieldDiv". + +Definition ecCeiling : forall (a : Type), @PRound a -> a -> @SAWCoreScaffolding.Integer := + fun (a : Type) (pr : RecordTypeCons "ceiling" (a -> @SAWCoreScaffolding.Integer) (RecordTypeCons "floor" (a -> @SAWCoreScaffolding.Integer) (RecordTypeCons "roundAway" (a -> @SAWCoreScaffolding.Integer) (RecordTypeCons "roundCmp" (RecordTypeCons "cmp" (a -> a -> @SAWCoreScaffolding.Bool -> @SAWCoreScaffolding.Bool) (RecordTypeCons "cmpEq" (RecordTypeCons "eq" (a -> a -> @SAWCoreScaffolding.Bool) RecordTypeNil) RecordTypeNil)) (RecordTypeCons "roundField" (RecordTypeCons "fieldDiv" (a -> a -> a) (RecordTypeCons "fieldRing" (RecordTypeCons "add" (a -> a -> a) (RecordTypeCons "int" (@SAWCoreScaffolding.Integer -> a) (RecordTypeCons "mul" (a -> a -> a) (RecordTypeCons "neg" (a -> a) (RecordTypeCons "ringZero" a (RecordTypeCons "sub" (a -> a -> a) RecordTypeNil)))))) (RecordTypeCons "recip" (a -> a) RecordTypeNil))) (RecordTypeCons "roundToEven" (a -> @SAWCoreScaffolding.Integer) (RecordTypeCons "trunc" (a -> @SAWCoreScaffolding.Integer) RecordTypeNil))))))) => RecordProj pr "ceiling". + +Definition ecFloor : forall (a : Type), @PRound a -> a -> @SAWCoreScaffolding.Integer := + fun (a : Type) (pr : RecordTypeCons "ceiling" (a -> @SAWCoreScaffolding.Integer) (RecordTypeCons "floor" (a -> @SAWCoreScaffolding.Integer) (RecordTypeCons "roundAway" (a -> @SAWCoreScaffolding.Integer) (RecordTypeCons "roundCmp" (RecordTypeCons "cmp" (a -> a -> @SAWCoreScaffolding.Bool -> @SAWCoreScaffolding.Bool) (RecordTypeCons "cmpEq" (RecordTypeCons "eq" (a -> a -> @SAWCoreScaffolding.Bool) RecordTypeNil) RecordTypeNil)) (RecordTypeCons "roundField" (RecordTypeCons "fieldDiv" (a -> a -> a) (RecordTypeCons "fieldRing" (RecordTypeCons "add" (a -> a -> a) (RecordTypeCons "int" (@SAWCoreScaffolding.Integer -> a) (RecordTypeCons "mul" (a -> a -> a) (RecordTypeCons "neg" (a -> a) (RecordTypeCons "ringZero" a (RecordTypeCons "sub" (a -> a -> a) RecordTypeNil)))))) (RecordTypeCons "recip" (a -> a) RecordTypeNil))) (RecordTypeCons "roundToEven" (a -> @SAWCoreScaffolding.Integer) (RecordTypeCons "trunc" (a -> @SAWCoreScaffolding.Integer) RecordTypeNil))))))) => RecordProj pr "floor". + +Definition ecTruncate : forall (a : Type), @PRound a -> a -> @SAWCoreScaffolding.Integer := + fun (a : Type) (pr : RecordTypeCons "ceiling" (a -> @SAWCoreScaffolding.Integer) (RecordTypeCons "floor" (a -> @SAWCoreScaffolding.Integer) (RecordTypeCons "roundAway" (a -> @SAWCoreScaffolding.Integer) (RecordTypeCons "roundCmp" (RecordTypeCons "cmp" (a -> a -> @SAWCoreScaffolding.Bool -> @SAWCoreScaffolding.Bool) (RecordTypeCons "cmpEq" (RecordTypeCons "eq" (a -> a -> @SAWCoreScaffolding.Bool) RecordTypeNil) RecordTypeNil)) (RecordTypeCons "roundField" (RecordTypeCons "fieldDiv" (a -> a -> a) (RecordTypeCons "fieldRing" (RecordTypeCons "add" (a -> a -> a) (RecordTypeCons "int" (@SAWCoreScaffolding.Integer -> a) (RecordTypeCons "mul" (a -> a -> a) (RecordTypeCons "neg" (a -> a) (RecordTypeCons "ringZero" a (RecordTypeCons "sub" (a -> a -> a) RecordTypeNil)))))) (RecordTypeCons "recip" (a -> a) RecordTypeNil))) (RecordTypeCons "roundToEven" (a -> @SAWCoreScaffolding.Integer) (RecordTypeCons "trunc" (a -> @SAWCoreScaffolding.Integer) RecordTypeNil))))))) => RecordProj pr "trunc". + +Definition ecRoundAway : forall (a : Type), @PRound a -> a -> @SAWCoreScaffolding.Integer := + fun (a : Type) (pr : RecordTypeCons "ceiling" (a -> @SAWCoreScaffolding.Integer) (RecordTypeCons "floor" (a -> @SAWCoreScaffolding.Integer) (RecordTypeCons "roundAway" (a -> @SAWCoreScaffolding.Integer) (RecordTypeCons "roundCmp" (RecordTypeCons "cmp" (a -> a -> @SAWCoreScaffolding.Bool -> @SAWCoreScaffolding.Bool) (RecordTypeCons "cmpEq" (RecordTypeCons "eq" (a -> a -> @SAWCoreScaffolding.Bool) RecordTypeNil) RecordTypeNil)) (RecordTypeCons "roundField" (RecordTypeCons "fieldDiv" (a -> a -> a) (RecordTypeCons "fieldRing" (RecordTypeCons "add" (a -> a -> a) (RecordTypeCons "int" (@SAWCoreScaffolding.Integer -> a) (RecordTypeCons "mul" (a -> a -> a) (RecordTypeCons "neg" (a -> a) (RecordTypeCons "ringZero" a (RecordTypeCons "sub" (a -> a -> a) RecordTypeNil)))))) (RecordTypeCons "recip" (a -> a) RecordTypeNil))) (RecordTypeCons "roundToEven" (a -> @SAWCoreScaffolding.Integer) (RecordTypeCons "trunc" (a -> @SAWCoreScaffolding.Integer) RecordTypeNil))))))) => RecordProj pr "roundAway". + +Definition ecRoundToEven : forall (a : Type), @PRound a -> a -> @SAWCoreScaffolding.Integer := + fun (a : Type) (pr : RecordTypeCons "ceiling" (a -> @SAWCoreScaffolding.Integer) (RecordTypeCons "floor" (a -> @SAWCoreScaffolding.Integer) (RecordTypeCons "roundAway" (a -> @SAWCoreScaffolding.Integer) (RecordTypeCons "roundCmp" (RecordTypeCons "cmp" (a -> a -> @SAWCoreScaffolding.Bool -> @SAWCoreScaffolding.Bool) (RecordTypeCons "cmpEq" (RecordTypeCons "eq" (a -> a -> @SAWCoreScaffolding.Bool) RecordTypeNil) RecordTypeNil)) (RecordTypeCons "roundField" (RecordTypeCons "fieldDiv" (a -> a -> a) (RecordTypeCons "fieldRing" (RecordTypeCons "add" (a -> a -> a) (RecordTypeCons "int" (@SAWCoreScaffolding.Integer -> a) (RecordTypeCons "mul" (a -> a -> a) (RecordTypeCons "neg" (a -> a) (RecordTypeCons "ringZero" a (RecordTypeCons "sub" (a -> a -> a) RecordTypeNil)))))) (RecordTypeCons "recip" (a -> a) RecordTypeNil))) (RecordTypeCons "roundToEven" (a -> @SAWCoreScaffolding.Integer) (RecordTypeCons "trunc" (a -> @SAWCoreScaffolding.Integer) RecordTypeNil))))))) => RecordProj pr "roundToEven". + +Definition ecLg2 : forall (n : @Num), @seq n (@SAWCoreScaffolding.Bool) -> @seq n (@SAWCoreScaffolding.Bool) := + fun (n : @Num) => CryptolPrimitivesForSAWCore.Num_rect (fun (n1 : @Num) => @seq n1 (@SAWCoreScaffolding.Bool) -> @seq n1 (@SAWCoreScaffolding.Bool)) (@SAWCoreVectorsAsCoqVectors.bvLg2) (@SAWCoreScaffolding.error (@SAWCorePrelude.Stream (@SAWCoreScaffolding.Bool) -> @SAWCorePrelude.Stream (@SAWCoreScaffolding.Bool)) "ecLg2: expected finite word"%string) n. + +Definition ecSDiv : forall (n : @Num), @seq n (@SAWCoreScaffolding.Bool) -> @seq n (@SAWCoreScaffolding.Bool) -> @seq n (@SAWCoreScaffolding.Bool) := + fun (n : @Num) => CryptolPrimitivesForSAWCore.Num_rect (fun (n1 : @Num) => @seq n1 (@SAWCoreScaffolding.Bool) -> @seq n1 (@SAWCoreScaffolding.Bool) -> @seq n1 (@SAWCoreScaffolding.Bool)) (@SAWCorePrelude.Nat__rec (fun (n1 : @SAWCoreScaffolding.Nat) => @SAWCoreVectorsAsCoqVectors.Vec n1 (@SAWCoreScaffolding.Bool) -> @SAWCoreVectorsAsCoqVectors.Vec n1 (@SAWCoreScaffolding.Bool) -> @SAWCoreVectorsAsCoqVectors.Vec n1 (@SAWCoreScaffolding.Bool)) (@SAWCoreScaffolding.error (@SAWCoreVectorsAsCoqVectors.Vec 0 (@SAWCoreScaffolding.Bool) -> @SAWCoreVectorsAsCoqVectors.Vec 0 (@SAWCoreScaffolding.Bool) -> @SAWCoreVectorsAsCoqVectors.Vec 0 (@SAWCoreScaffolding.Bool)) "ecSDiv: illegal 0-width word"%string) (fun (n' : @SAWCoreScaffolding.Nat) (_1 : @SAWCoreVectorsAsCoqVectors.Vec n' (@SAWCoreScaffolding.Bool) -> @SAWCoreVectorsAsCoqVectors.Vec n' (@SAWCoreScaffolding.Bool) -> @SAWCoreVectorsAsCoqVectors.Vec n' (@SAWCoreScaffolding.Bool)) => @SAWCoreVectorsAsCoqVectors.bvSDiv n')) (@SAWCoreScaffolding.error (@SAWCorePrelude.Stream (@SAWCoreScaffolding.Bool) -> @SAWCorePrelude.Stream (@SAWCoreScaffolding.Bool) -> @SAWCorePrelude.Stream (@SAWCoreScaffolding.Bool)) "ecSDiv: expected finite word"%string) n. + +Definition ecSMod : forall (n : @Num), @seq n (@SAWCoreScaffolding.Bool) -> @seq n (@SAWCoreScaffolding.Bool) -> @seq n (@SAWCoreScaffolding.Bool) := + fun (n : @Num) => CryptolPrimitivesForSAWCore.Num_rect (fun (n1 : @Num) => @seq n1 (@SAWCoreScaffolding.Bool) -> @seq n1 (@SAWCoreScaffolding.Bool) -> @seq n1 (@SAWCoreScaffolding.Bool)) (@SAWCorePrelude.Nat__rec (fun (n1 : @SAWCoreScaffolding.Nat) => @SAWCoreVectorsAsCoqVectors.Vec n1 (@SAWCoreScaffolding.Bool) -> @SAWCoreVectorsAsCoqVectors.Vec n1 (@SAWCoreScaffolding.Bool) -> @SAWCoreVectorsAsCoqVectors.Vec n1 (@SAWCoreScaffolding.Bool)) (@SAWCoreScaffolding.error (@SAWCoreVectorsAsCoqVectors.Vec 0 (@SAWCoreScaffolding.Bool) -> @SAWCoreVectorsAsCoqVectors.Vec 0 (@SAWCoreScaffolding.Bool) -> @SAWCoreVectorsAsCoqVectors.Vec 0 (@SAWCoreScaffolding.Bool)) "ecSMod: illegal 0-width word"%string) (fun (n' : @SAWCoreScaffolding.Nat) (_1 : @SAWCoreVectorsAsCoqVectors.Vec n' (@SAWCoreScaffolding.Bool) -> @SAWCoreVectorsAsCoqVectors.Vec n' (@SAWCoreScaffolding.Bool) -> @SAWCoreVectorsAsCoqVectors.Vec n' (@SAWCoreScaffolding.Bool)) => @SAWCoreVectorsAsCoqVectors.bvSRem n')) (@SAWCoreScaffolding.error (@SAWCorePrelude.Stream (@SAWCoreScaffolding.Bool) -> @SAWCorePrelude.Stream (@SAWCoreScaffolding.Bool) -> @SAWCorePrelude.Stream (@SAWCoreScaffolding.Bool)) "ecSMod: expected finite word"%string) n. + +Definition ecEq : forall (a : Type), @PEq a -> a -> a -> @SAWCoreScaffolding.Bool := + fun (a : Type) (pa : RecordTypeCons "eq" (a -> a -> @SAWCoreScaffolding.Bool) RecordTypeNil) => RecordProj pa "eq". + +Definition ecNotEq : forall (a : Type), @PEq a -> a -> a -> @SAWCoreScaffolding.Bool := + fun (a : Type) (pa : RecordTypeCons "eq" (a -> a -> @SAWCoreScaffolding.Bool) RecordTypeNil) (x : a) (y : a) => @SAWCoreScaffolding.not (@ecEq a pa x y). + +Definition ecLt : forall (a : Type), @PCmp a -> a -> a -> @SAWCoreScaffolding.Bool := + fun (a : Type) (pa : RecordTypeCons "cmp" (a -> a -> @SAWCoreScaffolding.Bool -> @SAWCoreScaffolding.Bool) (RecordTypeCons "cmpEq" (RecordTypeCons "eq" (a -> a -> @SAWCoreScaffolding.Bool) RecordTypeNil) RecordTypeNil)) (x : a) (y : a) => RecordProj pa "cmp" x y (@SAWCoreScaffolding.false). + +Definition ecGt : forall (a : Type), @PCmp a -> a -> a -> @SAWCoreScaffolding.Bool := + fun (a : Type) (pa : RecordTypeCons "cmp" (a -> a -> @SAWCoreScaffolding.Bool -> @SAWCoreScaffolding.Bool) (RecordTypeCons "cmpEq" (RecordTypeCons "eq" (a -> a -> @SAWCoreScaffolding.Bool) RecordTypeNil) RecordTypeNil)) (x : a) (y : a) => @ecLt a pa y x. + +Definition ecLtEq : forall (a : Type), @PCmp a -> a -> a -> @SAWCoreScaffolding.Bool := + fun (a : Type) (pa : RecordTypeCons "cmp" (a -> a -> @SAWCoreScaffolding.Bool -> @SAWCoreScaffolding.Bool) (RecordTypeCons "cmpEq" (RecordTypeCons "eq" (a -> a -> @SAWCoreScaffolding.Bool) RecordTypeNil) RecordTypeNil)) (x : a) (y : a) => @SAWCoreScaffolding.not (@ecLt a pa y x). + +Definition ecGtEq : forall (a : Type), @PCmp a -> a -> a -> @SAWCoreScaffolding.Bool := + fun (a : Type) (pa : RecordTypeCons "cmp" (a -> a -> @SAWCoreScaffolding.Bool -> @SAWCoreScaffolding.Bool) (RecordTypeCons "cmpEq" (RecordTypeCons "eq" (a -> a -> @SAWCoreScaffolding.Bool) RecordTypeNil) RecordTypeNil)) (x : a) (y : a) => @SAWCoreScaffolding.not (@ecLt a pa x y). + +Definition ecSLt : forall (a : Type), @PSignedCmp a -> a -> a -> @SAWCoreScaffolding.Bool := + fun (a : Type) (pa : RecordTypeCons "scmp" (a -> a -> @SAWCoreScaffolding.Bool -> @SAWCoreScaffolding.Bool) (RecordTypeCons "signedCmpEq" (RecordTypeCons "eq" (a -> a -> @SAWCoreScaffolding.Bool) RecordTypeNil) RecordTypeNil)) (x : a) (y : a) => RecordProj pa "scmp" x y (@SAWCoreScaffolding.false). + +Definition ecAnd : forall (a : Type), @PLogic a -> a -> a -> a := + fun (a : Type) (pa : RecordTypeCons "and" (a -> a -> a) (RecordTypeCons "logicZero" a (RecordTypeCons "not" (a -> a) (RecordTypeCons "or" (a -> a -> a) (RecordTypeCons "xor" (a -> a -> a) RecordTypeNil))))) => RecordProj pa "and". + +Definition ecOr : forall (a : Type), @PLogic a -> a -> a -> a := + fun (a : Type) (pa : RecordTypeCons "and" (a -> a -> a) (RecordTypeCons "logicZero" a (RecordTypeCons "not" (a -> a) (RecordTypeCons "or" (a -> a -> a) (RecordTypeCons "xor" (a -> a -> a) RecordTypeNil))))) => RecordProj pa "or". + +Definition ecXor : forall (a : Type), @PLogic a -> a -> a -> a := + fun (a : Type) (pa : RecordTypeCons "and" (a -> a -> a) (RecordTypeCons "logicZero" a (RecordTypeCons "not" (a -> a) (RecordTypeCons "or" (a -> a -> a) (RecordTypeCons "xor" (a -> a -> a) RecordTypeNil))))) => RecordProj pa "xor". + +Definition ecCompl : forall (a : Type), @PLogic a -> a -> a := + fun (a : Type) (pa : RecordTypeCons "and" (a -> a -> a) (RecordTypeCons "logicZero" a (RecordTypeCons "not" (a -> a) (RecordTypeCons "or" (a -> a -> a) (RecordTypeCons "xor" (a -> a -> a) RecordTypeNil))))) => RecordProj pa "not". + +Definition ecZero : forall (a : Type), @PZero a -> a := + fun (a : Type) (pa : a) => pa. + +Definition ecFraction : forall (a : Type), a := + fun (a : Type) => @SAWCoreScaffolding.error a "Unimplemented: fraction"%string. + +Definition ecShiftL : forall (m : @Num), forall (ix : Type), forall (a : Type), @PIntegral ix -> @PZero a -> @seq m a -> ix -> @seq m a := + fun (m : @Num) => CryptolPrimitivesForSAWCore.Num_rect (fun (m1 : @Num) => forall (ix : Type), forall (a : Type), @PIntegral ix -> @PZero a -> @seq m1 a -> ix -> @seq m1 a) (fun (m1 : @SAWCoreScaffolding.Nat) (ix : Type) (a : Type) (pix : RecordTypeCons "div" (ix -> ix -> ix) (RecordTypeCons "integralRing" (RecordTypeCons "add" (ix -> ix -> ix) (RecordTypeCons "int" (@SAWCoreScaffolding.Integer -> ix) (RecordTypeCons "mul" (ix -> ix -> ix) (RecordTypeCons "neg" (ix -> ix) (RecordTypeCons "ringZero" ix (RecordTypeCons "sub" (ix -> ix -> ix) RecordTypeNil)))))) (RecordTypeCons "mod" (ix -> ix -> ix) (RecordTypeCons "posNegCases" (forall (r : Type), (@SAWCoreScaffolding.Nat -> r) -> (@SAWCoreScaffolding.Nat -> r) -> ix -> r) (RecordTypeCons "toInt" (ix -> @SAWCoreScaffolding.Integer) RecordTypeNil))))) (pz : a) (xs : @SAWCoreVectorsAsCoqVectors.Vec m1 a) => RecordProj pix "posNegCases" (@SAWCoreVectorsAsCoqVectors.Vec m1 a) (@SAWCoreVectorsAsCoqVectors.shiftL m1 a (@ecZero a pz) xs) (@SAWCoreVectorsAsCoqVectors.shiftR m1 a (@ecZero a pz) xs)) (fun (ix : Type) (a : Type) (pix : RecordTypeCons "div" (ix -> ix -> ix) (RecordTypeCons "integralRing" (RecordTypeCons "add" (ix -> ix -> ix) (RecordTypeCons "int" (@SAWCoreScaffolding.Integer -> ix) (RecordTypeCons "mul" (ix -> ix -> ix) (RecordTypeCons "neg" (ix -> ix) (RecordTypeCons "ringZero" ix (RecordTypeCons "sub" (ix -> ix -> ix) RecordTypeNil)))))) (RecordTypeCons "mod" (ix -> ix -> ix) (RecordTypeCons "posNegCases" (forall (r : Type), (@SAWCoreScaffolding.Nat -> r) -> (@SAWCoreScaffolding.Nat -> r) -> ix -> r) (RecordTypeCons "toInt" (ix -> @SAWCoreScaffolding.Integer) RecordTypeNil))))) (pz : a) (xs : @SAWCorePrelude.Stream a) => RecordProj pix "posNegCases" (@SAWCorePrelude.Stream a) (@SAWCorePrelude.streamShiftL a xs) (@SAWCorePrelude.streamShiftR a pz xs)) m. + +Definition ecShiftR : forall (m : @Num), forall (ix : Type), forall (a : Type), @PIntegral ix -> @PZero a -> @seq m a -> ix -> @seq m a := + fun (m : @Num) => CryptolPrimitivesForSAWCore.Num_rect (fun (m1 : @Num) => forall (ix : Type), forall (a : Type), @PIntegral ix -> @PZero a -> @seq m1 a -> ix -> @seq m1 a) (fun (m1 : @SAWCoreScaffolding.Nat) (ix : Type) (a : Type) (pix : RecordTypeCons "div" (ix -> ix -> ix) (RecordTypeCons "integralRing" (RecordTypeCons "add" (ix -> ix -> ix) (RecordTypeCons "int" (@SAWCoreScaffolding.Integer -> ix) (RecordTypeCons "mul" (ix -> ix -> ix) (RecordTypeCons "neg" (ix -> ix) (RecordTypeCons "ringZero" ix (RecordTypeCons "sub" (ix -> ix -> ix) RecordTypeNil)))))) (RecordTypeCons "mod" (ix -> ix -> ix) (RecordTypeCons "posNegCases" (forall (r : Type), (@SAWCoreScaffolding.Nat -> r) -> (@SAWCoreScaffolding.Nat -> r) -> ix -> r) (RecordTypeCons "toInt" (ix -> @SAWCoreScaffolding.Integer) RecordTypeNil))))) (pz : a) (xs : @SAWCoreVectorsAsCoqVectors.Vec m1 a) => RecordProj pix "posNegCases" (@SAWCoreVectorsAsCoqVectors.Vec m1 a) (@SAWCoreVectorsAsCoqVectors.shiftR m1 a (@ecZero a pz) xs) (@SAWCoreVectorsAsCoqVectors.shiftL m1 a (@ecZero a pz) xs)) (fun (ix : Type) (a : Type) (pix : RecordTypeCons "div" (ix -> ix -> ix) (RecordTypeCons "integralRing" (RecordTypeCons "add" (ix -> ix -> ix) (RecordTypeCons "int" (@SAWCoreScaffolding.Integer -> ix) (RecordTypeCons "mul" (ix -> ix -> ix) (RecordTypeCons "neg" (ix -> ix) (RecordTypeCons "ringZero" ix (RecordTypeCons "sub" (ix -> ix -> ix) RecordTypeNil)))))) (RecordTypeCons "mod" (ix -> ix -> ix) (RecordTypeCons "posNegCases" (forall (r : Type), (@SAWCoreScaffolding.Nat -> r) -> (@SAWCoreScaffolding.Nat -> r) -> ix -> r) (RecordTypeCons "toInt" (ix -> @SAWCoreScaffolding.Integer) RecordTypeNil))))) (pz : a) (xs : @SAWCorePrelude.Stream a) => RecordProj pix "posNegCases" (@SAWCorePrelude.Stream a) (@SAWCorePrelude.streamShiftR a pz xs) (@SAWCorePrelude.streamShiftL a xs)) m. + +Definition ecSShiftR : forall (n : @Num), forall (ix : Type), @PIntegral ix -> @seq n (@SAWCoreScaffolding.Bool) -> ix -> @seq n (@SAWCoreScaffolding.Bool) := + @finNumRec (fun (n : @Num) => forall (ix : Type), @PIntegral ix -> @seq n (@SAWCoreScaffolding.Bool) -> ix -> @seq n (@SAWCoreScaffolding.Bool)) (fun (n : @SAWCoreScaffolding.Nat) (ix : Type) (pix : RecordTypeCons "div" (ix -> ix -> ix) (RecordTypeCons "integralRing" (RecordTypeCons "add" (ix -> ix -> ix) (RecordTypeCons "int" (@SAWCoreScaffolding.Integer -> ix) (RecordTypeCons "mul" (ix -> ix -> ix) (RecordTypeCons "neg" (ix -> ix) (RecordTypeCons "ringZero" ix (RecordTypeCons "sub" (ix -> ix -> ix) RecordTypeNil)))))) (RecordTypeCons "mod" (ix -> ix -> ix) (RecordTypeCons "posNegCases" (forall (r : Type), (@SAWCoreScaffolding.Nat -> r) -> (@SAWCoreScaffolding.Nat -> r) -> ix -> r) (RecordTypeCons "toInt" (ix -> @SAWCoreScaffolding.Integer) RecordTypeNil))))) => @SAWCorePrelude.natCase (fun (w : @SAWCoreScaffolding.Nat) => @SAWCoreVectorsAsCoqVectors.Vec w (@SAWCoreScaffolding.Bool) -> ix -> @SAWCoreVectorsAsCoqVectors.Vec w (@SAWCoreScaffolding.Bool)) (fun (xs : @SAWCoreVectorsAsCoqVectors.Vec 0 (@SAWCoreScaffolding.Bool)) (_1 : ix) => xs) (fun (w : @SAWCoreScaffolding.Nat) (xs : @SAWCoreVectorsAsCoqVectors.Vec (@SAWCoreScaffolding.Succ w) (@SAWCoreScaffolding.Bool)) => RecordProj pix "posNegCases" (@SAWCoreVectorsAsCoqVectors.Vec (@SAWCoreScaffolding.Succ w) (@SAWCoreScaffolding.Bool)) (@SAWCoreVectorsAsCoqVectors.bvSShr w xs) (@SAWCoreVectorsAsCoqVectors.bvShl (@SAWCoreScaffolding.Succ w) xs)) n). + +Definition ecRotL : forall (m : @Num), forall (ix : Type), forall (a : Type), @PIntegral ix -> @seq m a -> ix -> @seq m a := + @finNumRec (fun (m : @Num) => forall (ix : Type), forall (a : Type), @PIntegral ix -> @seq m a -> ix -> @seq m a) (fun (m : @SAWCoreScaffolding.Nat) (ix : Type) (a : Type) (pix : RecordTypeCons "div" (ix -> ix -> ix) (RecordTypeCons "integralRing" (RecordTypeCons "add" (ix -> ix -> ix) (RecordTypeCons "int" (@SAWCoreScaffolding.Integer -> ix) (RecordTypeCons "mul" (ix -> ix -> ix) (RecordTypeCons "neg" (ix -> ix) (RecordTypeCons "ringZero" ix (RecordTypeCons "sub" (ix -> ix -> ix) RecordTypeNil)))))) (RecordTypeCons "mod" (ix -> ix -> ix) (RecordTypeCons "posNegCases" (forall (r : Type), (@SAWCoreScaffolding.Nat -> r) -> (@SAWCoreScaffolding.Nat -> r) -> ix -> r) (RecordTypeCons "toInt" (ix -> @SAWCoreScaffolding.Integer) RecordTypeNil))))) (xs : @SAWCoreVectorsAsCoqVectors.Vec m a) => RecordProj pix "posNegCases" (@SAWCoreVectorsAsCoqVectors.Vec m a) (@SAWCoreVectorsAsCoqVectors.rotateL m a xs) (@SAWCoreVectorsAsCoqVectors.rotateR m a xs)). + +Definition ecRotR : forall (m : @Num), forall (ix : Type), forall (a : Type), @PIntegral ix -> @seq m a -> ix -> @seq m a := + @finNumRec (fun (m : @Num) => forall (ix : Type), forall (a : Type), @PIntegral ix -> @seq m a -> ix -> @seq m a) (fun (m : @SAWCoreScaffolding.Nat) (ix : Type) (a : Type) (pix : RecordTypeCons "div" (ix -> ix -> ix) (RecordTypeCons "integralRing" (RecordTypeCons "add" (ix -> ix -> ix) (RecordTypeCons "int" (@SAWCoreScaffolding.Integer -> ix) (RecordTypeCons "mul" (ix -> ix -> ix) (RecordTypeCons "neg" (ix -> ix) (RecordTypeCons "ringZero" ix (RecordTypeCons "sub" (ix -> ix -> ix) RecordTypeNil)))))) (RecordTypeCons "mod" (ix -> ix -> ix) (RecordTypeCons "posNegCases" (forall (r : Type), (@SAWCoreScaffolding.Nat -> r) -> (@SAWCoreScaffolding.Nat -> r) -> ix -> r) (RecordTypeCons "toInt" (ix -> @SAWCoreScaffolding.Integer) RecordTypeNil))))) (xs : @SAWCoreVectorsAsCoqVectors.Vec m a) => RecordProj pix "posNegCases" (@SAWCoreVectorsAsCoqVectors.Vec m a) (@SAWCoreVectorsAsCoqVectors.rotateR m a xs) (@SAWCoreVectorsAsCoqVectors.rotateL m a xs)). + +Definition ecCat : forall (m : @Num), forall (n : @Num), forall (a : Type), @seq m a -> @seq n a -> @seq (@tcAdd m n) a := + @finNumRec (fun (m : @Num) => forall (n : @Num), forall (a : Type), @seq m a -> @seq n a -> @seq (@tcAdd m n) a) (fun (m : @SAWCoreScaffolding.Nat) => @CryptolPrimitivesForSAWCore.Num_rect (fun (n : @Num) => forall (a : Type), @SAWCoreVectorsAsCoqVectors.Vec m a -> @seq n a -> @seq (@tcAdd (@TCNum m) n) a) (fun (n : @SAWCoreScaffolding.Nat) (a : Type) => @SAWCorePrelude.append m n a) (fun (a : Type) => @SAWCorePrelude.streamAppend a m)). + +Definition ecSplitAt : forall (m : @Num), forall (n : @Num), forall (a : Type), @seq (@tcAdd m n) a -> prod (@seq m a) (@seq n a) := + @finNumRec (fun (m : @Num) => forall (n : @Num), forall (a : Type), @seq (@tcAdd m n) a -> prod (@seq m a) (@seq n a)) (fun (m : @SAWCoreScaffolding.Nat) => @CryptolPrimitivesForSAWCore.Num_rect (fun (n : @Num) => forall (a : Type), @seq (@tcAdd (@TCNum m) n) a -> prod (@SAWCoreVectorsAsCoqVectors.Vec m a) (@seq n a)) (fun (n : @SAWCoreScaffolding.Nat) (a : Type) (xs : @SAWCoreVectorsAsCoqVectors.Vec (@SAWCorePrelude.addNat m n) a) => pair (@SAWCorePrelude.take a m n xs) (@SAWCorePrelude.drop a m n xs)) (fun (a : Type) (xs : @SAWCorePrelude.Stream a) => pair (@SAWCorePrelude.streamTake a m xs) (@SAWCorePrelude.streamDrop a m xs))). + +Definition ecJoin : forall (m : @Num), forall (n : @Num), forall (a : Type), @seq m (@seq n a) -> @seq (@tcMul m n) a := + fun (m : @Num) => CryptolPrimitivesForSAWCore.Num_rect (fun (m1 : @Num) => forall (n : @Num), forall (a : Type), @seq m1 (@seq n a) -> @seq (@tcMul m1 n) a) (fun (m1 : @SAWCoreScaffolding.Nat) => @finNumRec (fun (n : @Num) => forall (a : Type), @SAWCoreVectorsAsCoqVectors.Vec m1 (@seq n a) -> @seq (@tcMul (@TCNum m1) n) a) (fun (n : @SAWCoreScaffolding.Nat) (a : Type) => @SAWCorePrelude.join m1 n a)) (@finNumRec (fun (n : @Num) => forall (a : Type), @SAWCorePrelude.Stream (@seq n a) -> @seq (@tcMul (@TCInf) n) a) (fun (n : @SAWCoreScaffolding.Nat) (a : Type) => @SAWCorePrelude.natCase (fun (n' : @SAWCoreScaffolding.Nat) => @SAWCorePrelude.Stream (@SAWCoreVectorsAsCoqVectors.Vec n' a) -> @seq (@SAWCorePrelude.if0Nat (@Num) n' (@TCNum 0) (@TCInf)) a) (fun (s : @SAWCorePrelude.Stream (@SAWCoreVectorsAsCoqVectors.Vec 0 a)) => @SAWCoreVectorsAsCoqVectors.EmptyVec a) (fun (n' : @SAWCoreScaffolding.Nat) (s : @SAWCorePrelude.Stream (@SAWCoreVectorsAsCoqVectors.Vec (@SAWCoreScaffolding.Succ n') a)) => @SAWCorePrelude.streamJoin a n' s) n)) m. + +Definition ecSplit : forall (m : @Num), forall (n : @Num), forall (a : Type), @seq (@tcMul m n) a -> @seq m (@seq n a) := + fun (m : @Num) => CryptolPrimitivesForSAWCore.Num_rect (fun (m1 : @Num) => forall (n : @Num), forall (a : Type), @seq (@tcMul m1 n) a -> @seq m1 (@seq n a)) (fun (m1 : @SAWCoreScaffolding.Nat) => @finNumRec (fun (n : @Num) => forall (a : Type), @seq (@tcMul (@TCNum m1) n) a -> @SAWCoreVectorsAsCoqVectors.Vec m1 (@seq n a)) (fun (n : @SAWCoreScaffolding.Nat) (a : Type) => @SAWCorePrelude.split m1 n a)) (@finNumRec (fun (n : @Num) => forall (a : Type), @seq (@tcMul (@TCInf) n) a -> @SAWCorePrelude.Stream (@seq n a)) (fun (n : @SAWCoreScaffolding.Nat) (a : Type) => @SAWCorePrelude.natCase (fun (n' : @SAWCoreScaffolding.Nat) => @seq (@SAWCorePrelude.if0Nat (@Num) n' (@TCNum 0) (@TCInf)) a -> @SAWCorePrelude.Stream (@SAWCoreVectorsAsCoqVectors.Vec n' a)) (@SAWCorePrelude.streamConst (@SAWCoreVectorsAsCoqVectors.Vec 0 a)) (fun (n' : @SAWCoreScaffolding.Nat) => @SAWCorePrelude.streamSplit a (@SAWCoreScaffolding.Succ n')) n)) m. + +Definition ecReverse : forall (n : @Num), forall (a : Type), @seq n a -> @seq n a := + @finNumRec (fun (n : @Num) => forall (a : Type), @seq n a -> @seq n a) reverse. + +Definition ecTranspose : forall (m : @Num), forall (n : @Num), forall (a : Type), @seq m (@seq n a) -> @seq n (@seq m a) := + fun (m : @Num) (n : @Num) (a : Type) => CryptolPrimitivesForSAWCore.Num_rect (fun (m1 : @Num) => @seq m1 (@seq n a) -> @seq n (@seq m1 a)) (fun (m1 : @SAWCoreScaffolding.Nat) => CryptolPrimitivesForSAWCore.Num_rect (fun (n1 : @Num) => @SAWCoreVectorsAsCoqVectors.Vec m1 (@seq n1 a) -> @seq n1 (@SAWCoreVectorsAsCoqVectors.Vec m1 a)) (fun (n1 : @SAWCoreScaffolding.Nat) => @SAWCorePrelude.transpose m1 n1 a) (fun (xss : @SAWCoreVectorsAsCoqVectors.Vec m1 (@SAWCorePrelude.Stream a)) => @SAWCorePrelude.MkStream (@SAWCoreVectorsAsCoqVectors.Vec m1 a) (fun (i : @SAWCoreScaffolding.Nat) => @SAWCoreVectorsAsCoqVectors.gen m1 a (fun (j : @SAWCoreScaffolding.Nat) => @SAWCorePrelude.streamGet a (@SAWCorePrelude.sawAt m1 (@SAWCorePrelude.Stream a) xss j) i))) n) (CryptolPrimitivesForSAWCore.Num_rect (fun (n1 : @Num) => @SAWCorePrelude.Stream (@seq n1 a) -> @seq n1 (@SAWCorePrelude.Stream a)) (fun (n1 : @SAWCoreScaffolding.Nat) (xss : @SAWCorePrelude.Stream (@SAWCoreVectorsAsCoqVectors.Vec n1 a)) => @SAWCoreVectorsAsCoqVectors.gen n1 (@SAWCorePrelude.Stream a) (fun (i : @SAWCoreScaffolding.Nat) => @SAWCorePrelude.MkStream a (fun (j : @SAWCoreScaffolding.Nat) => @SAWCorePrelude.sawAt n1 a (@SAWCorePrelude.streamGet (@SAWCoreVectorsAsCoqVectors.Vec n1 a) xss j) i))) (fun (xss : @SAWCorePrelude.Stream (@SAWCorePrelude.Stream a)) => @SAWCorePrelude.MkStream (@SAWCorePrelude.Stream a) (fun (i : @SAWCoreScaffolding.Nat) => @SAWCorePrelude.MkStream a (fun (j : @SAWCoreScaffolding.Nat) => @SAWCorePrelude.streamGet a (@SAWCorePrelude.streamGet (@SAWCorePrelude.Stream a) xss j) i))) n) m. + +Definition ecAt : forall (n : @Num), forall (a : Type), forall (ix : Type), @PIntegral ix -> @seq n a -> ix -> a := + fun (n : @Num) => CryptolPrimitivesForSAWCore.Num_rect (fun (n1 : @Num) => forall (a : Type), forall (ix : Type), @PIntegral ix -> @seq n1 a -> ix -> a) (fun (n1 : @SAWCoreScaffolding.Nat) (a : Type) (ix : Type) (pix : RecordTypeCons "div" (ix -> ix -> ix) (RecordTypeCons "integralRing" (RecordTypeCons "add" (ix -> ix -> ix) (RecordTypeCons "int" (@SAWCoreScaffolding.Integer -> ix) (RecordTypeCons "mul" (ix -> ix -> ix) (RecordTypeCons "neg" (ix -> ix) (RecordTypeCons "ringZero" ix (RecordTypeCons "sub" (ix -> ix -> ix) RecordTypeNil)))))) (RecordTypeCons "mod" (ix -> ix -> ix) (RecordTypeCons "posNegCases" (forall (r : Type), (@SAWCoreScaffolding.Nat -> r) -> (@SAWCoreScaffolding.Nat -> r) -> ix -> r) (RecordTypeCons "toInt" (ix -> @SAWCoreScaffolding.Integer) RecordTypeNil))))) (xs : @SAWCoreVectorsAsCoqVectors.Vec n1 a) => RecordProj pix "posNegCases" a (@SAWCorePrelude.sawAt n1 a xs) (fun (_1 : @SAWCoreScaffolding.Nat) => @SAWCorePrelude.sawAt n1 a xs 0)) (fun (a : Type) (ix : Type) (pix : RecordTypeCons "div" (ix -> ix -> ix) (RecordTypeCons "integralRing" (RecordTypeCons "add" (ix -> ix -> ix) (RecordTypeCons "int" (@SAWCoreScaffolding.Integer -> ix) (RecordTypeCons "mul" (ix -> ix -> ix) (RecordTypeCons "neg" (ix -> ix) (RecordTypeCons "ringZero" ix (RecordTypeCons "sub" (ix -> ix -> ix) RecordTypeNil)))))) (RecordTypeCons "mod" (ix -> ix -> ix) (RecordTypeCons "posNegCases" (forall (r : Type), (@SAWCoreScaffolding.Nat -> r) -> (@SAWCoreScaffolding.Nat -> r) -> ix -> r) (RecordTypeCons "toInt" (ix -> @SAWCoreScaffolding.Integer) RecordTypeNil))))) (xs : @SAWCorePrelude.Stream a) => RecordProj pix "posNegCases" a (@SAWCorePrelude.streamGet a xs) (fun (_1 : @SAWCoreScaffolding.Nat) => @SAWCorePrelude.streamGet a xs 0)) n. + +Definition ecAtBack : forall (n : @Num), forall (a : Type), forall (ix : Type), @PIntegral ix -> @seq n a -> ix -> a := + fun (n : @Num) (a : Type) (ix : Type) (pix : RecordTypeCons "div" (ix -> ix -> ix) (RecordTypeCons "integralRing" (RecordTypeCons "add" (ix -> ix -> ix) (RecordTypeCons "int" (@SAWCoreScaffolding.Integer -> ix) (RecordTypeCons "mul" (ix -> ix -> ix) (RecordTypeCons "neg" (ix -> ix) (RecordTypeCons "ringZero" ix (RecordTypeCons "sub" (ix -> ix -> ix) RecordTypeNil)))))) (RecordTypeCons "mod" (ix -> ix -> ix) (RecordTypeCons "posNegCases" (forall (r : Type), (@SAWCoreScaffolding.Nat -> r) -> (@SAWCoreScaffolding.Nat -> r) -> ix -> r) (RecordTypeCons "toInt" (ix -> @SAWCoreScaffolding.Integer) RecordTypeNil))))) (xs : CryptolPrimitivesForSAWCore.Num_rect (fun (num : @Num) => Type) (fun (n1 : @SAWCoreScaffolding.Nat) => @SAWCoreVectorsAsCoqVectors.Vec n1 a) (@SAWCorePrelude.Stream a) n) => @ecAt n a ix pix (@ecReverse n a xs). + +Definition ecFromTo : forall (first : @Num), forall (last : @Num), forall (a : Type), @PLiteral a -> @PLiteral a -> @seq (@tcAdd (@TCNum 1) (@tcSub last first)) a := + @finNumRec (fun (first : @Num) => forall (last : @Num), forall (a : Type), @PLiteral a -> @PLiteral a -> @seq (@tcAdd (@TCNum 1) (@tcSub last first)) a) (fun (first : @SAWCoreScaffolding.Nat) => @finNumRec (fun (last : @Num) => forall (a : Type), @PLiteral a -> @PLiteral a -> @seq (@tcAdd (@TCNum 1) (@tcSub last (@TCNum first))) a) (fun (last : @SAWCoreScaffolding.Nat) (a : Type) (pa : @SAWCoreScaffolding.Nat -> a) (_1 : @SAWCoreScaffolding.Nat -> a) => @SAWCoreVectorsAsCoqVectors.gen (@SAWCorePrelude.addNat 1 (@SAWCorePrelude.subNat last first)) a (fun (i : @SAWCoreScaffolding.Nat) => pa (@SAWCorePrelude.addNat i first)))). + +Definition ecFromToLessThan : forall (first : @Num), forall (bound : @Num), forall (a : Type), @PLiteralLessThan a -> @seq (@tcSub bound first) a := + fun (first : @Num) (bound : @Num) (a : Type) => @finNumRec (fun (first1 : @Num) => @PLiteralLessThan a -> @seq (@tcSub bound first1) a) (fun (first1 : @SAWCoreScaffolding.Nat) => CryptolPrimitivesForSAWCore.Num_rect (fun (bound1 : @Num) => @PLiteralLessThan a -> @seq (@tcSub bound1 (@TCNum first1)) a) (fun (bound1 : @SAWCoreScaffolding.Nat) (pa : @SAWCoreScaffolding.Nat -> a) => @SAWCoreVectorsAsCoqVectors.gen (@SAWCorePrelude.subNat bound1 first1) a (fun (i : @SAWCoreScaffolding.Nat) => pa (@SAWCorePrelude.addNat i first1))) (fun (pa : @SAWCoreScaffolding.Nat -> a) => @SAWCorePrelude.MkStream a (fun (i : @SAWCoreScaffolding.Nat) => pa (@SAWCorePrelude.addNat i first1))) bound) first. + +Definition ecFromThenTo : forall (first : @Num), forall (next : @Num), forall (last : @Num), forall (a : Type), forall (len : @Num), @PLiteral a -> @PLiteral a -> @PLiteral a -> @seq len a := + fun (first : @Num) (next : @Num) (_1 : @Num) (a : Type) => @finNumRec (fun (len : @Num) => @PLiteral a -> @PLiteral a -> @PLiteral a -> @seq len a) (fun (len : @SAWCoreScaffolding.Nat) (pa : @SAWCoreScaffolding.Nat -> a) (_2 : @SAWCoreScaffolding.Nat -> a) (_3 : @SAWCoreScaffolding.Nat -> a) => @SAWCoreVectorsAsCoqVectors.gen len a (fun (i : @SAWCoreScaffolding.Nat) => pa (@SAWCorePrelude.subNat (@SAWCorePrelude.addNat (@getFinNat first) (@SAWCorePrelude.mulNat i (@getFinNat next))) (@SAWCorePrelude.mulNat i (@getFinNat first))))). + +Definition ecInfFrom : forall (a : Type), @PIntegral a -> a -> @seq (@TCInf) a := + fun (a : Type) (pa : RecordTypeCons "div" (a -> a -> a) (RecordTypeCons "integralRing" (RecordTypeCons "add" (a -> a -> a) (RecordTypeCons "int" (@SAWCoreScaffolding.Integer -> a) (RecordTypeCons "mul" (a -> a -> a) (RecordTypeCons "neg" (a -> a) (RecordTypeCons "ringZero" a (RecordTypeCons "sub" (a -> a -> a) RecordTypeNil)))))) (RecordTypeCons "mod" (a -> a -> a) (RecordTypeCons "posNegCases" (forall (r : Type), (@SAWCoreScaffolding.Nat -> r) -> (@SAWCoreScaffolding.Nat -> r) -> a -> r) (RecordTypeCons "toInt" (a -> @SAWCoreScaffolding.Integer) RecordTypeNil))))) (x : a) => @SAWCorePrelude.MkStream a (fun (i : @SAWCoreScaffolding.Nat) => RecordProj (RecordProj pa "integralRing") "add" x (RecordProj (RecordProj pa "integralRing") "int" (@SAWCoreScaffolding.natToInt i))). + +Definition ecInfFromThen : forall (a : Type), @PIntegral a -> a -> a -> @seq (@TCInf) a := + fun (a : Type) (pa : RecordTypeCons "div" (a -> a -> a) (RecordTypeCons "integralRing" (RecordTypeCons "add" (a -> a -> a) (RecordTypeCons "int" (@SAWCoreScaffolding.Integer -> a) (RecordTypeCons "mul" (a -> a -> a) (RecordTypeCons "neg" (a -> a) (RecordTypeCons "ringZero" a (RecordTypeCons "sub" (a -> a -> a) RecordTypeNil)))))) (RecordTypeCons "mod" (a -> a -> a) (RecordTypeCons "posNegCases" (forall (r : Type), (@SAWCoreScaffolding.Nat -> r) -> (@SAWCoreScaffolding.Nat -> r) -> a -> r) (RecordTypeCons "toInt" (a -> @SAWCoreScaffolding.Integer) RecordTypeNil))))) (x : a) (y : a) => @SAWCorePrelude.MkStream a (fun (i : @SAWCoreScaffolding.Nat) => RecordProj (RecordProj pa "integralRing") "add" x (RecordProj (RecordProj pa "integralRing") "mul" (RecordProj (RecordProj pa "integralRing") "sub" y x) (RecordProj (RecordProj pa "integralRing") "int" (@SAWCoreScaffolding.natToInt i)))). + +Definition ecError : forall (a : Type), forall (len : @Num), @seq len (@SAWCoreVectorsAsCoqVectors.Vec 8 (@SAWCoreScaffolding.Bool)) -> a := + fun (a : Type) (len : @Num) (msg : CryptolPrimitivesForSAWCore.Num_rect (fun (num : @Num) => Type) (fun (n : @SAWCoreScaffolding.Nat) => @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreVectorsAsCoqVectors.Vec 8 (@SAWCoreScaffolding.Bool))) (@SAWCorePrelude.Stream (@SAWCoreVectorsAsCoqVectors.Vec 8 (@SAWCoreScaffolding.Bool))) len) => @SAWCoreScaffolding.error a "encountered call to the Cryptol 'error' function"%string. + +Definition ecRandom : forall (a : Type), @SAWCoreVectorsAsCoqVectors.Vec 32 (@SAWCoreScaffolding.Bool) -> a := + fun (a : Type) (_1 : @SAWCoreVectorsAsCoqVectors.Vec 32 (@SAWCoreScaffolding.Bool)) => @SAWCoreScaffolding.error a "Cryptol.random"%string. + +Definition ecTrace : forall (n : @Num), forall (a : Type), forall (b : Type), @seq n (@SAWCoreVectorsAsCoqVectors.Vec 8 (@SAWCoreScaffolding.Bool)) -> a -> b -> b := + fun (_1 : @Num) (_2 : Type) (_3 : Type) (_4 : CryptolPrimitivesForSAWCore.Num_rect (fun (num : @Num) => Type) (fun (n : @SAWCoreScaffolding.Nat) => @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreVectorsAsCoqVectors.Vec 8 (@SAWCoreScaffolding.Bool))) (@SAWCorePrelude.Stream (@SAWCoreVectorsAsCoqVectors.Vec 8 (@SAWCoreScaffolding.Bool))) _1) (_5 : _2) (x : _3) => x. + +Definition ecDeepseq : forall (a : Type), forall (b : Type), @PEq a -> a -> b -> b := + fun (a : Type) (b : Type) (pa : RecordTypeCons "eq" (a -> a -> @SAWCoreScaffolding.Bool) RecordTypeNil) (x : a) (y : b) => y. + +Definition ecParmap : forall (a : Type), forall (b : Type), forall (n : @Num), @PEq b -> (a -> b) -> @seq n a -> @seq n b := + fun (a : Type) (b : Type) (n : @Num) (pb : RecordTypeCons "eq" (b -> b -> @SAWCoreScaffolding.Bool) RecordTypeNil) => CryptolPrimitivesForSAWCore.Num_rect (fun (n1 : @Num) => (a -> b) -> @seq n1 a -> @seq n1 b) (fun (n1 : @SAWCoreScaffolding.Nat) (f : a -> b) (xs : @SAWCoreVectorsAsCoqVectors.Vec n1 a) => @SAWCorePrelude.map a b f n1 xs) (fun (f : a -> b) (xs : @SAWCorePrelude.Stream a) => @SAWCoreScaffolding.error (@SAWCorePrelude.Stream b) "Unexpected infinite stream in parmap"%string) n. + +Definition ecFoldl : forall (n : @Num), forall (a : Type), forall (b : Type), (a -> b -> a) -> a -> @seq n b -> a := + fun (n : @Num) (a : Type) (b : Type) (f : a -> b -> a) (z : a) => CryptolPrimitivesForSAWCore.Num_rect (fun (n1 : @Num) => @seq n1 b -> a) (fun (n1 : @SAWCoreScaffolding.Nat) (xs : @SAWCoreVectorsAsCoqVectors.Vec n1 b) => @SAWCoreVectorsAsCoqVectors.foldr b a n1 (fun (y : b) (x : a) => f x y) z (@SAWCorePrelude.reverse n1 b xs)) (fun (xs : @SAWCorePrelude.Stream b) => @SAWCoreScaffolding.error a "Unexpected infinite stream in foldl"%string) n. + +Definition ecFoldlPrime : forall (n : @Num), forall (a : Type), forall (b : Type), @PEq a -> (a -> b -> a) -> a -> @seq n b -> a := + fun (n : @Num) (a : Type) (b : Type) (pa : RecordTypeCons "eq" (a -> a -> @SAWCoreScaffolding.Bool) RecordTypeNil) => @ecFoldl n a b. + +Definition TCFloat : @Num -> @Num -> Type := + fun (_1 : @Num) (_2 : @Num) => unit. + +Definition PEqFloat : forall (e : @Num), forall (p : @Num), @PEq (@TCFloat e p) := + fun (e : @Num) (p : @Num) => RecordCons "eq" (fun (x : unit) (y : unit) => @SAWCoreScaffolding.error (@SAWCoreScaffolding.Bool) "Unimplemented: (==) Float"%string) RecordNil. + +Definition PCmpFloat : forall (e : @Num), forall (p : @Num), @PCmp (@TCFloat e p) := + fun (e : @Num) (p : @Num) => RecordCons "cmp" (fun (x : unit) (y : unit) (k : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.error (@SAWCoreScaffolding.Bool) "Unimplemented: Cmp Float"%string) (RecordCons "cmpEq" (@PEqFloat e p) RecordNil). + +Definition PZeroFloat : forall (e : @Num), forall (p : @Num), @PZero (@TCFloat e p) := + fun (e : @Num) (p : @Num) => @SAWCoreScaffolding.error (@TCFloat e p) "Unimplemented: Zero Float"%string. + +Definition PRingFloat : forall (e : @Num), forall (p : @Num), @PRing (@TCFloat e p) := + fun (e : @Num) (p : @Num) => RecordCons "add" (fun (x : unit) (y : unit) => @SAWCoreScaffolding.error (@TCFloat e p) "Unimplemented: (+) Float"%string) (RecordCons "int" (fun (i : @SAWCoreScaffolding.Integer) => @SAWCoreScaffolding.error (@TCFloat e p) "Unimplemented: toInteger Float"%string) (RecordCons "mul" (fun (x : unit) (y : unit) => @SAWCoreScaffolding.error (@TCFloat e p) "Unimplemented: (*) Float"%string) (RecordCons "neg" (fun (x : unit) => @SAWCoreScaffolding.error (@TCFloat e p) "Unimplemented: neg Float"%string) (RecordCons "ringZero" (@PZeroFloat e p) (RecordCons "sub" (fun (x : unit) (y : unit) => @SAWCoreScaffolding.error (@TCFloat e p) "Unimplemented: (-) Float"%string) RecordNil))))). + +Definition PFieldFloat : forall (e : @Num), forall (p : @Num), @PField (@TCFloat e p) := + fun (e : @Num) (p : @Num) => RecordCons "fieldDiv" (fun (x : unit) (y : unit) => @SAWCoreScaffolding.error (@TCFloat e p) "Unimplemented: (/.) Float"%string) (RecordCons "fieldRing" (@PRingFloat e p) (RecordCons "recip" (fun (x : unit) => @SAWCoreScaffolding.error (@TCFloat e p) "Unimplemented: recip Float"%string) RecordNil)). + +Definition PRoundFloat : forall (e : @Num), forall (p : @Num), @PRound (@TCFloat e p) := + fun (e : @Num) (p : @Num) => RecordCons "ceiling" (fun (x : unit) => @SAWCoreScaffolding.error (@SAWCoreScaffolding.Integer) "Unimplemented: ceiling Float"%string) (RecordCons "floor" (fun (x : unit) => @SAWCoreScaffolding.error (@SAWCoreScaffolding.Integer) "Unimplemented: floor Float"%string) (RecordCons "roundAway" (fun (x : unit) => @SAWCoreScaffolding.error (@SAWCoreScaffolding.Integer) "Unimplemented: roundAway Float"%string) (RecordCons "roundCmp" (@PCmpFloat e p) (RecordCons "roundField" (@PFieldFloat e p) (RecordCons "roundToEven" (fun (x : unit) => @SAWCoreScaffolding.error (@SAWCoreScaffolding.Integer) "Unimplemented: roundToEven Float"%string) (RecordCons "trunc" (fun (x : unit) => @SAWCoreScaffolding.error (@SAWCoreScaffolding.Integer) "Unimplemented: trunc Float"%string) RecordNil)))))). + +Definition PLiteralFloat : forall (e : @Num), forall (p : @Num), @PLiteral (@TCFloat e p) := + fun (e : @Num) (p : @Num) (x : @SAWCoreScaffolding.Nat) => @SAWCoreScaffolding.error (@TCFloat e p) "Unimplemented: Literal Float"%string. + +Definition ecFpNaN : forall (e : @Num), forall (p : @Num), @TCFloat e p := + fun (e : @Num) (p : @Num) => @SAWCoreScaffolding.error (@TCFloat e p) "Unimplemented: fpNaN"%string. + +Definition ecFpPosInf : forall (e : @Num), forall (p : @Num), @TCFloat e p := + fun (e : @Num) (p : @Num) => @SAWCoreScaffolding.error (@TCFloat e p) "Unimplemented: fpPosInf"%string. + +Definition ecFpFromBits : forall (e : @Num), forall (p : @Num), @seq (@tcAdd e p) (@SAWCoreScaffolding.Bool) -> @TCFloat e p := + fun (e : @Num) (p : @Num) (_1 : CryptolPrimitivesForSAWCore.Num_rect (fun (num : @Num) => Type) (fun (n : @SAWCoreScaffolding.Nat) => @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool)) (@SAWCorePrelude.Stream (@SAWCoreScaffolding.Bool)) (CryptolPrimitivesForSAWCore.Num_rect (fun (num1' : @Num) => @Num) (fun (n1 : @SAWCoreScaffolding.Nat) => CryptolPrimitivesForSAWCore.Num_rect (fun (num2' : @Num) => @Num) (fun (n2 : @SAWCoreScaffolding.Nat) => @TCNum (@SAWCorePrelude.addNat n1 n2)) ((fun (x : @SAWCoreScaffolding.Nat) => @TCInf) n1) p) (CryptolPrimitivesForSAWCore.Num_rect (fun (num2' : @Num) => @Num) (fun (y : @SAWCoreScaffolding.Nat) => @TCInf) (@TCInf) p) e)) => @SAWCoreScaffolding.error (@TCFloat e p) "Unimplemented: fpFromBits"%string. + +Definition ecFpToBits : forall (e : @Num), forall (p : @Num), @TCFloat e p -> @seq (@tcAdd e p) (@SAWCoreScaffolding.Bool) := + fun (e : @Num) (p : @Num) (_1 : unit) => @SAWCoreScaffolding.error (@seq (@tcAdd e p) (@SAWCoreScaffolding.Bool)) "Unimplemented: fpToBits"%string. + +Definition ecFpEq : forall (e : @Num), forall (p : @Num), @TCFloat e p -> @TCFloat e p -> @SAWCoreScaffolding.Bool := + fun (e : @Num) (p : @Num) (_1 : unit) (_2 : unit) => @SAWCoreScaffolding.error (@SAWCoreScaffolding.Bool) "Unimplemented: =.="%string. + +Definition ecFpAdd : forall (e : @Num), forall (p : @Num), @SAWCoreVectorsAsCoqVectors.Vec 3 (@SAWCoreScaffolding.Bool) -> @TCFloat e p -> @TCFloat e p -> @TCFloat e p := + fun (e : @Num) (p : @Num) (_1 : @SAWCoreVectorsAsCoqVectors.Vec 3 (@SAWCoreScaffolding.Bool)) (_2 : unit) (_3 : unit) => @SAWCoreScaffolding.error (@TCFloat e p) "Unimplemented: fpAdd"%string. + +Definition ecFpSub : forall (e : @Num), forall (p : @Num), @SAWCoreVectorsAsCoqVectors.Vec 3 (@SAWCoreScaffolding.Bool) -> @TCFloat e p -> @TCFloat e p -> @TCFloat e p := + fun (e : @Num) (p : @Num) (_1 : @SAWCoreVectorsAsCoqVectors.Vec 3 (@SAWCoreScaffolding.Bool)) (_2 : unit) (_3 : unit) => @SAWCoreScaffolding.error (@TCFloat e p) "Unimplemented: fpSub"%string. + +Definition ecFpMul : forall (e : @Num), forall (p : @Num), @SAWCoreVectorsAsCoqVectors.Vec 3 (@SAWCoreScaffolding.Bool) -> @TCFloat e p -> @TCFloat e p -> @TCFloat e p := + fun (e : @Num) (p : @Num) (_1 : @SAWCoreVectorsAsCoqVectors.Vec 3 (@SAWCoreScaffolding.Bool)) (_2 : unit) (_3 : unit) => @SAWCoreScaffolding.error (@TCFloat e p) "Unimplemented: fpMul"%string. + +Definition ecFpDiv : forall (e : @Num), forall (p : @Num), @SAWCoreVectorsAsCoqVectors.Vec 3 (@SAWCoreScaffolding.Bool) -> @TCFloat e p -> @TCFloat e p -> @TCFloat e p := + fun (e : @Num) (p : @Num) (_1 : @SAWCoreVectorsAsCoqVectors.Vec 3 (@SAWCoreScaffolding.Bool)) (_2 : unit) (_3 : unit) => @SAWCoreScaffolding.error (@TCFloat e p) "Unimplemented: fpDiv"%string. + +Definition ecFpToRational : forall (e : @Num), forall (p : @Num), @TCFloat e p -> Rational := + fun (e : @Num) (p : @Num) (_1 : unit) => @SAWCoreScaffolding.error Rational "Unimplemented: fpToRational"%string. + +Definition ecFpFromRational : forall (e : @Num), forall (p : @Num), @SAWCoreVectorsAsCoqVectors.Vec 3 (@SAWCoreScaffolding.Bool) -> Rational -> @TCFloat e p := + fun (e : @Num) (p : @Num) (_1 : @SAWCoreVectorsAsCoqVectors.Vec 3 (@SAWCoreScaffolding.Bool)) (_2 : unit) => @SAWCoreScaffolding.error (@TCFloat e p) "Unimplemented: fpFromRational"%string. + +Definition fpIsNaN : forall (e : @Num), forall (p : @Num), @TCFloat e p -> @SAWCoreScaffolding.Bool := + fun (e : @Num) (p : @Num) (x : unit) => @SAWCoreScaffolding.error (@SAWCoreScaffolding.Bool) "Unimplemented: fpIsNaN"%string. + +Definition fpIsInf : forall (e : @Num), forall (p : @Num), @TCFloat e p -> @SAWCoreScaffolding.Bool := + fun (e : @Num) (p : @Num) (x : unit) => @SAWCoreScaffolding.error (@SAWCoreScaffolding.Bool) "Unimplemented: fpIsInf"%string. + +Definition fpIsZero : forall (e : @Num), forall (p : @Num), @TCFloat e p -> @SAWCoreScaffolding.Bool := + fun (e : @Num) (p : @Num) (x : unit) => @SAWCoreScaffolding.error (@SAWCoreScaffolding.Bool) "Unimplemented: fpIsZero"%string. + +Definition fpIsNeg : forall (e : @Num), forall (p : @Num), @TCFloat e p -> @SAWCoreScaffolding.Bool := + fun (e : @Num) (p : @Num) (x : unit) => @SAWCoreScaffolding.error (@SAWCoreScaffolding.Bool) "Unimplemented: fpIsNeg"%string. + +Definition fpIsNormal : forall (e : @Num), forall (p : @Num), @TCFloat e p -> @SAWCoreScaffolding.Bool := + fun (e : @Num) (p : @Num) (x : unit) => @SAWCoreScaffolding.error (@SAWCoreScaffolding.Bool) "Unimplemented: fpIsNormal"%string. + +Definition fpIsSubnormal : forall (e : @Num), forall (p : @Num), @TCFloat e p -> @SAWCoreScaffolding.Bool := + fun (e : @Num) (p : @Num) (x : unit) => @SAWCoreScaffolding.error (@SAWCoreScaffolding.Bool) "Unimplemented: fpIsSubnormal"%string. + +Definition fpFMA : forall (e : @Num), forall (p : @Num), @SAWCoreVectorsAsCoqVectors.Vec 3 (@SAWCoreScaffolding.Bool) -> @TCFloat e p -> @TCFloat e p -> @TCFloat e p -> @TCFloat e p := + fun (e : @Num) (p : @Num) (r : @SAWCoreVectorsAsCoqVectors.Vec 3 (@SAWCoreScaffolding.Bool)) (x : unit) (y : unit) (z : unit) => @SAWCoreScaffolding.error (@TCFloat e p) "Unimplemented: fpFMA"%string. + +Definition fpAbs : forall (e : @Num), forall (p : @Num), @TCFloat e p -> @TCFloat e p := + fun (e : @Num) (p : @Num) (x : unit) => @SAWCoreScaffolding.error (@TCFloat e p) "Unimplemented: fpAbs"%string. + +Definition fpSqrt : forall (e : @Num), forall (p : @Num), @SAWCoreVectorsAsCoqVectors.Vec 3 (@SAWCoreScaffolding.Bool) -> @TCFloat e p -> @TCFloat e p := + fun (e : @Num) (p : @Num) (r : @SAWCoreVectorsAsCoqVectors.Vec 3 (@SAWCoreScaffolding.Bool)) (x : unit) => @SAWCoreScaffolding.error (@TCFloat e p) "Unimplemented: fpSqrt"%string. + +Definition ecUpdate : forall (n : @Num), forall (a : Type), forall (ix : Type), @PIntegral ix -> @seq n a -> ix -> a -> @seq n a := + fun (n : @Num) => CryptolPrimitivesForSAWCore.Num_rect (fun (n1 : @Num) => forall (a : Type), forall (ix : Type), @PIntegral ix -> @seq n1 a -> ix -> a -> @seq n1 a) (fun (n1 : @SAWCoreScaffolding.Nat) (a : Type) (ix : Type) (pix : RecordTypeCons "div" (ix -> ix -> ix) (RecordTypeCons "integralRing" (RecordTypeCons "add" (ix -> ix -> ix) (RecordTypeCons "int" (@SAWCoreScaffolding.Integer -> ix) (RecordTypeCons "mul" (ix -> ix -> ix) (RecordTypeCons "neg" (ix -> ix) (RecordTypeCons "ringZero" ix (RecordTypeCons "sub" (ix -> ix -> ix) RecordTypeNil)))))) (RecordTypeCons "mod" (ix -> ix -> ix) (RecordTypeCons "posNegCases" (forall (r : Type), (@SAWCoreScaffolding.Nat -> r) -> (@SAWCoreScaffolding.Nat -> r) -> ix -> r) (RecordTypeCons "toInt" (ix -> @SAWCoreScaffolding.Integer) RecordTypeNil))))) (xs : @SAWCoreVectorsAsCoqVectors.Vec n1 a) => RecordProj pix "posNegCases" (a -> @SAWCoreVectorsAsCoqVectors.Vec n1 a) (@SAWCorePrelude.upd n1 a xs) (fun (_1 : @SAWCoreScaffolding.Nat) (_2 : a) => xs)) (fun (a : Type) (ix : Type) (pix : RecordTypeCons "div" (ix -> ix -> ix) (RecordTypeCons "integralRing" (RecordTypeCons "add" (ix -> ix -> ix) (RecordTypeCons "int" (@SAWCoreScaffolding.Integer -> ix) (RecordTypeCons "mul" (ix -> ix -> ix) (RecordTypeCons "neg" (ix -> ix) (RecordTypeCons "ringZero" ix (RecordTypeCons "sub" (ix -> ix -> ix) RecordTypeNil)))))) (RecordTypeCons "mod" (ix -> ix -> ix) (RecordTypeCons "posNegCases" (forall (r : Type), (@SAWCoreScaffolding.Nat -> r) -> (@SAWCoreScaffolding.Nat -> r) -> ix -> r) (RecordTypeCons "toInt" (ix -> @SAWCoreScaffolding.Integer) RecordTypeNil))))) (xs : @SAWCorePrelude.Stream a) => RecordProj pix "posNegCases" (a -> @SAWCorePrelude.Stream a) (@SAWCorePrelude.streamUpd a xs) (fun (_1 : @SAWCoreScaffolding.Nat) (_2 : a) => xs)) n. + +Definition ecUpdateEnd : forall (n : @Num), forall (a : Type), forall (ix : Type), @PIntegral ix -> @seq n a -> ix -> a -> @seq n a := + @finNumRec (fun (n : @Num) => forall (a : Type), forall (ix : Type), @PIntegral ix -> @seq n a -> ix -> a -> @seq n a) (fun (n : @SAWCoreScaffolding.Nat) (a : Type) (ix : Type) (pix : RecordTypeCons "div" (ix -> ix -> ix) (RecordTypeCons "integralRing" (RecordTypeCons "add" (ix -> ix -> ix) (RecordTypeCons "int" (@SAWCoreScaffolding.Integer -> ix) (RecordTypeCons "mul" (ix -> ix -> ix) (RecordTypeCons "neg" (ix -> ix) (RecordTypeCons "ringZero" ix (RecordTypeCons "sub" (ix -> ix -> ix) RecordTypeNil)))))) (RecordTypeCons "mod" (ix -> ix -> ix) (RecordTypeCons "posNegCases" (forall (r : Type), (@SAWCoreScaffolding.Nat -> r) -> (@SAWCoreScaffolding.Nat -> r) -> ix -> r) (RecordTypeCons "toInt" (ix -> @SAWCoreScaffolding.Integer) RecordTypeNil))))) (xs : @SAWCoreVectorsAsCoqVectors.Vec n a) => RecordProj pix "posNegCases" (a -> @SAWCoreVectorsAsCoqVectors.Vec n a) (fun (i : @SAWCoreScaffolding.Nat) => @SAWCorePrelude.upd n a xs (@SAWCorePrelude.subNat (@SAWCorePrelude.subNat n 1) i)) (fun (_1 : @SAWCoreScaffolding.Nat) (_2 : a) => xs)). + +Definition ecTrunc : forall (m : @Num), forall (n : @Num), @seq (@tcAdd m n) (@SAWCoreScaffolding.Bool) -> @seq n (@SAWCoreScaffolding.Bool) := + @finNumRec2 (fun (m : @Num) (n : @Num) => @seq (@tcAdd m n) (@SAWCoreScaffolding.Bool) -> @seq n (@SAWCoreScaffolding.Bool)) bvTrunc. + +Definition ecUExt : forall (m : @Num), forall (n : @Num), @seq n (@SAWCoreScaffolding.Bool) -> @seq (@tcAdd m n) (@SAWCoreScaffolding.Bool) := + @finNumRec2 (fun (m : @Num) (n : @Num) => @seq n (@SAWCoreScaffolding.Bool) -> @seq (@tcAdd m n) (@SAWCoreScaffolding.Bool)) bvUExt. + +Definition ecSExt : forall (m : @Num), forall (n : @Num), @seq n (@SAWCoreScaffolding.Bool) -> @seq (@tcAdd m n) (@SAWCoreScaffolding.Bool) := + @finNumRec2 (fun (m : @Num) (n : @Num) => @seq n (@SAWCoreScaffolding.Bool) -> @seq (@tcAdd m n) (@SAWCoreScaffolding.Bool)) (fun (m : @SAWCoreScaffolding.Nat) (n : @SAWCoreScaffolding.Nat) => @SAWCorePrelude.natCase (fun (n' : @SAWCoreScaffolding.Nat) => @SAWCoreVectorsAsCoqVectors.Vec n' (@SAWCoreScaffolding.Bool) -> @SAWCoreVectorsAsCoqVectors.Vec (@SAWCorePrelude.addNat m n') (@SAWCoreScaffolding.Bool)) (fun (_1 : @SAWCoreVectorsAsCoqVectors.Vec 0 (@SAWCoreScaffolding.Bool)) => @SAWCoreVectorsAsCoqVectors.bvNat (@SAWCorePrelude.addNat m 0) 0) (@SAWCorePrelude.bvSExt m) n). + +Definition ecSgt : forall (n : @Num), @seq n (@SAWCoreScaffolding.Bool) -> @seq n (@SAWCoreScaffolding.Bool) -> @SAWCoreScaffolding.Bool := + @finNumRec (fun (n : @Num) => @seq n (@SAWCoreScaffolding.Bool) -> @seq n (@SAWCoreScaffolding.Bool) -> @SAWCoreScaffolding.Bool) (@SAWCoreVectorsAsCoqVectors.bvsgt). + +Definition ecSge : forall (n : @Num), @seq n (@SAWCoreScaffolding.Bool) -> @seq n (@SAWCoreScaffolding.Bool) -> @SAWCoreScaffolding.Bool := + @finNumRec (fun (n : @Num) => @seq n (@SAWCoreScaffolding.Bool) -> @seq n (@SAWCoreScaffolding.Bool) -> @SAWCoreScaffolding.Bool) (@SAWCoreVectorsAsCoqVectors.bvsge). + +Definition ecSlt : forall (n : @Num), @seq n (@SAWCoreScaffolding.Bool) -> @seq n (@SAWCoreScaffolding.Bool) -> @SAWCoreScaffolding.Bool := + @finNumRec (fun (n : @Num) => @seq n (@SAWCoreScaffolding.Bool) -> @seq n (@SAWCoreScaffolding.Bool) -> @SAWCoreScaffolding.Bool) (@SAWCoreVectorsAsCoqVectors.bvslt). + +Definition ecSle : forall (n : @Num), @seq n (@SAWCoreScaffolding.Bool) -> @seq n (@SAWCoreScaffolding.Bool) -> @SAWCoreScaffolding.Bool := + @finNumRec (fun (n : @Num) => @seq n (@SAWCoreScaffolding.Bool) -> @seq n (@SAWCoreScaffolding.Bool) -> @SAWCoreScaffolding.Bool) (@SAWCoreVectorsAsCoqVectors.bvsle). + +Definition ecArrayConstant : forall (a : Type), forall (b : Type), b -> @SAWCorePrelude.Array a b := + @SAWCorePrelude.arrayConstant. + +Definition ecArrayLookup : forall (a : Type), forall (b : Type), @SAWCorePrelude.Array a b -> a -> b := + @SAWCorePrelude.arrayLookup. + +Definition ecArrayUpdate : forall (a : Type), forall (b : Type), @SAWCorePrelude.Array a b -> a -> b -> @SAWCorePrelude.Array a b := + @SAWCorePrelude.arrayUpdate. + +Axiom replicate_False : forall (n : @SAWCoreScaffolding.Nat), @SAWCoreScaffolding.Eq (@SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool)) (@SAWCorePrelude.replicate n (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.false)) (@SAWCoreVectorsAsCoqVectors.bvNat n 0) . + +Axiom subNat_0 : forall (n : @SAWCoreScaffolding.Nat), @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Nat) (@SAWCorePrelude.subNat n 0) n . + +End CryptolPrimitivesForSAWCore. diff --git a/saw-core-coq/coq/generated/CryptolToCoq/SAWCorePrelude.v b/saw-core-coq/coq/generated/CryptolToCoq/SAWCorePrelude.v new file mode 100644 index 0000000000..e39533684c --- /dev/null +++ b/saw-core-coq/coq/generated/CryptolToCoq/SAWCorePrelude.v @@ -0,0 +1,933 @@ + +(** Mandatory imports from saw-core-coq *) +From Coq Require Import Lists.List. +From Coq Require Import String. +From Coq Require Import Vectors.Vector. +From CryptolToCoq Require Import SAWCoreScaffolding. +From CryptolToCoq Require Import SAWCoreVectorsAsCoqVectors. +Import ListNotations. + +(** Post-preamble section specified by you *) + + +(** Code generated by saw-core-coq *) + +Module SAWCorePrelude. + +(* Prelude.id was skipped *) + +(* Prelude.fix was skipped *) + +(* Prelude.UnitType was skipped *) + +(* Prelude.UnitType__rec was skipped *) + +(* Prelude.PairType was skipped *) + +Definition pair_example : forall (a : Type), forall (b : Type), a -> b -> @SAWCoreScaffolding.PairType a b := + fun (a : Type) (b : Type) (x : a) (y : b) => @SAWCoreScaffolding.PairValue a b x y. + +(* Prelude.Pair__rec was skipped *) + +Definition Pair_fst : forall (a : Type), forall (b : Type), @SAWCoreScaffolding.PairType a b -> a := + fun (a : Type) (b : Type) => @SAWCoreScaffolding.Pair__rec a b (fun (p : @SAWCoreScaffolding.PairType a b) => a) (fun (x : a) (y : b) => x). + +Definition Pair_snd : forall (a : Type), forall (b : Type), @SAWCoreScaffolding.PairType a b -> b := + fun (a : Type) (b : Type) => @SAWCoreScaffolding.Pair__rec a b (fun (p : @SAWCoreScaffolding.PairType a b) => b) (fun (x : a) (y : b) => y). + +(* Prelude.fst was skipped *) + +(* Prelude.snd was skipped *) + +Definition uncurry : forall (a : Type), forall (b : Type), forall (c : Type), forall (f : a -> b -> c), prod a b -> c := + fun (a : Type) (b : Type) (c : Type) (f : a -> b -> c) (x : prod a b) => f (SAWCoreScaffolding.fst x) (SAWCoreScaffolding.snd x). + +(* Prelude.String was skipped *) + +(* Prelude.error was skipped *) + +(* Prelude.EmptyType was skipped *) + +(* Prelude.EmptyType__rec was skipped *) + +(* Prelude.RecordType was skipped *) + +(* Prelude.RecordType__rec was skipped *) + +(* Prelude.Eq was skipped *) + +(* Prelude.Eq__rec was skipped *) + +Definition eq_cong : forall (t : Type), forall (x : t), forall (y : t), @SAWCoreScaffolding.Eq t x y -> forall (u : Type), forall (f : t -> u), @SAWCoreScaffolding.Eq u (f x) (f y) := + fun (t : Type) (x : t) (y : t) (eq : @SAWCoreScaffolding.Eq t x y) (u : Type) (f : t -> u) => @SAWCoreScaffolding.Eq__rec t x (fun (y' : t) (eq' : @SAWCoreScaffolding.Eq t x y') => @SAWCoreScaffolding.Eq u (f x) (f y')) (@SAWCoreScaffolding.Refl u (f x)) y eq. + +Definition sym : forall (a : Type), forall (x : a), forall (y : a), @SAWCoreScaffolding.Eq a x y -> @SAWCoreScaffolding.Eq a y x := + fun (a : Type) (x : a) (y : a) (eq : @SAWCoreScaffolding.Eq a x y) => @SAWCoreScaffolding.Eq__rec a x (fun (y' : a) (eq' : @SAWCoreScaffolding.Eq a x y') => @SAWCoreScaffolding.Eq a y' x) (@SAWCoreScaffolding.Refl a x) y eq. + +Definition trans : forall (a : Type), forall (x : a), forall (y : a), forall (z : a), @SAWCoreScaffolding.Eq a x y -> @SAWCoreScaffolding.Eq a y z -> @SAWCoreScaffolding.Eq a x z := + fun (a : Type) (x : a) (y : a) (z : a) (eq1 : @SAWCoreScaffolding.Eq a x y) (eq2 : @SAWCoreScaffolding.Eq a y z) => @SAWCoreScaffolding.Eq__rec a y (fun (y' : a) (eq' : @SAWCoreScaffolding.Eq a y y') => @SAWCoreScaffolding.Eq a x y') eq1 z eq2. + +Definition trans2 : forall (a : Type), forall (x : a), forall (y : a), forall (z : a), @SAWCoreScaffolding.Eq a x z -> @SAWCoreScaffolding.Eq a y z -> @SAWCoreScaffolding.Eq a x y := + fun (a : Type) (x : a) (y : a) (z : a) (eq1 : @SAWCoreScaffolding.Eq a x z) (eq2 : @SAWCoreScaffolding.Eq a y z) => @trans a x z y eq1 (@sym a y z eq2). + +Definition trans4 : forall (a : Type), forall (w : a), forall (x : a), forall (y : a), forall (z : a), @SAWCoreScaffolding.Eq a w x -> @SAWCoreScaffolding.Eq a x y -> @SAWCoreScaffolding.Eq a y z -> @SAWCoreScaffolding.Eq a w z := + fun (a : Type) (w : a) (x : a) (y : a) (z : a) (eq1 : @SAWCoreScaffolding.Eq a w x) (eq2 : @SAWCoreScaffolding.Eq a x y) (eq3 : @SAWCoreScaffolding.Eq a y z) => @trans a w x z eq1 (@trans a x y z eq2 eq3). + +Definition eq_inv_map : forall (a : Type), forall (b : Type), forall (a1 : a), forall (a2 : a), @SAWCoreScaffolding.Eq a a1 a2 -> forall (f1 : a -> b), forall (f2 : a -> b), @SAWCoreScaffolding.Eq b (f1 a2) (f2 a2) -> @SAWCoreScaffolding.Eq b (f1 a1) (f2 a1) := + fun (a : Type) (b : Type) (a1 : a) (a2 : a) (eq_a : @SAWCoreScaffolding.Eq a a1 a2) (f1 : a -> b) (f2 : a -> b) (eq_f : @SAWCoreScaffolding.Eq b (f1 a2) (f2 a2)) => @trans b (f1 a1) (f1 a2) (f2 a1) (@eq_cong a a1 a2 eq_a b f1) (@trans b (f1 a2) (f2 a2) (f2 a1) eq_f (@eq_cong a a2 a1 (@sym a a1 a2 eq_a) b f2)). + +(* Prelude.unsafeAssert was skipped *) + +(* Prelude.coerce was skipped *) + +(* Prelude.coerce__def was skipped *) + +(* Prelude.coerce__eq was skipped *) + +(* Prelude.rcoerce was skipped *) + +(* Prelude.unsafeCoerce was skipped *) + +(* Prelude.unsafeCoerce_same was skipped *) + +Definition piCong0 : forall (r : Type), forall (x : Type), forall (y : Type), @SAWCoreScaffolding.Eq Type x y -> @SAWCoreScaffolding.Eq Type (x -> r) (y -> r) := + fun (r : Type) (x : Type) (y : Type) (eq : @SAWCoreScaffolding.Eq Type x y) => @SAWCoreScaffolding.Eq__rec Type x (fun (y' : Type) (eq' : @SAWCoreScaffolding.Eq Type x y') => @SAWCoreScaffolding.Eq Type (x -> r) (y' -> r)) (@SAWCoreScaffolding.Refl Type (x -> r)) y eq. + +Definition piCong1 : forall (r : Type), forall (x : Type), forall (y : Type), @SAWCoreScaffolding.Eq Type x y -> @SAWCoreScaffolding.Eq Type (r -> x) (r -> y) := + fun (r : Type) (x : Type) (y : Type) (eq : @SAWCoreScaffolding.Eq Type x y) => @SAWCoreScaffolding.Eq__rec Type x (fun (y' : Type) (eq' : @SAWCoreScaffolding.Eq Type x y') => @SAWCoreScaffolding.Eq Type (r -> x) (r -> y')) (@SAWCoreScaffolding.Refl Type (r -> x)) y eq. + +Inductive Bit : Type := +| Bit1 : @Bit +| Bit0 : @Bit +. + +Definition Bit__rec : forall (p : @Bit -> Type), p (@Bit1) -> p (@Bit0) -> forall (b : @Bit), p b := + fun (p : @Bit -> Type) (f1 : p (@Bit1)) (f2 : p (@Bit0)) (b : @Bit) => SAWCorePrelude.Bit_rect p f1 f2 b. + +(* Prelude.Bool was skipped *) + +(* Prelude.True was skipped *) + +(* Prelude.False was skipped *) + +(* Prelude.iteDep was skipped *) + +(* Prelude.iteDep_True was skipped *) + +(* Prelude.iteDep_False was skipped *) + +(* Prelude.ite was skipped *) + +(* Prelude.ite_eq_iteDep was skipped *) + +Definition ite_true : forall (a : Type), forall (x : a), forall (y : a), @SAWCoreScaffolding.Eq a (if @SAWCoreScaffolding.true then x else y) x := + fun (a : Type) (x : a) (y : a) => @trans a (if @SAWCoreScaffolding.true then x else y) (@SAWCoreScaffolding.iteDep (fun (b : @SAWCoreScaffolding.Bool) => a) (@SAWCoreScaffolding.true) x y) x (@SAWCoreScaffolding.ite_eq_iteDep a (@SAWCoreScaffolding.true) x y) (@SAWCoreScaffolding.iteDep_True (fun (_1 : @SAWCoreScaffolding.Bool) => a) x y). + +Definition ite_false : forall (a : Type), forall (x : a), forall (y : a), @SAWCoreScaffolding.Eq a (if @SAWCoreScaffolding.false then x else y) y := + fun (a : Type) (x : a) (y : a) => @trans a (if @SAWCoreScaffolding.false then x else y) (@SAWCoreScaffolding.iteDep (fun (b : @SAWCoreScaffolding.Bool) => a) (@SAWCoreScaffolding.false) x y) y (@SAWCoreScaffolding.ite_eq_iteDep a (@SAWCoreScaffolding.false) x y) (@SAWCoreScaffolding.iteDep_False (fun (_1 : @SAWCoreScaffolding.Bool) => a) x y). + +Definition bool2bit : @SAWCoreScaffolding.Bool -> @Bit := + fun (b : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.iteDep (fun (_1 : @SAWCoreScaffolding.Bool) => @Bit) b (@Bit1) (@Bit0). + +Definition bool2bit_True : @SAWCoreScaffolding.Eq (@Bit) (@bool2bit (@SAWCoreScaffolding.true)) (@Bit1) := + @SAWCoreScaffolding.iteDep_True (fun (_1 : @SAWCoreScaffolding.Bool) => @Bit) (@Bit1) (@Bit0). + +Definition bool2bit_False : @SAWCoreScaffolding.Eq (@Bit) (@bool2bit (@SAWCoreScaffolding.false)) (@Bit0) := + @SAWCoreScaffolding.iteDep_False (fun (_1 : @SAWCoreScaffolding.Bool) => @Bit) (@Bit1) (@Bit0). + +Definition bit2bool : @Bit -> @SAWCoreScaffolding.Bool := + @Bit__rec (fun (_1 : @Bit) => @SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.true) (@SAWCoreScaffolding.false). + +Definition bit2bool_Bit1 : @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (@bit2bool (@Bit1)) (@SAWCoreScaffolding.true) := + @SAWCoreScaffolding.Refl (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.true). + +Definition bit2bool_Bit0 : @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (@bit2bool (@Bit0)) (@SAWCoreScaffolding.false) := + @SAWCoreScaffolding.Refl (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.false). + +(* Prelude.not was skipped *) + +(* Prelude.not__eq was skipped *) + +(* Prelude.and was skipped *) + +(* Prelude.and__eq was skipped *) + +(* Prelude.or was skipped *) + +(* Prelude.or__eq was skipped *) + +(* Prelude.xor was skipped *) + +(* Prelude.xor__eq was skipped *) + +(* Prelude.boolEq was skipped *) + +(* Prelude.boolEq__eq was skipped *) + +Definition implies : @SAWCoreScaffolding.Bool -> @SAWCoreScaffolding.Bool -> @SAWCoreScaffolding.Bool := + fun (a : @SAWCoreScaffolding.Bool) (b : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.or (@SAWCoreScaffolding.not a) b. + +Definition implies__eq : forall (a : @SAWCoreScaffolding.Bool), forall (b : @SAWCoreScaffolding.Bool), @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (@implies a b) (@SAWCoreScaffolding.or (@SAWCoreScaffolding.not a) b) := + fun (a : @SAWCoreScaffolding.Bool) (b : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.Refl (@SAWCoreScaffolding.Bool) (@implies a b). + +Definition unitEq : @SAWCoreScaffolding.UnitType -> @SAWCoreScaffolding.UnitType -> @SAWCoreScaffolding.Bool := + fun (_1 : @SAWCoreScaffolding.UnitType) (_2 : @SAWCoreScaffolding.UnitType) => @SAWCoreScaffolding.true. + +Definition pairEq : forall (a : Type), forall (b : Type), (a -> a -> @SAWCoreScaffolding.Bool) -> (b -> b -> @SAWCoreScaffolding.Bool) -> prod a b -> prod a b -> @SAWCoreScaffolding.Bool := + fun (a : Type) (b : Type) (f : a -> a -> @SAWCoreScaffolding.Bool) (g : b -> b -> @SAWCoreScaffolding.Bool) (x : prod a b) (y : prod a b) => @SAWCoreScaffolding.and (f (SAWCoreScaffolding.fst x) (SAWCoreScaffolding.fst y)) (g (SAWCoreScaffolding.snd x) (SAWCoreScaffolding.snd y)). + +Definition not_True : @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.not (@SAWCoreScaffolding.true)) (@SAWCoreScaffolding.false) := + @trans (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.not (@SAWCoreScaffolding.true)) (if @SAWCoreScaffolding.true then @SAWCoreScaffolding.false else @SAWCoreScaffolding.true) (@SAWCoreScaffolding.false) (@SAWCoreScaffolding.not__eq (@SAWCoreScaffolding.true)) (@ite_true (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.false) (@SAWCoreScaffolding.true)). + +Definition not_False : @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.not (@SAWCoreScaffolding.false)) (@SAWCoreScaffolding.true) := + @trans (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.not (@SAWCoreScaffolding.false)) (if @SAWCoreScaffolding.false then @SAWCoreScaffolding.false else @SAWCoreScaffolding.true) (@SAWCoreScaffolding.true) (@SAWCoreScaffolding.not__eq (@SAWCoreScaffolding.false)) (@ite_false (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.false) (@SAWCoreScaffolding.true)). + +Definition not_not : forall (x : @SAWCoreScaffolding.Bool), let var__0 := @SAWCoreScaffolding.Bool -> @SAWCoreScaffolding.Bool in + @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.not (@SAWCoreScaffolding.not x)) x := + fun (x : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.iteDep (fun (b : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.not (@SAWCoreScaffolding.not b)) b) x (@trans (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.not (@SAWCoreScaffolding.not (@SAWCoreScaffolding.true))) (@SAWCoreScaffolding.not (@SAWCoreScaffolding.false)) (@SAWCoreScaffolding.true) (@eq_cong (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.not (@SAWCoreScaffolding.true)) (@SAWCoreScaffolding.false) not_True (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.not)) not_False) (@trans (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.not (@SAWCoreScaffolding.not (@SAWCoreScaffolding.false))) (@SAWCoreScaffolding.not (@SAWCoreScaffolding.true)) (@SAWCoreScaffolding.false) (@eq_cong (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.not (@SAWCoreScaffolding.false)) (@SAWCoreScaffolding.true) not_False (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.not)) not_True). + +Definition and_True1 : forall (x : @SAWCoreScaffolding.Bool), @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.and (@SAWCoreScaffolding.true) x) x := + fun (x : @SAWCoreScaffolding.Bool) => @trans (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.and (@SAWCoreScaffolding.true) x) (if @SAWCoreScaffolding.true then x else @SAWCoreScaffolding.false) x (@SAWCoreScaffolding.and__eq (@SAWCoreScaffolding.true) x) (@ite_true (@SAWCoreScaffolding.Bool) x (@SAWCoreScaffolding.false)). + +Definition and_False1 : forall (x : @SAWCoreScaffolding.Bool), @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.and (@SAWCoreScaffolding.false) x) (@SAWCoreScaffolding.false) := + fun (x : @SAWCoreScaffolding.Bool) => @trans (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.and (@SAWCoreScaffolding.false) x) (if @SAWCoreScaffolding.false then x else @SAWCoreScaffolding.false) (@SAWCoreScaffolding.false) (@SAWCoreScaffolding.and__eq (@SAWCoreScaffolding.false) x) (@ite_false (@SAWCoreScaffolding.Bool) x (@SAWCoreScaffolding.false)). + +Definition and_True2 : forall (x : @SAWCoreScaffolding.Bool), @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.and x (@SAWCoreScaffolding.true)) x := + fun (x : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.iteDep (fun (b : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.and b (@SAWCoreScaffolding.true)) b) x (@and_True1 (@SAWCoreScaffolding.true)) (@and_False1 (@SAWCoreScaffolding.true)). + +Definition and_False2 : forall (x : @SAWCoreScaffolding.Bool), @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.and x (@SAWCoreScaffolding.false)) (@SAWCoreScaffolding.false) := + fun (x : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.iteDep (fun (b : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.and b (@SAWCoreScaffolding.false)) (@SAWCoreScaffolding.false)) x (@and_True1 (@SAWCoreScaffolding.false)) (@and_False1 (@SAWCoreScaffolding.false)). + +Definition and_assoc : forall (x : @SAWCoreScaffolding.Bool), forall (y : @SAWCoreScaffolding.Bool), forall (z : @SAWCoreScaffolding.Bool), let var__0 := @SAWCoreScaffolding.Bool -> @SAWCoreScaffolding.Bool -> @SAWCoreScaffolding.Bool in + @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.and x (@SAWCoreScaffolding.and y z)) (@SAWCoreScaffolding.and (@SAWCoreScaffolding.and x y) z) := + fun (x : @SAWCoreScaffolding.Bool) (y : @SAWCoreScaffolding.Bool) (z : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.iteDep (fun (b : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.and x (@SAWCoreScaffolding.and y b)) (@SAWCoreScaffolding.and (@SAWCoreScaffolding.and x y) b)) z (@trans2 (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.and x (@SAWCoreScaffolding.and y (@SAWCoreScaffolding.true))) (@SAWCoreScaffolding.and (@SAWCoreScaffolding.and x y) (@SAWCoreScaffolding.true)) (@SAWCoreScaffolding.and x y) (@eq_cong (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.and y (@SAWCoreScaffolding.true)) y (@and_True2 y) (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.and x)) (@and_True2 (@SAWCoreScaffolding.and x y))) (@trans2 (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.and x (@SAWCoreScaffolding.and y (@SAWCoreScaffolding.false))) (@SAWCoreScaffolding.and (@SAWCoreScaffolding.and x y) (@SAWCoreScaffolding.false)) (@SAWCoreScaffolding.false) (@trans (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.and x (@SAWCoreScaffolding.and y (@SAWCoreScaffolding.false))) (@SAWCoreScaffolding.and x (@SAWCoreScaffolding.false)) (@SAWCoreScaffolding.false) (@eq_cong (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.and y (@SAWCoreScaffolding.false)) (@SAWCoreScaffolding.false) (@and_False2 y) (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.and x)) (@and_False2 x)) (@and_False2 (@SAWCoreScaffolding.and x y))). + +Definition and_idem : forall (x : @SAWCoreScaffolding.Bool), @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.and x x) x := + fun (x : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.iteDep (fun (b : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.and b b) b) x (@and_True1 (@SAWCoreScaffolding.true)) (@and_False1 (@SAWCoreScaffolding.false)). + +Definition or_True1 : forall (x : @SAWCoreScaffolding.Bool), @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.or (@SAWCoreScaffolding.true) x) (@SAWCoreScaffolding.true) := + fun (x : @SAWCoreScaffolding.Bool) => @trans (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.or (@SAWCoreScaffolding.true) x) (if @SAWCoreScaffolding.true then @SAWCoreScaffolding.true else x) (@SAWCoreScaffolding.true) (@SAWCoreScaffolding.or__eq (@SAWCoreScaffolding.true) x) (@ite_true (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.true) x). + +Definition or_False1 : forall (x : @SAWCoreScaffolding.Bool), @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.or (@SAWCoreScaffolding.false) x) x := + fun (x : @SAWCoreScaffolding.Bool) => @trans (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.or (@SAWCoreScaffolding.false) x) (if @SAWCoreScaffolding.false then @SAWCoreScaffolding.true else x) x (@SAWCoreScaffolding.or__eq (@SAWCoreScaffolding.false) x) (@ite_false (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.true) x). + +Definition or_True2 : forall (x : @SAWCoreScaffolding.Bool), @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.or x (@SAWCoreScaffolding.true)) (@SAWCoreScaffolding.true) := + fun (x : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.iteDep (fun (b : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.or b (@SAWCoreScaffolding.true)) (@SAWCoreScaffolding.true)) x (@or_True1 (@SAWCoreScaffolding.true)) (@or_False1 (@SAWCoreScaffolding.true)). + +Definition or_False2 : forall (x : @SAWCoreScaffolding.Bool), @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.or x (@SAWCoreScaffolding.false)) x := + fun (x : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.iteDep (fun (b : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.or b (@SAWCoreScaffolding.false)) b) x (@or_True1 (@SAWCoreScaffolding.false)) (@or_False1 (@SAWCoreScaffolding.false)). + +Definition or_assoc : forall (x : @SAWCoreScaffolding.Bool), forall (y : @SAWCoreScaffolding.Bool), forall (z : @SAWCoreScaffolding.Bool), let var__0 := @SAWCoreScaffolding.Bool -> @SAWCoreScaffolding.Bool -> @SAWCoreScaffolding.Bool in + @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.or x (@SAWCoreScaffolding.or y z)) (@SAWCoreScaffolding.or (@SAWCoreScaffolding.or x y) z) := + fun (x : @SAWCoreScaffolding.Bool) (y : @SAWCoreScaffolding.Bool) (z : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.iteDep (fun (b : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.or x (@SAWCoreScaffolding.or y b)) (@SAWCoreScaffolding.or (@SAWCoreScaffolding.or x y) b)) z (@trans2 (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.or x (@SAWCoreScaffolding.or y (@SAWCoreScaffolding.true))) (@SAWCoreScaffolding.or (@SAWCoreScaffolding.or x y) (@SAWCoreScaffolding.true)) (@SAWCoreScaffolding.true) (@trans (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.or x (@SAWCoreScaffolding.or y (@SAWCoreScaffolding.true))) (@SAWCoreScaffolding.or x (@SAWCoreScaffolding.true)) (@SAWCoreScaffolding.true) (@eq_cong (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.or y (@SAWCoreScaffolding.true)) (@SAWCoreScaffolding.true) (@or_True2 y) (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.or x)) (@or_True2 x)) (@or_True2 (@SAWCoreScaffolding.or x y))) (@trans2 (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.or x (@SAWCoreScaffolding.or y (@SAWCoreScaffolding.false))) (@SAWCoreScaffolding.or (@SAWCoreScaffolding.or x y) (@SAWCoreScaffolding.false)) (@SAWCoreScaffolding.or x y) (@eq_cong (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.or y (@SAWCoreScaffolding.false)) y (@or_False2 y) (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.or x)) (@or_False2 (@SAWCoreScaffolding.or x y))). + +Definition or_idem : forall (x : @SAWCoreScaffolding.Bool), @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.or x x) x := + fun (x : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.iteDep (fun (b : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.or b b) b) x (@or_True1 (@SAWCoreScaffolding.true)) (@or_False1 (@SAWCoreScaffolding.false)). + +Definition implies_True1 : forall (x : @SAWCoreScaffolding.Bool), @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (@implies (@SAWCoreScaffolding.true) x) x := + fun (x : @SAWCoreScaffolding.Bool) => @trans (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.or (@SAWCoreScaffolding.not (@SAWCoreScaffolding.true)) x) (@SAWCoreScaffolding.or (@SAWCoreScaffolding.false) x) x (@eq_cong (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.not (@SAWCoreScaffolding.true)) (@SAWCoreScaffolding.false) not_True (@SAWCoreScaffolding.Bool) (fun (y : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.or y x)) (@or_False1 x). + +Definition implies_False1 : forall (x : @SAWCoreScaffolding.Bool), @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (@implies (@SAWCoreScaffolding.false) x) (@SAWCoreScaffolding.true) := + fun (x : @SAWCoreScaffolding.Bool) => @trans (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.or (@SAWCoreScaffolding.not (@SAWCoreScaffolding.false)) x) (@SAWCoreScaffolding.or (@SAWCoreScaffolding.true) x) (@SAWCoreScaffolding.true) (@eq_cong (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.not (@SAWCoreScaffolding.false)) (@SAWCoreScaffolding.true) not_False (@SAWCoreScaffolding.Bool) (fun (y : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.or y x)) (@or_True1 x). + +Definition true_implies : forall (x : @SAWCoreScaffolding.Bool), @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (@implies (@SAWCoreScaffolding.true) x) x := + fun (x : @SAWCoreScaffolding.Bool) => @implies_True1 x. + +Definition xor_True1 : forall (x : @SAWCoreScaffolding.Bool), @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.xor (@SAWCoreScaffolding.true) x) (@SAWCoreScaffolding.not x) := + fun (x : @SAWCoreScaffolding.Bool) => @trans (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.xor (@SAWCoreScaffolding.true) x) (if @SAWCoreScaffolding.true then @SAWCoreScaffolding.not x else x) (@SAWCoreScaffolding.not x) (@SAWCoreScaffolding.xor__eq (@SAWCoreScaffolding.true) x) (@ite_true (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.not x) x). + +Definition xor_False1 : forall (x : @SAWCoreScaffolding.Bool), @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.xor (@SAWCoreScaffolding.false) x) x := + fun (x : @SAWCoreScaffolding.Bool) => @trans (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.xor (@SAWCoreScaffolding.false) x) (if @SAWCoreScaffolding.false then @SAWCoreScaffolding.not x else x) x (@SAWCoreScaffolding.xor__eq (@SAWCoreScaffolding.false) x) (@ite_false (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.not x) x). + +Definition xor_False2 : forall (x : @SAWCoreScaffolding.Bool), @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.xor x (@SAWCoreScaffolding.false)) x := + fun (x : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.iteDep (fun (b : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.xor b (@SAWCoreScaffolding.false)) b) x (@trans (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.xor (@SAWCoreScaffolding.true) (@SAWCoreScaffolding.false)) (@SAWCoreScaffolding.not (@SAWCoreScaffolding.false)) (@SAWCoreScaffolding.true) (@xor_True1 (@SAWCoreScaffolding.false)) not_False) (@xor_False1 (@SAWCoreScaffolding.false)). + +Definition xor_True2 : forall (x : @SAWCoreScaffolding.Bool), @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.xor x (@SAWCoreScaffolding.true)) (@SAWCoreScaffolding.not x) := + fun (x : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.iteDep (fun (b : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.xor b (@SAWCoreScaffolding.true)) (@SAWCoreScaffolding.not b)) x (@xor_True1 (@SAWCoreScaffolding.true)) (@trans2 (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.xor (@SAWCoreScaffolding.false) (@SAWCoreScaffolding.true)) (@SAWCoreScaffolding.not (@SAWCoreScaffolding.false)) (@SAWCoreScaffolding.true) (@xor_False1 (@SAWCoreScaffolding.true)) not_False). + +Definition xor_same : forall (x : @SAWCoreScaffolding.Bool), @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.xor x x) (@SAWCoreScaffolding.false) := + fun (x : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.iteDep (fun (b : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.xor b b) (@SAWCoreScaffolding.false)) x (@trans (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.xor (@SAWCoreScaffolding.true) (@SAWCoreScaffolding.true)) (@SAWCoreScaffolding.not (@SAWCoreScaffolding.true)) (@SAWCoreScaffolding.false) (@xor_True1 (@SAWCoreScaffolding.true)) not_True) (@xor_False1 (@SAWCoreScaffolding.false)). + +Definition boolEq_True1 : forall (x : @SAWCoreScaffolding.Bool), @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.boolEq (@SAWCoreScaffolding.true) x) x := + fun (x : @SAWCoreScaffolding.Bool) => @trans (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.boolEq (@SAWCoreScaffolding.true) x) (if @SAWCoreScaffolding.true then x else @SAWCoreScaffolding.not x) x (@SAWCoreScaffolding.boolEq__eq (@SAWCoreScaffolding.true) x) (@ite_true (@SAWCoreScaffolding.Bool) x (@SAWCoreScaffolding.not x)). + +Definition boolEq_False1 : forall (x : @SAWCoreScaffolding.Bool), @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.boolEq (@SAWCoreScaffolding.false) x) (@SAWCoreScaffolding.not x) := + fun (x : @SAWCoreScaffolding.Bool) => @trans (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.boolEq (@SAWCoreScaffolding.false) x) (if @SAWCoreScaffolding.false then x else @SAWCoreScaffolding.not x) (@SAWCoreScaffolding.not x) (@SAWCoreScaffolding.boolEq__eq (@SAWCoreScaffolding.false) x) (@ite_false (@SAWCoreScaffolding.Bool) x (@SAWCoreScaffolding.not x)). + +Definition boolEq_True2 : forall (x : @SAWCoreScaffolding.Bool), @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.boolEq x (@SAWCoreScaffolding.true)) x := + fun (x : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.iteDep (fun (b : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.boolEq b (@SAWCoreScaffolding.true)) b) x (@boolEq_True1 (@SAWCoreScaffolding.true)) (@trans (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.boolEq (@SAWCoreScaffolding.false) (@SAWCoreScaffolding.true)) (@SAWCoreScaffolding.not (@SAWCoreScaffolding.true)) (@SAWCoreScaffolding.false) (@boolEq_False1 (@SAWCoreScaffolding.true)) not_True). + +Definition boolEq_False2 : forall (x : @SAWCoreScaffolding.Bool), @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.boolEq x (@SAWCoreScaffolding.false)) (@SAWCoreScaffolding.not x) := + fun (x : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.iteDep (fun (b : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.boolEq b (@SAWCoreScaffolding.false)) (@SAWCoreScaffolding.not b)) x (@trans2 (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.boolEq (@SAWCoreScaffolding.true) (@SAWCoreScaffolding.false)) (@SAWCoreScaffolding.not (@SAWCoreScaffolding.true)) (@SAWCoreScaffolding.false) (@boolEq_True1 (@SAWCoreScaffolding.false)) not_True) (@boolEq_False1 (@SAWCoreScaffolding.false)). + +Definition boolEq_same : forall (x : @SAWCoreScaffolding.Bool), @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.boolEq x x) (@SAWCoreScaffolding.true) := + fun (x : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.iteDep (fun (b : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.boolEq b b) (@SAWCoreScaffolding.true)) x (@boolEq_True1 (@SAWCoreScaffolding.true)) (@trans (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.boolEq (@SAWCoreScaffolding.false) (@SAWCoreScaffolding.false)) (@SAWCoreScaffolding.not (@SAWCoreScaffolding.false)) (@SAWCoreScaffolding.true) (@boolEq_False1 (@SAWCoreScaffolding.false)) not_False). + +Definition not_or : forall (x : @SAWCoreScaffolding.Bool), forall (y : @SAWCoreScaffolding.Bool), let var__0 := @SAWCoreScaffolding.Bool -> @SAWCoreScaffolding.Bool in + let var__1 := @SAWCoreScaffolding.Bool -> @SAWCoreScaffolding.Bool -> @SAWCoreScaffolding.Bool in + @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.not (@SAWCoreScaffolding.or x y)) (@SAWCoreScaffolding.and (@SAWCoreScaffolding.not x) (@SAWCoreScaffolding.not y)) := + fun (x : @SAWCoreScaffolding.Bool) (y : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.iteDep (fun (b : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.not (@SAWCoreScaffolding.or b y)) (@SAWCoreScaffolding.and (@SAWCoreScaffolding.not b) (@SAWCoreScaffolding.not y))) x (@trans (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.not (@SAWCoreScaffolding.or (@SAWCoreScaffolding.true) y)) (@SAWCoreScaffolding.false) (@SAWCoreScaffolding.and (@SAWCoreScaffolding.not (@SAWCoreScaffolding.true)) (@SAWCoreScaffolding.not y)) (@trans (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.not (@SAWCoreScaffolding.or (@SAWCoreScaffolding.true) y)) (@SAWCoreScaffolding.not (@SAWCoreScaffolding.true)) (@SAWCoreScaffolding.false) (@eq_cong (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.or (@SAWCoreScaffolding.true) y) (@SAWCoreScaffolding.true) (@or_True1 y) (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.not)) not_True) (@trans (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.false) (@SAWCoreScaffolding.and (@SAWCoreScaffolding.false) (@SAWCoreScaffolding.not y)) (@SAWCoreScaffolding.and (@SAWCoreScaffolding.not (@SAWCoreScaffolding.true)) (@SAWCoreScaffolding.not y)) (@sym (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.and (@SAWCoreScaffolding.false) (@SAWCoreScaffolding.not y)) (@SAWCoreScaffolding.false) (@and_False1 (@SAWCoreScaffolding.not y))) (@eq_cong (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.false) (@SAWCoreScaffolding.not (@SAWCoreScaffolding.true)) (@sym (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.not (@SAWCoreScaffolding.true)) (@SAWCoreScaffolding.false) not_True) (@SAWCoreScaffolding.Bool) (fun (z : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.and z (@SAWCoreScaffolding.not y))))) (@trans (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.not (@SAWCoreScaffolding.or (@SAWCoreScaffolding.false) y)) (@SAWCoreScaffolding.not y) (@SAWCoreScaffolding.and (@SAWCoreScaffolding.not (@SAWCoreScaffolding.false)) (@SAWCoreScaffolding.not y)) (@eq_cong (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.or (@SAWCoreScaffolding.false) y) y (@or_False1 y) (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.not)) (@sym (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.and (@SAWCoreScaffolding.not (@SAWCoreScaffolding.false)) (@SAWCoreScaffolding.not y)) (@SAWCoreScaffolding.not y) (@trans (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.and (@SAWCoreScaffolding.not (@SAWCoreScaffolding.false)) (@SAWCoreScaffolding.not y)) (@SAWCoreScaffolding.and (@SAWCoreScaffolding.true) (@SAWCoreScaffolding.not y)) (@SAWCoreScaffolding.not y) (@eq_cong (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.not (@SAWCoreScaffolding.false)) (@SAWCoreScaffolding.true) not_False (@SAWCoreScaffolding.Bool) (fun (z : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.and z (@SAWCoreScaffolding.not y))) (@and_True1 (@SAWCoreScaffolding.not y))))). + +Definition not_and : forall (x : @SAWCoreScaffolding.Bool), forall (y : @SAWCoreScaffolding.Bool), let var__0 := @SAWCoreScaffolding.Bool -> @SAWCoreScaffolding.Bool in + let var__1 := @SAWCoreScaffolding.Bool -> @SAWCoreScaffolding.Bool -> @SAWCoreScaffolding.Bool in + @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.not (@SAWCoreScaffolding.and x y)) (@SAWCoreScaffolding.or (@SAWCoreScaffolding.not x) (@SAWCoreScaffolding.not y)) := + fun (x : @SAWCoreScaffolding.Bool) (y : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.iteDep (fun (b : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.not (@SAWCoreScaffolding.and b y)) (@SAWCoreScaffolding.or (@SAWCoreScaffolding.not b) (@SAWCoreScaffolding.not y))) x (@trans (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.not (@SAWCoreScaffolding.and (@SAWCoreScaffolding.true) y)) (@SAWCoreScaffolding.not y) (@SAWCoreScaffolding.or (@SAWCoreScaffolding.not (@SAWCoreScaffolding.true)) (@SAWCoreScaffolding.not y)) (@eq_cong (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.and (@SAWCoreScaffolding.true) y) y (@and_True1 y) (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.not)) (@sym (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.or (@SAWCoreScaffolding.not (@SAWCoreScaffolding.true)) (@SAWCoreScaffolding.not y)) (@SAWCoreScaffolding.not y) (@trans (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.or (@SAWCoreScaffolding.not (@SAWCoreScaffolding.true)) (@SAWCoreScaffolding.not y)) (@SAWCoreScaffolding.or (@SAWCoreScaffolding.false) (@SAWCoreScaffolding.not y)) (@SAWCoreScaffolding.not y) (@eq_cong (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.not (@SAWCoreScaffolding.true)) (@SAWCoreScaffolding.false) not_True (@SAWCoreScaffolding.Bool) (fun (z : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.or z (@SAWCoreScaffolding.not y))) (@or_False1 (@SAWCoreScaffolding.not y))))) (@trans (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.not (@SAWCoreScaffolding.and (@SAWCoreScaffolding.false) y)) (@SAWCoreScaffolding.true) (@SAWCoreScaffolding.or (@SAWCoreScaffolding.not (@SAWCoreScaffolding.false)) (@SAWCoreScaffolding.not y)) (@trans (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.not (@SAWCoreScaffolding.and (@SAWCoreScaffolding.false) y)) (@SAWCoreScaffolding.not (@SAWCoreScaffolding.false)) (@SAWCoreScaffolding.true) (@eq_cong (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.and (@SAWCoreScaffolding.false) y) (@SAWCoreScaffolding.false) (@and_False1 y) (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.not)) not_False) (@trans (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.true) (@SAWCoreScaffolding.or (@SAWCoreScaffolding.true) (@SAWCoreScaffolding.not y)) (@SAWCoreScaffolding.or (@SAWCoreScaffolding.not (@SAWCoreScaffolding.false)) (@SAWCoreScaffolding.not y)) (@sym (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.or (@SAWCoreScaffolding.true) (@SAWCoreScaffolding.not y)) (@SAWCoreScaffolding.true) (@or_True1 (@SAWCoreScaffolding.not y))) (@eq_cong (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.true) (@SAWCoreScaffolding.not (@SAWCoreScaffolding.false)) (@sym (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.not (@SAWCoreScaffolding.false)) (@SAWCoreScaffolding.true) not_False) (@SAWCoreScaffolding.Bool) (fun (z : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.or z (@SAWCoreScaffolding.not y))))). + +Definition ite_not : forall (a : Type), forall (b : @SAWCoreScaffolding.Bool), forall (x : a), forall (y : a), let var__0 := forall (a1 : Type), @SAWCoreScaffolding.Bool -> a1 -> a1 -> a1 in + @SAWCoreScaffolding.Eq a (if @SAWCoreScaffolding.not b then x else y) (if b then y else x) := + fun (a : Type) (b : @SAWCoreScaffolding.Bool) (x : a) (y : a) => @SAWCoreScaffolding.iteDep (fun (b' : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.Eq a (if @SAWCoreScaffolding.not b' then x else y) (if b' then y else x)) b (@trans a (if @SAWCoreScaffolding.not (@SAWCoreScaffolding.true) then x else y) y (if @SAWCoreScaffolding.true then y else x) (@trans a (if @SAWCoreScaffolding.not (@SAWCoreScaffolding.true) then x else y) (if @SAWCoreScaffolding.false then x else y) y (@eq_cong (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.not (@SAWCoreScaffolding.true)) (@SAWCoreScaffolding.false) not_True a (fun (z : @SAWCoreScaffolding.Bool) => if z then x else y)) (@ite_false a x y)) (@sym a (if @SAWCoreScaffolding.true then y else x) y (@ite_true a y x))) (@trans a (if @SAWCoreScaffolding.not (@SAWCoreScaffolding.false) then x else y) x (if @SAWCoreScaffolding.false then y else x) (@trans a (if @SAWCoreScaffolding.not (@SAWCoreScaffolding.false) then x else y) (if @SAWCoreScaffolding.true then x else y) x (@eq_cong (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.not (@SAWCoreScaffolding.false)) (@SAWCoreScaffolding.true) not_False a (fun (z : @SAWCoreScaffolding.Bool) => if z then x else y)) (@ite_true a x y)) (@sym a (if @SAWCoreScaffolding.false then y else x) x (@ite_false a y x))). + +Definition ite_nest1 : forall (a : Type), forall (b : @SAWCoreScaffolding.Bool), forall (x : a), forall (y : a), forall (z : a), let var__0 := forall (a1 : Type), @SAWCoreScaffolding.Bool -> a1 -> a1 -> a1 in + @SAWCoreScaffolding.Eq a (if b then if b then x else y else z) (if b then x else z) := + fun (a : Type) (b : @SAWCoreScaffolding.Bool) (x : a) (y : a) (z : a) => @SAWCoreScaffolding.iteDep (fun (b' : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.Eq a (if b' then if b' then x else y else z) (if b' then x else z)) b (@trans a (if @SAWCoreScaffolding.true then if @SAWCoreScaffolding.true then x else y else z) x (if @SAWCoreScaffolding.true then x else z) (@trans a (if @SAWCoreScaffolding.true then if @SAWCoreScaffolding.true then x else y else z) (if @SAWCoreScaffolding.true then x else y) x (@ite_true a (if @SAWCoreScaffolding.true then x else y) z) (@ite_true a x y)) (@sym a (if @SAWCoreScaffolding.true then x else z) x (@ite_true a x z))) (@trans a (if @SAWCoreScaffolding.false then if @SAWCoreScaffolding.false then x else y else z) z (if @SAWCoreScaffolding.false then x else z) (@ite_false a (if @SAWCoreScaffolding.false then x else y) z) (@sym a (if @SAWCoreScaffolding.false then x else z) z (@ite_false a x z))). + +Definition ite_nest2 : forall (a : Type), forall (b : @SAWCoreScaffolding.Bool), forall (x : a), forall (y : a), forall (z : a), let var__0 := forall (a1 : Type), @SAWCoreScaffolding.Bool -> a1 -> a1 -> a1 in + @SAWCoreScaffolding.Eq a (if b then x else if b then y else z) (if b then x else z) := + fun (a : Type) (b : @SAWCoreScaffolding.Bool) (x : a) (y : a) (z : a) => @SAWCoreScaffolding.iteDep (fun (b' : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.Eq a (if b' then x else if b' then y else z) (if b' then x else z)) b (@trans a (if @SAWCoreScaffolding.true then x else if @SAWCoreScaffolding.true then y else z) x (if @SAWCoreScaffolding.true then x else z) (@ite_true a x (if @SAWCoreScaffolding.true then y else z)) (@sym a (if @SAWCoreScaffolding.true then x else z) x (@ite_true a x z))) (@trans a (if @SAWCoreScaffolding.false then x else if @SAWCoreScaffolding.false then y else z) z (if @SAWCoreScaffolding.false then x else z) (@trans a (if @SAWCoreScaffolding.false then x else if @SAWCoreScaffolding.false then y else z) (if @SAWCoreScaffolding.false then y else z) z (@ite_false a x (if @SAWCoreScaffolding.false then y else z)) (@ite_false a y z)) (@sym a (if @SAWCoreScaffolding.false then x else z) z (@ite_false a x z))). + +(* Prelude.ite_bit was skipped *) + +Definition ite_bit_false_1 : forall (b : @SAWCoreScaffolding.Bool), forall (c : @SAWCoreScaffolding.Bool), @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (if b then @SAWCoreScaffolding.false else c) (@SAWCoreScaffolding.and (@SAWCoreScaffolding.not b) c) := + fun (b : @SAWCoreScaffolding.Bool) (c : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.iteDep (fun (b' : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (if b' then @SAWCoreScaffolding.false else c) (@SAWCoreScaffolding.and (@SAWCoreScaffolding.not b') c)) b (@trans (@SAWCoreScaffolding.Bool) (if @SAWCoreScaffolding.true then @SAWCoreScaffolding.false else c) (@SAWCoreScaffolding.false) (@SAWCoreScaffolding.and (@SAWCoreScaffolding.not (@SAWCoreScaffolding.true)) c) (@ite_true (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.false) c) (@sym (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.and (@SAWCoreScaffolding.not (@SAWCoreScaffolding.true)) c) (@SAWCoreScaffolding.false) (@trans (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.and (@SAWCoreScaffolding.not (@SAWCoreScaffolding.true)) c) (@SAWCoreScaffolding.and (@SAWCoreScaffolding.false) c) (@SAWCoreScaffolding.false) (@eq_cong (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.not (@SAWCoreScaffolding.true)) (@SAWCoreScaffolding.false) not_True (@SAWCoreScaffolding.Bool) (fun (z : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.and z c)) (@and_False1 c)))) (@trans (@SAWCoreScaffolding.Bool) (if @SAWCoreScaffolding.false then @SAWCoreScaffolding.false else c) c (@SAWCoreScaffolding.and (@SAWCoreScaffolding.not (@SAWCoreScaffolding.false)) c) (@ite_false (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.false) c) (@sym (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.and (@SAWCoreScaffolding.not (@SAWCoreScaffolding.false)) c) c (@trans (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.and (@SAWCoreScaffolding.not (@SAWCoreScaffolding.false)) c) (@SAWCoreScaffolding.and (@SAWCoreScaffolding.true) c) c (@eq_cong (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.not (@SAWCoreScaffolding.false)) (@SAWCoreScaffolding.true) not_False (@SAWCoreScaffolding.Bool) (fun (z : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.and z c)) (@and_True1 c)))). + +Definition ite_bit_true_1 : forall (b : @SAWCoreScaffolding.Bool), forall (c : @SAWCoreScaffolding.Bool), @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (if b then @SAWCoreScaffolding.true else c) (@SAWCoreScaffolding.or b c) := + fun (b : @SAWCoreScaffolding.Bool) (c : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.iteDep (fun (b' : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (if b' then @SAWCoreScaffolding.true else c) (@SAWCoreScaffolding.or b' c)) b (@trans (@SAWCoreScaffolding.Bool) (if @SAWCoreScaffolding.true then @SAWCoreScaffolding.true else c) (@SAWCoreScaffolding.true) (@SAWCoreScaffolding.or (@SAWCoreScaffolding.true) c) (@ite_true (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.true) c) (@sym (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.or (@SAWCoreScaffolding.true) c) (@SAWCoreScaffolding.true) (@or_True1 c))) (@trans (@SAWCoreScaffolding.Bool) (if @SAWCoreScaffolding.false then @SAWCoreScaffolding.true else c) c (@SAWCoreScaffolding.or (@SAWCoreScaffolding.false) c) (@ite_false (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.true) c) (@sym (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.or (@SAWCoreScaffolding.false) c) c (@or_False1 c))). + +Definition ite_fold_not : forall (b : @SAWCoreScaffolding.Bool), @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (if b then @SAWCoreScaffolding.false else @SAWCoreScaffolding.true) (@SAWCoreScaffolding.not b) := + fun (b : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.iteDep (fun (b' : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (if b' then @SAWCoreScaffolding.false else @SAWCoreScaffolding.true) (@SAWCoreScaffolding.not b')) b (@trans (@SAWCoreScaffolding.Bool) (if @SAWCoreScaffolding.true then @SAWCoreScaffolding.false else @SAWCoreScaffolding.true) (@SAWCoreScaffolding.false) (@SAWCoreScaffolding.not (@SAWCoreScaffolding.true)) (@ite_true (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.false) (@SAWCoreScaffolding.true)) (@sym (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.not (@SAWCoreScaffolding.true)) (@SAWCoreScaffolding.false) not_True)) (@trans (@SAWCoreScaffolding.Bool) (if @SAWCoreScaffolding.false then @SAWCoreScaffolding.false else @SAWCoreScaffolding.true) (@SAWCoreScaffolding.true) (@SAWCoreScaffolding.not (@SAWCoreScaffolding.false)) (@ite_false (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.false) (@SAWCoreScaffolding.true)) (@sym (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.not (@SAWCoreScaffolding.false)) (@SAWCoreScaffolding.true) not_False)). + +Definition ite_eq : forall (a : Type), forall (b : @SAWCoreScaffolding.Bool), forall (x : a), @SAWCoreScaffolding.Eq a (if b then x else x) x := + fun (a : Type) (b : @SAWCoreScaffolding.Bool) (x : a) => @SAWCoreScaffolding.iteDep (fun (b' : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.Eq a (if b' then x else x) x) b (@ite_true a x x) (@ite_false a x x). + +Definition or_triv1 : forall (x : @SAWCoreScaffolding.Bool), @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.or x (@SAWCoreScaffolding.not x)) (@SAWCoreScaffolding.true) := + fun (x : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.iteDep (fun (b : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.or b (@SAWCoreScaffolding.not b)) (@SAWCoreScaffolding.true)) x (@or_True1 (@SAWCoreScaffolding.not (@SAWCoreScaffolding.true))) (@trans (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.or (@SAWCoreScaffolding.false) (@SAWCoreScaffolding.not (@SAWCoreScaffolding.false))) (@SAWCoreScaffolding.not (@SAWCoreScaffolding.false)) (@SAWCoreScaffolding.true) (@or_False1 (@SAWCoreScaffolding.not (@SAWCoreScaffolding.false))) not_False). + +Definition or_triv2 : forall (x : @SAWCoreScaffolding.Bool), @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.or (@SAWCoreScaffolding.not x) x) (@SAWCoreScaffolding.true) := + fun (x : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.iteDep (fun (b : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.or (@SAWCoreScaffolding.not b) b) (@SAWCoreScaffolding.true)) x (@or_True2 (@SAWCoreScaffolding.not (@SAWCoreScaffolding.true))) (@trans (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.or (@SAWCoreScaffolding.not (@SAWCoreScaffolding.false)) (@SAWCoreScaffolding.false)) (@SAWCoreScaffolding.not (@SAWCoreScaffolding.false)) (@SAWCoreScaffolding.true) (@or_False2 (@SAWCoreScaffolding.not (@SAWCoreScaffolding.false))) not_False). + +Definition and_triv1 : forall (x : @SAWCoreScaffolding.Bool), @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.and x (@SAWCoreScaffolding.not x)) (@SAWCoreScaffolding.false) := + fun (x : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.iteDep (fun (b : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.and b (@SAWCoreScaffolding.not b)) (@SAWCoreScaffolding.false)) x (@trans (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.and (@SAWCoreScaffolding.true) (@SAWCoreScaffolding.not (@SAWCoreScaffolding.true))) (@SAWCoreScaffolding.not (@SAWCoreScaffolding.true)) (@SAWCoreScaffolding.false) (@and_True1 (@SAWCoreScaffolding.not (@SAWCoreScaffolding.true))) not_True) (@and_False1 (@SAWCoreScaffolding.not (@SAWCoreScaffolding.false))). + +Definition and_triv2 : forall (x : @SAWCoreScaffolding.Bool), @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.and (@SAWCoreScaffolding.not x) x) (@SAWCoreScaffolding.false) := + fun (x : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.iteDep (fun (b : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.and (@SAWCoreScaffolding.not b) b) (@SAWCoreScaffolding.false)) x (@trans (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.and (@SAWCoreScaffolding.not (@SAWCoreScaffolding.true)) (@SAWCoreScaffolding.true)) (@SAWCoreScaffolding.not (@SAWCoreScaffolding.true)) (@SAWCoreScaffolding.false) (@and_True2 (@SAWCoreScaffolding.not (@SAWCoreScaffolding.true))) not_True) (@and_False2 (@SAWCoreScaffolding.not (@SAWCoreScaffolding.false))). + +Definition EqTrue : @SAWCoreScaffolding.Bool -> Prop := + fun (x : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) x (@SAWCoreScaffolding.true). + +Definition TrueI : @EqTrue (@SAWCoreScaffolding.true) := + @SAWCoreScaffolding.Refl (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.true). + +Definition andI : forall (x : @SAWCoreScaffolding.Bool), forall (y : @SAWCoreScaffolding.Bool), @EqTrue x -> @EqTrue y -> @EqTrue (@SAWCoreScaffolding.and x y) := + fun (x : @SAWCoreScaffolding.Bool) (y : @SAWCoreScaffolding.Bool) (p : @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) x (@SAWCoreScaffolding.true)) (q : @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) y (@SAWCoreScaffolding.true)) => @trans4 (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.and x y) (@SAWCoreScaffolding.and x (@SAWCoreScaffolding.true)) x (@SAWCoreScaffolding.true) (@eq_cong (@SAWCoreScaffolding.Bool) y (@SAWCoreScaffolding.true) q (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.and x)) (@and_True2 x) p. + +Definition impliesI : forall (x : @SAWCoreScaffolding.Bool), forall (y : @SAWCoreScaffolding.Bool), (@EqTrue x -> @EqTrue y) -> @EqTrue (@implies x y) := + fun (x : @SAWCoreScaffolding.Bool) (y : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.iteDep (fun (x1 : @SAWCoreScaffolding.Bool) => (@EqTrue x1 -> @EqTrue y) -> @EqTrue (@implies x1 y)) x (fun (H : @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.true) (@SAWCoreScaffolding.true) -> @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) y (@SAWCoreScaffolding.true)) => @trans (@SAWCoreScaffolding.Bool) (@implies (@SAWCoreScaffolding.true) y) y (@SAWCoreScaffolding.true) (@implies_True1 y) (H TrueI)) (fun (_1 : @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.false) (@SAWCoreScaffolding.true) -> @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) y (@SAWCoreScaffolding.true)) => @implies_False1 y). + +Inductive Either (s : Type) (t : Type) : Type := +| Left : s -> @Either s t +| Right : t -> @Either s t +. + +Definition Either__rec : forall (s : Type), forall (t : Type), forall (p : @Either s t -> Type), (forall (l : s), p (@Left s t l)) -> (forall (r : t), p (@Right s t r)) -> forall (e : @Either s t), p e := + fun (s : Type) (t : Type) (p : @Either s t -> Type) (f1 : forall (l : s), p (@Left s t l)) (f2 : forall (r : t), p (@Right s t r)) (e : @Either s t) => SAWCorePrelude.Either_rect s t p f1 f2 e. + +Definition either : forall (a : Type), forall (b : Type), forall (c : Type), (a -> c) -> (b -> c) -> @Either a b -> c := + fun (a : Type) (b : Type) (c : Type) (f : a -> c) (g : b -> c) (e : @Either a b) => @Either__rec a b (fun (p : @Either a b) => c) f g e. + +Definition eitherCong0 : forall (t : Type), forall (x : Type), forall (y : Type), @SAWCoreScaffolding.Eq Type x y -> @SAWCoreScaffolding.Eq Type (@Either x t) (@Either y t) := + fun (t : Type) (x : Type) (y : Type) (eq : @SAWCoreScaffolding.Eq Type x y) => @eq_cong Type x y eq Type (fun (y' : Type) => @Either y' t). + +Definition eitherCong1 : forall (t : Type), forall (x : Type), forall (y : Type), @SAWCoreScaffolding.Eq Type x y -> @SAWCoreScaffolding.Eq Type (@Either t x) (@Either t y) := + fun (t : Type) (x : Type) (y : Type) (eq : @SAWCoreScaffolding.Eq Type x y) => @eq_cong Type x y eq Type (fun (y' : Type) => @Either t y'). + +Inductive Maybe (a : Type) : Type := +| Nothing : @Maybe a +| Just : a -> @Maybe a +. + +Definition Maybe__rec : forall (a : Type), forall (p : @Maybe a -> Type), p (@Nothing a) -> (forall (x : a), p (@Just a x)) -> forall (m : @Maybe a), p m := + fun (a : Type) (p : @Maybe a -> Type) (f1 : p (@Nothing a)) (f2 : forall (x : a), p (@Just a x)) (m : @Maybe a) => SAWCorePrelude.Maybe_rect a p f1 f2 m. + +Definition maybe : forall (a : Type), forall (b : Type), b -> (a -> b) -> @Maybe a -> b := + fun (a : Type) (b : Type) (f1 : b) (f2 : a -> b) (m : @Maybe a) => @Maybe__rec a (fun (m' : @Maybe a) => b) f1 f2 m. + +(* Prelude.Nat was skipped *) + +Definition Nat__rec : forall (p : @SAWCoreScaffolding.Nat -> Type), p (@SAWCoreScaffolding.Zero) -> (forall (n : @SAWCoreScaffolding.Nat), p n -> p (@SAWCoreScaffolding.Succ n)) -> forall (n : @SAWCoreScaffolding.Nat), p n := + fun (p : @SAWCoreScaffolding.Nat -> Type) (f1 : p 0) (f2 : forall (n : @SAWCoreScaffolding.Nat), p n -> p (@SAWCoreScaffolding.Succ n)) (n : @SAWCoreScaffolding.Nat) => SAWCoreScaffolding.Nat_rect p f1 f2 n. + +Definition Nat_cases : forall (a : Type), a -> (@SAWCoreScaffolding.Nat -> a -> a) -> @SAWCoreScaffolding.Nat -> a := + fun (a : Type) (f1 : a) (f2 : @SAWCoreScaffolding.Nat -> a -> a) (n : @SAWCoreScaffolding.Nat) => @Nat__rec (fun (n1 : @SAWCoreScaffolding.Nat) => a) f1 f2 n. + +Definition Nat_cases2 : forall (a : Type), (@SAWCoreScaffolding.Nat -> a) -> (@SAWCoreScaffolding.Nat -> a) -> (@SAWCoreScaffolding.Nat -> @SAWCoreScaffolding.Nat -> a -> a) -> @SAWCoreScaffolding.Nat -> @SAWCoreScaffolding.Nat -> a := + fun (a : Type) (f1 : @SAWCoreScaffolding.Nat -> a) (f2 : @SAWCoreScaffolding.Nat -> a) (f3 : @SAWCoreScaffolding.Nat -> @SAWCoreScaffolding.Nat -> a -> a) (n : @SAWCoreScaffolding.Nat) (m : @SAWCoreScaffolding.Nat) => @Nat__rec (fun (n1 : @SAWCoreScaffolding.Nat) => @SAWCoreScaffolding.Nat -> a) f1 (fun (n1 : @SAWCoreScaffolding.Nat) (f_rec : @SAWCoreScaffolding.Nat -> a) (m1 : @SAWCoreScaffolding.Nat) => @Nat__rec (fun (m' : @SAWCoreScaffolding.Nat) => a) (f2 n1) (fun (m' : @SAWCoreScaffolding.Nat) (frec' : a) => f3 n1 m' (f_rec m')) m1) n m. + +Definition eqNat : @SAWCoreScaffolding.Nat -> @SAWCoreScaffolding.Nat -> Type := + fun (x : @SAWCoreScaffolding.Nat) (y : @SAWCoreScaffolding.Nat) => @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Nat) x y. + +Definition eqNatSucc : forall (x : @SAWCoreScaffolding.Nat), forall (y : @SAWCoreScaffolding.Nat), @eqNat x y -> @eqNat (@SAWCoreScaffolding.Succ x) (@SAWCoreScaffolding.Succ y) := + fun (x : @SAWCoreScaffolding.Nat) (y : @SAWCoreScaffolding.Nat) (eq : @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Nat) x y) => @eq_cong (@SAWCoreScaffolding.Nat) x y eq (@SAWCoreScaffolding.Nat) (fun (n : @SAWCoreScaffolding.Nat) => @SAWCoreScaffolding.Succ n). + +Definition pred : @SAWCoreScaffolding.Nat -> @SAWCoreScaffolding.Nat := + fun (x : @SAWCoreScaffolding.Nat) => @Nat_cases (@SAWCoreScaffolding.Nat) (@SAWCoreScaffolding.Zero) (fun (n : @SAWCoreScaffolding.Nat) (m : @SAWCoreScaffolding.Nat) => n) x. + +Definition eqNatPrec : forall (x : @SAWCoreScaffolding.Nat), forall (y : @SAWCoreScaffolding.Nat), @eqNat (@SAWCoreScaffolding.Succ x) (@SAWCoreScaffolding.Succ y) -> @eqNat x y := + fun (x : @SAWCoreScaffolding.Nat) (y : @SAWCoreScaffolding.Nat) (eq' : @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Nat) (@SAWCoreScaffolding.Succ x) (@SAWCoreScaffolding.Succ y)) => @eq_cong (@SAWCoreScaffolding.Nat) (@SAWCoreScaffolding.Succ x) (@SAWCoreScaffolding.Succ y) eq' (@SAWCoreScaffolding.Nat) pred. + +Inductive IsLeNat (n : @SAWCoreScaffolding.Nat) : forall (_1 : @SAWCoreScaffolding.Nat), Prop := +| IsLeNat_base : @IsLeNat n n +| IsLeNat_succ : forall (m : @SAWCoreScaffolding.Nat), @IsLeNat n m -> @IsLeNat n (@SAWCoreScaffolding.Succ m) +. + +Definition IsLtNat : @SAWCoreScaffolding.Nat -> @SAWCoreScaffolding.Nat -> Prop := + fun (m : @SAWCoreScaffolding.Nat) (n : @SAWCoreScaffolding.Nat) => @IsLeNat (@SAWCoreScaffolding.Succ m) n. + +Axiom natCompareLe : forall (m : @SAWCoreScaffolding.Nat), forall (n : @SAWCoreScaffolding.Nat), @Either (@IsLtNat m n) (@IsLeNat n m) . + +Axiom proveEqNat : forall (m : @SAWCoreScaffolding.Nat), forall (n : @SAWCoreScaffolding.Nat), @Maybe (@SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Nat) m n) . + +Axiom proveLeNat : forall (x : @SAWCoreScaffolding.Nat), forall (y : @SAWCoreScaffolding.Nat), @Maybe (@IsLeNat x y) . + +Definition proveLtNat : forall (x : @SAWCoreScaffolding.Nat), forall (y : @SAWCoreScaffolding.Nat), @Maybe (@IsLtNat x y) := + fun (x : @SAWCoreScaffolding.Nat) (y : @SAWCoreScaffolding.Nat) => @proveLeNat (@SAWCoreScaffolding.Succ x) y. + +Definition addNat : @SAWCoreScaffolding.Nat -> @SAWCoreScaffolding.Nat -> @SAWCoreScaffolding.Nat := + fun (x : @SAWCoreScaffolding.Nat) (y : @SAWCoreScaffolding.Nat) => @Nat_cases (@SAWCoreScaffolding.Nat) y (fun (_1 : @SAWCoreScaffolding.Nat) (prev_sum : @SAWCoreScaffolding.Nat) => @SAWCoreScaffolding.Succ prev_sum) x. + +Definition eqNatAdd0 : forall (x : @SAWCoreScaffolding.Nat), @eqNat (@addNat x 0) x := + fun (x : @SAWCoreScaffolding.Nat) => @Nat__rec (fun (n : @SAWCoreScaffolding.Nat) => @eqNat (@addNat n 0) n) (@SAWCoreScaffolding.Refl (@SAWCoreScaffolding.Nat) 0) (fun (n : @SAWCoreScaffolding.Nat) => @eqNatSucc (@addNat n 0) n) x. + +Definition eqNatAddS : forall (x : @SAWCoreScaffolding.Nat), forall (y : @SAWCoreScaffolding.Nat), @eqNat (@addNat x (@SAWCoreScaffolding.Succ y)) (@SAWCoreScaffolding.Succ (@addNat x y)) := + fun (x : @SAWCoreScaffolding.Nat) (y : @SAWCoreScaffolding.Nat) => @Nat__rec (fun (x' : @SAWCoreScaffolding.Nat) => forall (y' : @SAWCoreScaffolding.Nat), @eqNat (@addNat x' (@SAWCoreScaffolding.Succ y')) (@SAWCoreScaffolding.Succ (@addNat x' y'))) (fun (y' : @SAWCoreScaffolding.Nat) => @SAWCoreScaffolding.Refl (@SAWCoreScaffolding.Nat) (@SAWCoreScaffolding.Succ y')) (fun (x' : @SAWCoreScaffolding.Nat) (eqF : forall (y' : @SAWCoreScaffolding.Nat), @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Nat) (SAWCoreScaffolding.Nat_rect (fun (n : @SAWCoreScaffolding.Nat) => @SAWCoreScaffolding.Nat) (@SAWCoreScaffolding.Succ y') (fun (_1 : @SAWCoreScaffolding.Nat) (prev_sum : @SAWCoreScaffolding.Nat) => @SAWCoreScaffolding.Succ prev_sum) x') (@SAWCoreScaffolding.Succ (@addNat x' y'))) (y' : @SAWCoreScaffolding.Nat) => @eqNatSucc (@addNat x' (@SAWCoreScaffolding.Succ y')) (@SAWCoreScaffolding.Succ (@addNat x' y')) (eqF y')) x y. + +Definition eqNatAddComm : forall (x : @SAWCoreScaffolding.Nat), forall (y : @SAWCoreScaffolding.Nat), @eqNat (@addNat x y) (@addNat y x) := + fun (x : @SAWCoreScaffolding.Nat) (y : @SAWCoreScaffolding.Nat) => @Nat__rec (fun (y' : @SAWCoreScaffolding.Nat) => forall (x' : @SAWCoreScaffolding.Nat), @eqNat (@addNat x' y') (@addNat y' x')) (fun (x' : @SAWCoreScaffolding.Nat) => @eqNatAdd0 x') (fun (y' : @SAWCoreScaffolding.Nat) (eqF : forall (x' : @SAWCoreScaffolding.Nat), let var__0 := fun (n : @SAWCoreScaffolding.Nat) => @SAWCoreScaffolding.Nat in + let var__1 := fun (_1 : @SAWCoreScaffolding.Nat) (prev_sum : @SAWCoreScaffolding.Nat) => @SAWCoreScaffolding.Succ prev_sum in + @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Nat) (SAWCoreScaffolding.Nat_rect var__0 y' var__1 x') (SAWCoreScaffolding.Nat_rect var__0 x' var__1 y')) (x' : @SAWCoreScaffolding.Nat) => @trans (@SAWCoreScaffolding.Nat) (@addNat x' (@SAWCoreScaffolding.Succ y')) (@SAWCoreScaffolding.Succ (@addNat x' y')) (@SAWCoreScaffolding.Succ (@addNat y' x')) (@eqNatAddS x' y') (@eqNatSucc (@addNat x' y') (@addNat y' x') (eqF x'))) y x. + +Definition addNat_assoc : forall (x : @SAWCoreScaffolding.Nat), forall (y : @SAWCoreScaffolding.Nat), forall (z : @SAWCoreScaffolding.Nat), @eqNat (@addNat x (@addNat y z)) (@addNat (@addNat x y) z) := + fun (x : @SAWCoreScaffolding.Nat) (y : @SAWCoreScaffolding.Nat) (z : @SAWCoreScaffolding.Nat) => @Nat__rec (fun (x' : @SAWCoreScaffolding.Nat) => @eqNat (@addNat x' (@addNat y z)) (@addNat (@addNat x' y) z)) (@SAWCoreScaffolding.Refl (@SAWCoreScaffolding.Nat) (@addNat y z)) (fun (x' : @SAWCoreScaffolding.Nat) (eq : @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Nat) (SAWCoreScaffolding.Nat_rect (fun (n : @SAWCoreScaffolding.Nat) => @SAWCoreScaffolding.Nat) (@addNat y z) (fun (_1 : @SAWCoreScaffolding.Nat) (prev_sum : @SAWCoreScaffolding.Nat) => @SAWCoreScaffolding.Succ prev_sum) x') (SAWCoreScaffolding.Nat_rect (fun (n : @SAWCoreScaffolding.Nat) => @SAWCoreScaffolding.Nat) z (fun (_1 : @SAWCoreScaffolding.Nat) (prev_sum : @SAWCoreScaffolding.Nat) => @SAWCoreScaffolding.Succ prev_sum) (SAWCoreScaffolding.Nat_rect (fun (n : @SAWCoreScaffolding.Nat) => @SAWCoreScaffolding.Nat) y (fun (_1 : @SAWCoreScaffolding.Nat) (prev_sum : @SAWCoreScaffolding.Nat) => @SAWCoreScaffolding.Succ prev_sum) x'))) => @eqNatSucc (@addNat x' (@addNat y z)) (@addNat (@addNat x' y) z) eq) x. + +Definition mulNat : @SAWCoreScaffolding.Nat -> @SAWCoreScaffolding.Nat -> @SAWCoreScaffolding.Nat := + fun (x : @SAWCoreScaffolding.Nat) (y : @SAWCoreScaffolding.Nat) => @Nat__rec (fun (x' : @SAWCoreScaffolding.Nat) => @SAWCoreScaffolding.Nat) 0 (fun (x' : @SAWCoreScaffolding.Nat) (prod : @SAWCoreScaffolding.Nat) => @addNat y prod) x. + +Definition equal0Nat : @SAWCoreScaffolding.Nat -> @SAWCoreScaffolding.Bool := + fun (n : @SAWCoreScaffolding.Nat) => @Nat_cases (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.true) (fun (n1 : @SAWCoreScaffolding.Nat) (b : @SAWCoreScaffolding.Bool) => @SAWCoreScaffolding.false) n. + +Definition equalNat : @SAWCoreScaffolding.Nat -> @SAWCoreScaffolding.Nat -> @SAWCoreScaffolding.Bool := + fun (x : @SAWCoreScaffolding.Nat) (y : @SAWCoreScaffolding.Nat) => @Nat_cases (@SAWCoreScaffolding.Nat -> @SAWCoreScaffolding.Bool) equal0Nat (fun (n' : @SAWCoreScaffolding.Nat) (eqN : @SAWCoreScaffolding.Nat -> @SAWCoreScaffolding.Bool) (m : @SAWCoreScaffolding.Nat) => @Nat_cases (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.false) (fun (m' : @SAWCoreScaffolding.Nat) (b : @SAWCoreScaffolding.Bool) => eqN m') m) x y. + +Definition ltNat : @SAWCoreScaffolding.Nat -> @SAWCoreScaffolding.Nat -> @SAWCoreScaffolding.Bool := + fun (x : @SAWCoreScaffolding.Nat) (y : @SAWCoreScaffolding.Nat) => @Nat_cases2 (@SAWCoreScaffolding.Bool) (fun (x' : @SAWCoreScaffolding.Nat) => @SAWCoreScaffolding.false) (fun (y' : @SAWCoreScaffolding.Nat) => @SAWCoreScaffolding.true) (fun (y' : @SAWCoreScaffolding.Nat) (x' : @SAWCoreScaffolding.Nat) (lt_mn : @SAWCoreScaffolding.Bool) => lt_mn) y x. + +Definition subNat : @SAWCoreScaffolding.Nat -> @SAWCoreScaffolding.Nat -> @SAWCoreScaffolding.Nat := + fun (x : @SAWCoreScaffolding.Nat) (y : @SAWCoreScaffolding.Nat) => @Nat_cases2 (@SAWCoreScaffolding.Nat) (fun (x' : @SAWCoreScaffolding.Nat) => x') (fun (y' : @SAWCoreScaffolding.Nat) => @SAWCoreScaffolding.Zero) (fun (y' : @SAWCoreScaffolding.Nat) (x' : @SAWCoreScaffolding.Nat) (sub_xy : @SAWCoreScaffolding.Nat) => sub_xy) y x. + +Definition minNat : @SAWCoreScaffolding.Nat -> @SAWCoreScaffolding.Nat -> @SAWCoreScaffolding.Nat := + fun (x : @SAWCoreScaffolding.Nat) (y : @SAWCoreScaffolding.Nat) => @Nat_cases2 (@SAWCoreScaffolding.Nat) (fun (y' : @SAWCoreScaffolding.Nat) => @SAWCoreScaffolding.Zero) (fun (x' : @SAWCoreScaffolding.Nat) => @SAWCoreScaffolding.Zero) (fun (x' : @SAWCoreScaffolding.Nat) (y' : @SAWCoreScaffolding.Nat) (min_xy : @SAWCoreScaffolding.Nat) => @SAWCoreScaffolding.Succ min_xy) x y. + +Definition maxNat : @SAWCoreScaffolding.Nat -> @SAWCoreScaffolding.Nat -> @SAWCoreScaffolding.Nat := + fun (x : @SAWCoreScaffolding.Nat) (y : @SAWCoreScaffolding.Nat) => @Nat_cases2 (@SAWCoreScaffolding.Nat) (fun (x' : @SAWCoreScaffolding.Nat) => x') (fun (y' : @SAWCoreScaffolding.Nat) => @SAWCoreScaffolding.Succ y') (fun (y' : @SAWCoreScaffolding.Nat) (x' : @SAWCoreScaffolding.Nat) (sub_xy : @SAWCoreScaffolding.Nat) => sub_xy) y x. + +(* Prelude.widthNat was skipped *) + +Definition expNat : @SAWCoreScaffolding.Nat -> @SAWCoreScaffolding.Nat -> @SAWCoreScaffolding.Nat := + fun (b : @SAWCoreScaffolding.Nat) (e : @SAWCoreScaffolding.Nat) => @Nat_cases (@SAWCoreScaffolding.Nat) 1 (fun (e' : @SAWCoreScaffolding.Nat) (exp_b_e : @SAWCoreScaffolding.Nat) => @mulNat b exp_b_e) e. + +(* Prelude.divModNat was skipped *) + +Definition divNat : @SAWCoreScaffolding.Nat -> @SAWCoreScaffolding.Nat -> @SAWCoreScaffolding.Nat := + fun (x : @SAWCoreScaffolding.Nat) (y : @SAWCoreScaffolding.Nat) => SAWCoreScaffolding.fst (@SAWCoreScaffolding.divModNat x y). + +Definition modNat : @SAWCoreScaffolding.Nat -> @SAWCoreScaffolding.Nat -> @SAWCoreScaffolding.Nat := + fun (x : @SAWCoreScaffolding.Nat) (y : @SAWCoreScaffolding.Nat) => SAWCoreScaffolding.snd (@SAWCoreScaffolding.divModNat x y). + +Definition natCase : forall (p : @SAWCoreScaffolding.Nat -> Type), p (@SAWCoreScaffolding.Zero) -> (forall (n : @SAWCoreScaffolding.Nat), p (@SAWCoreScaffolding.Succ n)) -> forall (n : @SAWCoreScaffolding.Nat), p n := + fun (p : @SAWCoreScaffolding.Nat -> Type) (z : p 0) (s : forall (n : @SAWCoreScaffolding.Nat), p (@SAWCoreScaffolding.Succ n)) => @Nat__rec p z (fun (n : @SAWCoreScaffolding.Nat) (r : p n) => s n). + +Definition if0Nat : forall (a : Type), @SAWCoreScaffolding.Nat -> a -> a -> a := + fun (a : Type) (n : @SAWCoreScaffolding.Nat) (x : a) (y : a) => @natCase (fun (_1 : @SAWCoreScaffolding.Nat) => a) x (fun (_1 : @SAWCoreScaffolding.Nat) => y) n. + +Axiom expByNat : forall (a : Type), a -> (a -> a -> a) -> a -> @SAWCoreScaffolding.Nat -> a . + +(* Prelude.Vec was skipped *) + +(* Prelude.gen was skipped *) + +(* Prelude.atWithDefault was skipped *) + +Definition sawAt : forall (n : @SAWCoreScaffolding.Nat), forall (a : Type), @SAWCoreVectorsAsCoqVectors.Vec n a -> @SAWCoreScaffolding.Nat -> a := + fun (n : @SAWCoreScaffolding.Nat) (a : Type) (v : @SAWCoreVectorsAsCoqVectors.Vec n a) (i : @SAWCoreScaffolding.Nat) => @SAWCoreVectorsAsCoqVectors.atWithDefault n a (@SAWCoreScaffolding.error a "at: index out of bounds"%string) v i. + +(* Prelude.EmptyVec was skipped *) + +Definition ConsVec : forall (a : Type), a -> forall (n : @SAWCoreScaffolding.Nat), @SAWCoreVectorsAsCoqVectors.Vec n a -> @SAWCoreVectorsAsCoqVectors.Vec (@SAWCoreScaffolding.Succ n) a := + fun (a : Type) (x : a) (n : @SAWCoreScaffolding.Nat) (v : @SAWCoreVectorsAsCoqVectors.Vec n a) => @SAWCoreVectorsAsCoqVectors.gen (@SAWCoreScaffolding.Succ n) a (@Nat_cases a x (fun (i : @SAWCoreScaffolding.Nat) (a' : a) => @SAWCorePrelude.sawAt n a v i)). + +Definition upd : forall (n : @SAWCoreScaffolding.Nat), forall (a : Type), @SAWCoreVectorsAsCoqVectors.Vec n a -> @SAWCoreScaffolding.Nat -> a -> @SAWCoreVectorsAsCoqVectors.Vec n a := + fun (n : @SAWCoreScaffolding.Nat) (a : Type) (v : @SAWCoreVectorsAsCoqVectors.Vec n a) (j : @SAWCoreScaffolding.Nat) (x : a) => @SAWCoreVectorsAsCoqVectors.gen n a (fun (i : @SAWCoreScaffolding.Nat) => if @equalNat i j then x else @SAWCorePrelude.sawAt n a v i). + +Definition map : forall (a : Type), forall (b : Type), (a -> b) -> forall (n : @SAWCoreScaffolding.Nat), @SAWCoreVectorsAsCoqVectors.Vec n a -> @SAWCoreVectorsAsCoqVectors.Vec n b := + fun (a : Type) (b : Type) (f : a -> b) (n : @SAWCoreScaffolding.Nat) (v : @SAWCoreVectorsAsCoqVectors.Vec n a) => @SAWCoreVectorsAsCoqVectors.gen n b (fun (i : @SAWCoreScaffolding.Nat) => f (@SAWCorePrelude.sawAt n a v i)). + +Definition zipWith : forall (a : Type), forall (b : Type), forall (c : Type), (a -> b -> c) -> forall (n : @SAWCoreScaffolding.Nat), @SAWCoreVectorsAsCoqVectors.Vec n a -> @SAWCoreVectorsAsCoqVectors.Vec n b -> @SAWCoreVectorsAsCoqVectors.Vec n c := + fun (a : Type) (b : Type) (c : Type) (f : a -> b -> c) (n : @SAWCoreScaffolding.Nat) (x : @SAWCoreVectorsAsCoqVectors.Vec n a) (y : @SAWCoreVectorsAsCoqVectors.Vec n b) => @SAWCoreVectorsAsCoqVectors.gen n c (fun (i : @SAWCoreScaffolding.Nat) => f (@SAWCorePrelude.sawAt n a x i) (@SAWCorePrelude.sawAt n b y i)). + +Definition replicate : forall (n : @SAWCoreScaffolding.Nat), forall (a : Type), a -> @SAWCoreVectorsAsCoqVectors.Vec n a := + fun (n : @SAWCoreScaffolding.Nat) (a : Type) (x : a) => @SAWCoreVectorsAsCoqVectors.gen n a (fun (_1 : @SAWCoreScaffolding.Nat) => x). + +Definition single : forall (a : Type), a -> @SAWCoreVectorsAsCoqVectors.Vec 1 a := + @replicate 1. + +(* Prelude.at_single was skipped *) + + +Fixpoint zip (a b : sort 0) (m n : Nat) (xs : Vec m a) (ys : Vec n b) + : Vec (minNat m n) (a * b) := + match + xs in Vector.t _ m' + return Vector.t _ (minNat m' n) + with + | Vector.nil => Vector.nil _ + | Vector.cons x pm xs => + match + ys in Vector.t _ n' + return Vector.t _ (minNat (S pm) n') + with + | Vector.nil => Vector.nil _ + | Vector.cons y pm' ys => Vector.cons _ (x, y) _ (zip _ _ _ _ xs ys) + end + end +. + +(* Prelude.foldr was skipped *) + +Definition reverse : forall (n : @SAWCoreScaffolding.Nat), forall (a : Type), @SAWCoreVectorsAsCoqVectors.Vec n a -> @SAWCoreVectorsAsCoqVectors.Vec n a := + fun (n : @SAWCoreScaffolding.Nat) (a : Type) (xs : @SAWCoreVectorsAsCoqVectors.Vec n a) => @SAWCoreVectorsAsCoqVectors.gen n a (fun (i : @SAWCoreScaffolding.Nat) => @SAWCorePrelude.sawAt n a xs (@subNat (@subNat n 1) i)). + +Definition transpose : forall (m : @SAWCoreScaffolding.Nat), forall (n : @SAWCoreScaffolding.Nat), forall (a : Type), @SAWCoreVectorsAsCoqVectors.Vec m (@SAWCoreVectorsAsCoqVectors.Vec n a) -> let var__0 := @SAWCoreScaffolding.Nat -> Type -> Type in + @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreVectorsAsCoqVectors.Vec m a) := + fun (m : @SAWCoreScaffolding.Nat) (n : @SAWCoreScaffolding.Nat) (a : Type) (xss : @SAWCoreVectorsAsCoqVectors.Vec m (@SAWCoreVectorsAsCoqVectors.Vec n a)) => @SAWCoreVectorsAsCoqVectors.gen n (@SAWCoreVectorsAsCoqVectors.Vec m a) (fun (j : @SAWCoreScaffolding.Nat) => @SAWCoreVectorsAsCoqVectors.gen m a (fun (i : @SAWCoreScaffolding.Nat) => @SAWCorePrelude.sawAt n a (@SAWCorePrelude.sawAt m (@SAWCoreVectorsAsCoqVectors.Vec n a) xss i) j)). + +Definition vecEq : forall (n : @SAWCoreScaffolding.Nat), forall (a : Type), (a -> a -> @SAWCoreScaffolding.Bool) -> @SAWCoreVectorsAsCoqVectors.Vec n a -> @SAWCoreVectorsAsCoqVectors.Vec n a -> @SAWCoreScaffolding.Bool := + fun (n : @SAWCoreScaffolding.Nat) (a : Type) (eqFn : a -> a -> @SAWCoreScaffolding.Bool) (x : @SAWCoreVectorsAsCoqVectors.Vec n a) (y : @SAWCoreVectorsAsCoqVectors.Vec n a) => @SAWCoreVectorsAsCoqVectors.foldr (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.Bool) n (@SAWCoreScaffolding.and) (@SAWCoreScaffolding.true) (@zipWith a a (@SAWCoreScaffolding.Bool) eqFn n x y). + +Definition take : forall (a : Type), forall (m : @SAWCoreScaffolding.Nat), forall (n : @SAWCoreScaffolding.Nat), @SAWCoreVectorsAsCoqVectors.Vec (@addNat m n) a -> @SAWCoreVectorsAsCoqVectors.Vec m a := + fun (a : Type) (m : @SAWCoreScaffolding.Nat) (n : @SAWCoreScaffolding.Nat) (v : @SAWCoreVectorsAsCoqVectors.Vec (@addNat m n) a) => @SAWCoreVectorsAsCoqVectors.gen m a (fun (i : @SAWCoreScaffolding.Nat) => @SAWCorePrelude.sawAt (@addNat m n) a v i). + +Definition vecCong : forall (a : Type), forall (m : @SAWCoreScaffolding.Nat), forall (n : @SAWCoreScaffolding.Nat), @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Nat) m n -> let var__0 := @SAWCoreScaffolding.Nat -> Type -> Type in + @SAWCoreScaffolding.Eq Type (@SAWCoreVectorsAsCoqVectors.Vec m a) (@SAWCoreVectorsAsCoqVectors.Vec n a) := + fun (a : Type) (m : @SAWCoreScaffolding.Nat) (n : @SAWCoreScaffolding.Nat) (eq : @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Nat) m n) => @eq_cong (@SAWCoreScaffolding.Nat) m n eq Type (fun (i : @SAWCoreScaffolding.Nat) => @SAWCoreVectorsAsCoqVectors.Vec i a). + +(* Prelude.coerceVec was skipped *) + +(* Prelude.take0 was skipped *) + +Definition drop : forall (a : Type), forall (m : @SAWCoreScaffolding.Nat), forall (n : @SAWCoreScaffolding.Nat), @SAWCoreVectorsAsCoqVectors.Vec (@addNat m n) a -> @SAWCoreVectorsAsCoqVectors.Vec n a := + fun (a : Type) (m : @SAWCoreScaffolding.Nat) (n : @SAWCoreScaffolding.Nat) (v : @SAWCoreVectorsAsCoqVectors.Vec (@addNat m n) a) => @SAWCoreVectorsAsCoqVectors.gen n a (fun (i : @SAWCoreScaffolding.Nat) => @SAWCorePrelude.sawAt (@addNat m n) a v (@addNat m i)). + +(* Prelude.drop0 was skipped *) + +Definition slice : forall (a : Type), forall (m : @SAWCoreScaffolding.Nat), forall (n : @SAWCoreScaffolding.Nat), forall (o : @SAWCoreScaffolding.Nat), @SAWCoreVectorsAsCoqVectors.Vec (@addNat (@addNat m n) o) a -> @SAWCoreVectorsAsCoqVectors.Vec n a := + fun (a : Type) (m : @SAWCoreScaffolding.Nat) (n : @SAWCoreScaffolding.Nat) (o : @SAWCoreScaffolding.Nat) (v : @SAWCoreVectorsAsCoqVectors.Vec (@addNat (@addNat m n) o) a) => @drop a m n (@take a (@addNat m n) o v). + +Definition join : forall (m : @SAWCoreScaffolding.Nat), forall (n : @SAWCoreScaffolding.Nat), forall (a : Type), @SAWCoreVectorsAsCoqVectors.Vec m (@SAWCoreVectorsAsCoqVectors.Vec n a) -> @SAWCoreVectorsAsCoqVectors.Vec (@mulNat m n) a := + fun (m : @SAWCoreScaffolding.Nat) (n : @SAWCoreScaffolding.Nat) (a : Type) (v : @SAWCoreVectorsAsCoqVectors.Vec m (@SAWCoreVectorsAsCoqVectors.Vec n a)) => @SAWCoreVectorsAsCoqVectors.gen (@mulNat m n) a (fun (i : @SAWCoreScaffolding.Nat) => @SAWCorePrelude.sawAt n a (@SAWCorePrelude.sawAt m (@SAWCoreVectorsAsCoqVectors.Vec n a) v (@divNat i n)) (@modNat i n)). + +Definition split : forall (m : @SAWCoreScaffolding.Nat), forall (n : @SAWCoreScaffolding.Nat), forall (a : Type), @SAWCoreVectorsAsCoqVectors.Vec (@mulNat m n) a -> let var__0 := @SAWCoreScaffolding.Nat -> Type -> Type in + @SAWCoreVectorsAsCoqVectors.Vec m (@SAWCoreVectorsAsCoqVectors.Vec n a) := + fun (m : @SAWCoreScaffolding.Nat) (n : @SAWCoreScaffolding.Nat) (a : Type) (v : @SAWCoreVectorsAsCoqVectors.Vec (@mulNat m n) a) => @SAWCoreVectorsAsCoqVectors.gen m (@SAWCoreVectorsAsCoqVectors.Vec n a) (fun (i : @SAWCoreScaffolding.Nat) => @SAWCoreVectorsAsCoqVectors.gen n a (fun (j : @SAWCoreScaffolding.Nat) => @SAWCorePrelude.sawAt (@mulNat m n) a v (@addNat (@mulNat i n) j))). + +Definition append : forall (m : @SAWCoreScaffolding.Nat), forall (n : @SAWCoreScaffolding.Nat), forall (a : Type), @SAWCoreVectorsAsCoqVectors.Vec m a -> @SAWCoreVectorsAsCoqVectors.Vec n a -> @SAWCoreVectorsAsCoqVectors.Vec (@addNat m n) a := + fun (m : @SAWCoreScaffolding.Nat) (n : @SAWCoreScaffolding.Nat) (a : Type) (x : @SAWCoreVectorsAsCoqVectors.Vec m a) (y : @SAWCoreVectorsAsCoqVectors.Vec n a) => @SAWCoreVectorsAsCoqVectors.gen (@addNat m n) a (fun (i : @SAWCoreScaffolding.Nat) => if @ltNat i m then @SAWCorePrelude.sawAt m a x i else @SAWCorePrelude.sawAt n a y (@subNat i m)). + +(* Prelude.rotateL was skipped *) + +(* Prelude.rotateR was skipped *) + +(* Prelude.shiftL was skipped *) + +(* Prelude.shiftR was skipped *) + +Definition joinLittleEndian : forall (m : @SAWCoreScaffolding.Nat), forall (n : @SAWCoreScaffolding.Nat), forall (a : Type), @SAWCoreVectorsAsCoqVectors.Vec m (@SAWCoreVectorsAsCoqVectors.Vec n a) -> @SAWCoreVectorsAsCoqVectors.Vec (@mulNat m n) a := + fun (m : @SAWCoreScaffolding.Nat) (n : @SAWCoreScaffolding.Nat) (a : Type) (v : @SAWCoreVectorsAsCoqVectors.Vec m (@SAWCoreVectorsAsCoqVectors.Vec n a)) => @join m n a (@reverse m (@SAWCoreVectorsAsCoqVectors.Vec n a) v). + +Definition splitLittleEndian : forall (m : @SAWCoreScaffolding.Nat), forall (n : @SAWCoreScaffolding.Nat), forall (a : Type), @SAWCoreVectorsAsCoqVectors.Vec (@mulNat m n) a -> let var__0 := @SAWCoreScaffolding.Nat -> Type -> Type in + @SAWCoreVectorsAsCoqVectors.Vec m (@SAWCoreVectorsAsCoqVectors.Vec n a) := + fun (m : @SAWCoreScaffolding.Nat) (n : @SAWCoreScaffolding.Nat) (a : Type) (v : @SAWCoreVectorsAsCoqVectors.Vec (@mulNat m n) a) => @reverse m (@SAWCoreVectorsAsCoqVectors.Vec n a) (@split m n a v). + +Definition msb : forall (n : @SAWCoreScaffolding.Nat), @SAWCoreVectorsAsCoqVectors.Vec (@SAWCoreScaffolding.Succ n) (@SAWCoreScaffolding.Bool) -> @SAWCoreScaffolding.Bool := + fun (n : @SAWCoreScaffolding.Nat) (v : @SAWCoreVectorsAsCoqVectors.Vec (@SAWCoreScaffolding.Succ n) (@SAWCoreScaffolding.Bool)) => @SAWCorePrelude.sawAt (@SAWCoreScaffolding.Succ n) (@SAWCoreScaffolding.Bool) v 0. + +Definition lsb : forall (n : @SAWCoreScaffolding.Nat), @SAWCoreVectorsAsCoqVectors.Vec (@SAWCoreScaffolding.Succ n) (@SAWCoreScaffolding.Bool) -> @SAWCoreScaffolding.Bool := + fun (n : @SAWCoreScaffolding.Nat) (v : @SAWCoreVectorsAsCoqVectors.Vec (@SAWCoreScaffolding.Succ n) (@SAWCoreScaffolding.Bool)) => @SAWCorePrelude.sawAt (@SAWCoreScaffolding.Succ n) (@SAWCoreScaffolding.Bool) v n. + +(* Prelude.bvNat was skipped *) + +(* Prelude.bvToNat was skipped *) + +Definition bvAt : forall (n : @SAWCoreScaffolding.Nat), forall (a : Type), forall (w : @SAWCoreScaffolding.Nat), @SAWCoreVectorsAsCoqVectors.Vec n a -> @SAWCoreVectorsAsCoqVectors.Vec w (@SAWCoreScaffolding.Bool) -> a := + fun (n : @SAWCoreScaffolding.Nat) (a : Type) (w : @SAWCoreScaffolding.Nat) (xs : @SAWCoreVectorsAsCoqVectors.Vec n a) (i : @SAWCoreVectorsAsCoqVectors.Vec w (@SAWCoreScaffolding.Bool)) => @SAWCorePrelude.sawAt n a xs (@SAWCoreVectorsAsCoqVectors.bvToNat w i). + +Definition bvUpd : forall (n : @SAWCoreScaffolding.Nat), forall (a : Type), forall (w : @SAWCoreScaffolding.Nat), @SAWCoreVectorsAsCoqVectors.Vec n a -> @SAWCoreVectorsAsCoqVectors.Vec w (@SAWCoreScaffolding.Bool) -> a -> @SAWCoreVectorsAsCoqVectors.Vec n a := + fun (n : @SAWCoreScaffolding.Nat) (a : Type) (w : @SAWCoreScaffolding.Nat) (xs : @SAWCoreVectorsAsCoqVectors.Vec n a) (i : @SAWCoreVectorsAsCoqVectors.Vec w (@SAWCoreScaffolding.Bool)) (y : a) => @upd n a xs (@SAWCoreVectorsAsCoqVectors.bvToNat w i) y. + +Definition bvRotateL : forall (n : @SAWCoreScaffolding.Nat), forall (a : Type), forall (w : @SAWCoreScaffolding.Nat), @SAWCoreVectorsAsCoqVectors.Vec n a -> @SAWCoreVectorsAsCoqVectors.Vec w (@SAWCoreScaffolding.Bool) -> @SAWCoreVectorsAsCoqVectors.Vec n a := + fun (n : @SAWCoreScaffolding.Nat) (a : Type) (w : @SAWCoreScaffolding.Nat) (xs : @SAWCoreVectorsAsCoqVectors.Vec n a) (i : @SAWCoreVectorsAsCoqVectors.Vec w (@SAWCoreScaffolding.Bool)) => @SAWCoreVectorsAsCoqVectors.rotateL n a xs (@SAWCoreVectorsAsCoqVectors.bvToNat w i). + +Definition bvRotateR : forall (n : @SAWCoreScaffolding.Nat), forall (a : Type), forall (w : @SAWCoreScaffolding.Nat), @SAWCoreVectorsAsCoqVectors.Vec n a -> @SAWCoreVectorsAsCoqVectors.Vec w (@SAWCoreScaffolding.Bool) -> @SAWCoreVectorsAsCoqVectors.Vec n a := + fun (n : @SAWCoreScaffolding.Nat) (a : Type) (w : @SAWCoreScaffolding.Nat) (xs : @SAWCoreVectorsAsCoqVectors.Vec n a) (i : @SAWCoreVectorsAsCoqVectors.Vec w (@SAWCoreScaffolding.Bool)) => @SAWCoreVectorsAsCoqVectors.rotateR n a xs (@SAWCoreVectorsAsCoqVectors.bvToNat w i). + +Definition bvShiftL : forall (n : @SAWCoreScaffolding.Nat), forall (a : Type), forall (w : @SAWCoreScaffolding.Nat), a -> @SAWCoreVectorsAsCoqVectors.Vec n a -> @SAWCoreVectorsAsCoqVectors.Vec w (@SAWCoreScaffolding.Bool) -> @SAWCoreVectorsAsCoqVectors.Vec n a := + fun (n : @SAWCoreScaffolding.Nat) (a : Type) (w : @SAWCoreScaffolding.Nat) (z : a) (xs : @SAWCoreVectorsAsCoqVectors.Vec n a) (i : @SAWCoreVectorsAsCoqVectors.Vec w (@SAWCoreScaffolding.Bool)) => @SAWCoreVectorsAsCoqVectors.shiftL n a z xs (@SAWCoreVectorsAsCoqVectors.bvToNat w i). + +Definition bvShiftR : forall (n : @SAWCoreScaffolding.Nat), forall (a : Type), forall (w : @SAWCoreScaffolding.Nat), a -> @SAWCoreVectorsAsCoqVectors.Vec n a -> @SAWCoreVectorsAsCoqVectors.Vec w (@SAWCoreScaffolding.Bool) -> @SAWCoreVectorsAsCoqVectors.Vec n a := + fun (n : @SAWCoreScaffolding.Nat) (a : Type) (w : @SAWCoreScaffolding.Nat) (z : a) (xs : @SAWCoreVectorsAsCoqVectors.Vec n a) (i : @SAWCoreVectorsAsCoqVectors.Vec w (@SAWCoreScaffolding.Bool)) => @SAWCoreVectorsAsCoqVectors.shiftR n a z xs (@SAWCoreVectorsAsCoqVectors.bvToNat w i). + +(* Prelude.bvAdd was skipped *) + +(* Prelude.bvugt was skipped *) + +(* Prelude.bvuge was skipped *) + +(* Prelude.bvult was skipped *) + +(* Prelude.bvule was skipped *) + +(* Prelude.bvsgt was skipped *) + +(* Prelude.bvsge was skipped *) + +(* Prelude.bvslt was skipped *) + +(* Prelude.bvsle was skipped *) + +(* Prelude.bvPopcount was skipped *) + +(* Prelude.bvCountLeadingZeros was skipped *) + +(* Prelude.bvCountTrailingZeros was skipped *) + +(* Prelude.bvForall was skipped *) + +Definition bvCarry : forall (n : @SAWCoreScaffolding.Nat), @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool) -> @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool) -> @SAWCoreScaffolding.Bool := + fun (n : @SAWCoreScaffolding.Nat) (x : @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool)) (y : @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool)) => @SAWCoreVectorsAsCoqVectors.bvult n (@SAWCoreVectorsAsCoqVectors.bvAdd n x y) x. + +Definition bvSCarry : forall (n : @SAWCoreScaffolding.Nat), @SAWCoreVectorsAsCoqVectors.Vec (@SAWCoreScaffolding.Succ n) (@SAWCoreScaffolding.Bool) -> @SAWCoreVectorsAsCoqVectors.Vec (@SAWCoreScaffolding.Succ n) (@SAWCoreScaffolding.Bool) -> @SAWCoreScaffolding.Bool := + fun (n : @SAWCoreScaffolding.Nat) (x : @SAWCoreVectorsAsCoqVectors.Vec (@SAWCoreScaffolding.Succ n) (@SAWCoreScaffolding.Bool)) (y : @SAWCoreVectorsAsCoqVectors.Vec (@SAWCoreScaffolding.Succ n) (@SAWCoreScaffolding.Bool)) => @SAWCoreScaffolding.and (@SAWCoreScaffolding.boolEq (@msb n x) (@msb n y)) (@SAWCoreScaffolding.xor (@msb n x) (@msb n (@SAWCoreVectorsAsCoqVectors.bvAdd (@SAWCoreScaffolding.Succ n) x y))). + +Definition bvAddWithCarry : forall (n : @SAWCoreScaffolding.Nat), @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool) -> @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool) -> prod (@SAWCoreScaffolding.Bool) (@SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool)) := + fun (n : @SAWCoreScaffolding.Nat) (x : @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool)) (y : @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool)) => pair (@bvCarry n x y) (@SAWCoreVectorsAsCoqVectors.bvAdd n x y). + +(* Prelude.bvAddZeroL was skipped *) + +(* Prelude.bvAddZeroR was skipped *) + +(* Prelude.bvNeg was skipped *) + +(* Prelude.bvSub was skipped *) + +Definition bvSBorrow : forall (n : @SAWCoreScaffolding.Nat), @SAWCoreVectorsAsCoqVectors.Vec (@SAWCoreScaffolding.Succ n) (@SAWCoreScaffolding.Bool) -> @SAWCoreVectorsAsCoqVectors.Vec (@SAWCoreScaffolding.Succ n) (@SAWCoreScaffolding.Bool) -> @SAWCoreScaffolding.Bool := + fun (n : @SAWCoreScaffolding.Nat) (x : @SAWCoreVectorsAsCoqVectors.Vec (@SAWCoreScaffolding.Succ n) (@SAWCoreScaffolding.Bool)) (y : @SAWCoreVectorsAsCoqVectors.Vec (@SAWCoreScaffolding.Succ n) (@SAWCoreScaffolding.Bool)) => @SAWCoreScaffolding.and (@SAWCoreScaffolding.xor (@msb n x) (@msb n y)) (@SAWCoreScaffolding.xor (@msb n x) (@msb n (@SAWCoreVectorsAsCoqVectors.bvSub (@SAWCoreScaffolding.Succ n) x y))). + +(* Prelude.bvMul was skipped *) + +(* Prelude.bvLg2 was skipped *) + +(* Prelude.bvUDiv was skipped *) + +(* Prelude.bvURem was skipped *) + +(* Prelude.bvSDiv was skipped *) + +(* Prelude.bvSRem was skipped *) + +(* Prelude.bvShl was skipped *) + +(* Prelude.bvShr was skipped *) + +(* Prelude.bvSShr was skipped *) + +(* Prelude.bvShiftL_bvShl was skipped *) + +(* Prelude.bvShiftR_bvShr was skipped *) + +Definition bvZipWith : (@SAWCoreScaffolding.Bool -> @SAWCoreScaffolding.Bool -> @SAWCoreScaffolding.Bool) -> forall (n : @SAWCoreScaffolding.Nat), @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool) -> @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool) -> @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool) := + @zipWith (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.Bool). + +Definition bvNot : forall (n : @SAWCoreScaffolding.Nat), @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool) -> @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool) := + @map (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.not). + +Definition bvAnd : forall (n : @SAWCoreScaffolding.Nat), @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool) -> @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool) -> @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool) := + @bvZipWith (@SAWCoreScaffolding.and). + +Definition bvOr : forall (n : @SAWCoreScaffolding.Nat), @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool) -> @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool) -> @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool) := + @bvZipWith (@SAWCoreScaffolding.or). + +Definition bvXor : forall (n : @SAWCoreScaffolding.Nat), @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool) -> @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool) -> @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool) := + @bvZipWith (@SAWCoreScaffolding.xor). + +Definition bvEq : forall (n : @SAWCoreScaffolding.Nat), @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool) -> @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool) -> @SAWCoreScaffolding.Bool := + fun (n : @SAWCoreScaffolding.Nat) (x : @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool)) (y : @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool)) => @vecEq n (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.boolEq) x y. + +(* Prelude.bvEq_refl was skipped *) + +(* Prelude.equalNat_bv was skipped *) + +Definition bvBool : forall (n : @SAWCoreScaffolding.Nat), @SAWCoreScaffolding.Bool -> @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool) := + fun (n : @SAWCoreScaffolding.Nat) (b : @SAWCoreScaffolding.Bool) => if b then @SAWCoreVectorsAsCoqVectors.bvNat n 1 else @SAWCoreVectorsAsCoqVectors.bvNat n 0. + +Definition bvNe : forall (n : @SAWCoreScaffolding.Nat), @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool) -> @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool) -> @SAWCoreScaffolding.Bool := + fun (n : @SAWCoreScaffolding.Nat) (x : @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool)) (y : @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool)) => @SAWCoreScaffolding.not (@bvEq n x y). + +Definition bvNonzero : forall (n : @SAWCoreScaffolding.Nat), @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool) -> @SAWCoreScaffolding.Bool := + fun (n : @SAWCoreScaffolding.Nat) (x : @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool)) => @bvNe n x (@SAWCoreVectorsAsCoqVectors.bvNat n 0). + +Definition bvTrunc : forall (m : @SAWCoreScaffolding.Nat), forall (n : @SAWCoreScaffolding.Nat), @SAWCoreVectorsAsCoqVectors.Vec (@addNat m n) (@SAWCoreScaffolding.Bool) -> @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool) := + @drop (@SAWCoreScaffolding.Bool). + +Definition bvUExt : forall (m : @SAWCoreScaffolding.Nat), forall (n : @SAWCoreScaffolding.Nat), @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool) -> @SAWCoreVectorsAsCoqVectors.Vec (@addNat m n) (@SAWCoreScaffolding.Bool) := + fun (m : @SAWCoreScaffolding.Nat) (n : @SAWCoreScaffolding.Nat) (x : @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool)) => @append m n (@SAWCoreScaffolding.Bool) (@SAWCoreVectorsAsCoqVectors.bvNat m 0) x. + +Definition replicateBool : forall (n : @SAWCoreScaffolding.Nat), @SAWCoreScaffolding.Bool -> @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool) := + fun (n : @SAWCoreScaffolding.Nat) (b : @SAWCoreScaffolding.Bool) => if b then @bvNot n (@SAWCoreVectorsAsCoqVectors.bvNat n 0) else @SAWCoreVectorsAsCoqVectors.bvNat n 0. + +Definition bvSExt : forall (m : @SAWCoreScaffolding.Nat), forall (n : @SAWCoreScaffolding.Nat), @SAWCoreVectorsAsCoqVectors.Vec (@SAWCoreScaffolding.Succ n) (@SAWCoreScaffolding.Bool) -> @SAWCoreVectorsAsCoqVectors.Vec (@addNat m (@SAWCoreScaffolding.Succ n)) (@SAWCoreScaffolding.Bool) := + fun (m : @SAWCoreScaffolding.Nat) (n : @SAWCoreScaffolding.Nat) (x : @SAWCoreVectorsAsCoqVectors.Vec (@SAWCoreScaffolding.Succ n) (@SAWCoreScaffolding.Bool)) => @append m (@SAWCoreScaffolding.Succ n) (@SAWCoreScaffolding.Bool) (@replicateBool m (@msb n x)) x. + +Inductive Stream (a : Type) : Type := +| MkStream : (@SAWCoreScaffolding.Nat -> a) -> @Stream a +. + +Definition Stream__rec : forall (a : Type), forall (p : @Stream a -> Type), (forall (f : @SAWCoreScaffolding.Nat -> a), p (@MkStream a f)) -> forall (str : @Stream a), p str := + fun (a : Type) (p : @Stream a -> Type) (f1 : forall (f : @SAWCoreScaffolding.Nat -> a), p (@MkStream a f)) (str : @Stream a) => SAWCorePrelude.Stream_rect a p f1 str. + +Definition streamUpd : forall (a : Type), @Stream a -> @SAWCoreScaffolding.Nat -> a -> @Stream a := + fun (a : Type) (strm : @Stream a) (i : @SAWCoreScaffolding.Nat) (y : a) => @Stream__rec a (fun (strm' : @Stream a) => @Stream a) (fun (s : @SAWCoreScaffolding.Nat -> a) => @MkStream a (fun (j : @SAWCoreScaffolding.Nat) => if @equalNat i j then y else s j)) strm. + +Definition bvStreamUpd : forall (a : Type), forall (w : @SAWCoreScaffolding.Nat), @Stream a -> @SAWCoreVectorsAsCoqVectors.Vec w (@SAWCoreScaffolding.Bool) -> a -> @Stream a := + fun (a : Type) (w : @SAWCoreScaffolding.Nat) (xs : @Stream a) (i : @SAWCoreVectorsAsCoqVectors.Vec w (@SAWCoreScaffolding.Bool)) (y : a) => @streamUpd a xs (@SAWCoreVectorsAsCoqVectors.bvToNat w i) y. + +Definition streamGet : forall (a : Type), @Stream a -> @SAWCoreScaffolding.Nat -> a := + fun (a : Type) (strm : @Stream a) (i : @SAWCoreScaffolding.Nat) => @Stream__rec a (fun (strm' : @Stream a) => a) (fun (s : @SAWCoreScaffolding.Nat -> a) => s i) strm. + +Definition streamConst : forall (a : Type), a -> @Stream a := + fun (a : Type) (x : a) => @MkStream a (fun (i : @SAWCoreScaffolding.Nat) => x). + +Definition streamMap : forall (a : Type), forall (b : Type), (a -> b) -> @Stream a -> @Stream b := + fun (a : Type) (b : Type) (f : a -> b) (xs : @Stream a) => @MkStream b (fun (i : @SAWCoreScaffolding.Nat) => f (@streamGet a xs i)). + +Definition streamMap2 : forall (a : Type), forall (b : Type), forall (c : Type), (a -> b -> c) -> @Stream a -> @Stream b -> @Stream c := + fun (a : Type) (b : Type) (c : Type) (f : a -> b -> c) (xs : @Stream a) (ys : @Stream b) => @MkStream c (fun (i : @SAWCoreScaffolding.Nat) => f (@streamGet a xs i) (@streamGet b ys i)). + +Definition streamTake : forall (a : Type), forall (n : @SAWCoreScaffolding.Nat), @Stream a -> @SAWCoreVectorsAsCoqVectors.Vec n a := + fun (a : Type) (n : @SAWCoreScaffolding.Nat) (xs : @Stream a) => @SAWCoreVectorsAsCoqVectors.gen n a (fun (i : @SAWCoreScaffolding.Nat) => @streamGet a xs i). + +Definition streamDrop : forall (a : Type), forall (n : @SAWCoreScaffolding.Nat), @Stream a -> @Stream a := + fun (a : Type) (n : @SAWCoreScaffolding.Nat) (xs : @Stream a) => @MkStream a (fun (i : @SAWCoreScaffolding.Nat) => @streamGet a xs (@addNat n i)). + +Definition streamAppend : forall (a : Type), forall (n : @SAWCoreScaffolding.Nat), @SAWCoreVectorsAsCoqVectors.Vec n a -> @Stream a -> @Stream a := + fun (a : Type) (n : @SAWCoreScaffolding.Nat) (xs : @SAWCoreVectorsAsCoqVectors.Vec n a) (ys : @Stream a) => @MkStream a (fun (i : @SAWCoreScaffolding.Nat) => @SAWCoreVectorsAsCoqVectors.atWithDefault n a (@streamGet a ys (@subNat i n)) xs i). + +Definition streamJoin : forall (a : Type), forall (n : @SAWCoreScaffolding.Nat), @Stream (@SAWCoreVectorsAsCoqVectors.Vec (@SAWCoreScaffolding.Succ n) a) -> @Stream a := + fun (a : Type) (n : @SAWCoreScaffolding.Nat) (s : @Stream (@SAWCoreVectorsAsCoqVectors.Vec (@SAWCoreScaffolding.Succ n) a)) => @MkStream a (fun (i : @SAWCoreScaffolding.Nat) => @SAWCorePrelude.sawAt (@SAWCoreScaffolding.Succ n) a (@streamGet (@SAWCoreVectorsAsCoqVectors.Vec (@SAWCoreScaffolding.Succ n) a) s (@divNat i (@SAWCoreScaffolding.Succ n))) (@modNat i (@SAWCoreScaffolding.Succ n))). + +Definition streamSplit : forall (a : Type), forall (n : @SAWCoreScaffolding.Nat), @Stream a -> @Stream (@SAWCoreVectorsAsCoqVectors.Vec n a) := + fun (a : Type) (n : @SAWCoreScaffolding.Nat) (xs : @Stream a) => @MkStream (@SAWCoreVectorsAsCoqVectors.Vec n a) (fun (i : @SAWCoreScaffolding.Nat) => @SAWCoreVectorsAsCoqVectors.gen n a (fun (j : @SAWCoreScaffolding.Nat) => @streamGet a xs (@addNat (@mulNat i n) j))). + +Definition streamShiftL : forall (a : Type), @Stream a -> @SAWCoreScaffolding.Nat -> @Stream a := + fun (a : Type) (xs : @Stream a) (i : @SAWCoreScaffolding.Nat) => @streamDrop a i xs. + +Definition streamShiftR : forall (a : Type), a -> @Stream a -> @SAWCoreScaffolding.Nat -> @Stream a := + fun (a : Type) (z : a) (xs : @Stream a) (i : @SAWCoreScaffolding.Nat) => @streamAppend a i (@replicate i a z) xs. + +(* Prelude.Integer was skipped *) + +(* Prelude.intAdd was skipped *) + +(* Prelude.intSub was skipped *) + +(* Prelude.intMul was skipped *) + +(* Prelude.intDiv was skipped *) + +(* Prelude.intMod was skipped *) + +(* Prelude.intMin was skipped *) + +(* Prelude.intMax was skipped *) + +(* Prelude.intNeg was skipped *) + +(* Prelude.intAbs was skipped *) + +(* Prelude.intEq was skipped *) + +(* Prelude.intLe was skipped *) + +(* Prelude.intLt was skipped *) + +(* Prelude.intToNat was skipped *) + +(* Prelude.natToInt was skipped *) + +(* Prelude.intToBv was skipped *) + +(* Prelude.bvToInt was skipped *) + +(* Prelude.sbvToInt was skipped *) + +(* Prelude.IntMod was skipped *) + +(* Prelude.toIntMod was skipped *) + +(* Prelude.fromIntMod was skipped *) + +(* Prelude.intModEq was skipped *) + +(* Prelude.intModAdd was skipped *) + +(* Prelude.intModSub was skipped *) + +(* Prelude.intModMul was skipped *) + +(* Prelude.intModNeg was skipped *) + +Definition updNatFun : forall (a : Type), (@SAWCoreScaffolding.Nat -> a) -> @SAWCoreScaffolding.Nat -> a -> @SAWCoreScaffolding.Nat -> a := + fun (a : Type) (f : @SAWCoreScaffolding.Nat -> a) (i : @SAWCoreScaffolding.Nat) (v : a) (x : @SAWCoreScaffolding.Nat) => if @equalNat i x then v else f x. + +Definition updBvFun : forall (n : @SAWCoreScaffolding.Nat), forall (a : Type), (@SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool) -> a) -> @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool) -> a -> @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool) -> a := + fun (n : @SAWCoreScaffolding.Nat) (a : Type) (f : @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool) -> a) (i : @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool)) (v : a) (x : @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool)) => if @bvEq n i x then v else f x. + +(* Prelude.Float was skipped *) + +(* Prelude.mkFloat was skipped *) + +(* Prelude.Double was skipped *) + +(* Prelude.mkDouble was skipped *) + +(* Prelude.Sigma was skipped *) + +(* Prelude.Sigma__rec was skipped *) + +(* Prelude.Sigma_proj1 was skipped *) + +(* Prelude.Sigma_proj2 was skipped *) + +(* Prelude.List was skipped *) + +(* Prelude.List__rec was skipped *) + +Definition unfoldList : forall (a : Type), @Datatypes.list a -> @Either unit (prod a (prod (@Datatypes.list a) unit)) := + fun (a : Type) (l : @Datatypes.list a) => @Datatypes.list_rect a (fun (_1 : @Datatypes.list a) => @Either unit (prod a (prod (@Datatypes.list a) unit))) (@Left unit (prod a (prod (@Datatypes.list a) unit)) tt) (fun (x : a) (l1 : @Datatypes.list a) (_1 : @Either unit (prod a (prod (@Datatypes.list a) unit))) => @Right unit (prod a (prod (@Datatypes.list a) unit)) (pair x (pair l1 tt))) l. + +Definition foldList : forall (a : Type), @Either unit (prod a (prod (@Datatypes.list a) unit)) -> @Datatypes.list a := + fun (a : Type) => @either unit (prod a (prod (@Datatypes.list a) unit)) (@Datatypes.list a) (fun (_1 : unit) => @Datatypes.nil a) (fun (tup : prod a (prod (@Datatypes.list a) unit)) => @Datatypes.cons a (SAWCoreScaffolding.fst tup) (SAWCoreScaffolding.fst (SAWCoreScaffolding.snd tup))). + +Inductive W64List : Type := +| W64Nil : @W64List +| W64Cons : @SAWCoreVectorsAsCoqVectors.Vec 64 (@SAWCoreScaffolding.Bool) -> @W64List -> @W64List +. + +Definition unfoldedW64List : Type := + @Either unit (prod (@sigT (@SAWCoreVectorsAsCoqVectors.Vec 64 (@SAWCoreScaffolding.Bool)) (fun (_1 : @SAWCoreVectorsAsCoqVectors.Vec 64 (@SAWCoreScaffolding.Bool)) => unit)) (prod (@W64List) unit)). + +Definition unfoldW64List : @W64List -> unfoldedW64List := + fun (l : @W64List) => SAWCorePrelude.W64List_rect (fun (_1 : @W64List) => unfoldedW64List) (@Left unit (prod (@sigT (@SAWCoreVectorsAsCoqVectors.Vec 64 (@SAWCoreScaffolding.Bool)) (fun (_1 : @SAWCoreVectorsAsCoqVectors.Vec 64 (@SAWCoreScaffolding.Bool)) => unit)) (prod (@W64List) unit)) tt) (fun (bv : @SAWCoreVectorsAsCoqVectors.Vec 64 (@SAWCoreScaffolding.Bool)) (l' : @W64List) (_1 : @Either unit (prod (@sigT (@SAWCoreVectorsAsCoqVectors.Vec 64 (@SAWCoreScaffolding.Bool)) (fun (_1 : @SAWCoreVectorsAsCoqVectors.Vec 64 (@SAWCoreScaffolding.Bool)) => unit)) (prod (@W64List) unit))) => @Right unit (prod (@sigT (@SAWCoreVectorsAsCoqVectors.Vec 64 (@SAWCoreScaffolding.Bool)) (fun (_2 : @SAWCoreVectorsAsCoqVectors.Vec 64 (@SAWCoreScaffolding.Bool)) => unit)) (prod (@W64List) unit)) (pair (@existT (@SAWCoreVectorsAsCoqVectors.Vec 64 (@SAWCoreScaffolding.Bool)) (fun (_2 : @SAWCoreVectorsAsCoqVectors.Vec 64 (@SAWCoreScaffolding.Bool)) => unit) bv tt) (pair l' tt))) l. + +Definition foldW64List : unfoldedW64List -> @W64List := + @either unit (prod (@sigT (@SAWCoreVectorsAsCoqVectors.Vec 64 (@SAWCoreScaffolding.Bool)) (fun (_1 : @SAWCoreVectorsAsCoqVectors.Vec 64 (@SAWCoreScaffolding.Bool)) => unit)) (prod (@W64List) unit)) (@W64List) (fun (_1 : unit) => @W64Nil) (fun (bv_l : prod (@sigT (@SAWCoreVectorsAsCoqVectors.Vec 64 (@SAWCoreScaffolding.Bool)) (fun (_1 : @SAWCoreVectorsAsCoqVectors.Vec 64 (@SAWCoreScaffolding.Bool)) => unit)) (prod (@W64List) unit)) => @W64Cons (@projT1 (@SAWCoreVectorsAsCoqVectors.Vec 64 (@SAWCoreScaffolding.Bool)) (fun (_1 : @SAWCoreVectorsAsCoqVectors.Vec 64 (@SAWCoreScaffolding.Bool)) => unit) (SAWCoreScaffolding.fst bv_l)) (SAWCoreScaffolding.fst (SAWCoreScaffolding.snd bv_l))). + +Axiom bvEqWithProof : forall (n : @SAWCoreScaffolding.Nat), forall (v1 : @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool)), forall (v2 : @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool)), @Maybe (@SAWCoreScaffolding.Eq (@SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool)) v1 v2) . + +Definition bvultWithProof : forall (n : @SAWCoreScaffolding.Nat), forall (v1 : @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool)), forall (v2 : @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool)), @Maybe (@SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (@SAWCoreVectorsAsCoqVectors.bvult n v1 v2) (@SAWCoreScaffolding.true)) := + fun (n : @SAWCoreScaffolding.Nat) (v1 : @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool)) (v2 : @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool)) => @SAWCoreScaffolding.iteDep (fun (b : @SAWCoreScaffolding.Bool) => @Maybe (@SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) b (@SAWCoreScaffolding.true))) (@SAWCoreVectorsAsCoqVectors.bvult n v1 v2) (@Just (@SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.true) (@SAWCoreScaffolding.true)) (@SAWCoreScaffolding.Refl (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.true))) (@Nothing (@SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.false) (@SAWCoreScaffolding.true))). + +Definition bvuleWithProof : forall (n : @SAWCoreScaffolding.Nat), forall (v1 : @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool)), forall (v2 : @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool)), @Maybe (@SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (@SAWCoreVectorsAsCoqVectors.bvule n v1 v2) (@SAWCoreScaffolding.true)) := + fun (n : @SAWCoreScaffolding.Nat) (v1 : @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool)) (v2 : @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool)) => @SAWCoreScaffolding.iteDep (fun (b : @SAWCoreScaffolding.Bool) => @Maybe (@SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) b (@SAWCoreScaffolding.true))) (@SAWCoreVectorsAsCoqVectors.bvule n v1 v2) (@Just (@SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.true) (@SAWCoreScaffolding.true)) (@SAWCoreScaffolding.Refl (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.true))) (@Nothing (@SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (@SAWCoreScaffolding.false) (@SAWCoreScaffolding.true))). + +Axiom bvEqToEqNat : forall (n : @SAWCoreScaffolding.Nat), forall (v1 : @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool)), forall (v2 : @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool)), @SAWCoreScaffolding.Eq (@SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool)) v1 v2 -> let var__0 := forall (n1 : @SAWCoreScaffolding.Nat), @SAWCoreVectorsAsCoqVectors.Vec n1 (@SAWCoreScaffolding.Bool) -> @SAWCoreScaffolding.Nat in + @eqNat (@SAWCoreVectorsAsCoqVectors.bvToNat n v1) (@SAWCoreVectorsAsCoqVectors.bvToNat n v2) . + +Axiom bvultToIsLtNat : forall (n : @SAWCoreScaffolding.Nat), forall (v1 : @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool)), forall (v2 : @SAWCoreVectorsAsCoqVectors.Vec n (@SAWCoreScaffolding.Bool)), @SAWCoreScaffolding.Eq (@SAWCoreScaffolding.Bool) (@SAWCoreVectorsAsCoqVectors.bvult n v1 v2) (@SAWCoreScaffolding.true) -> let var__0 := forall (n1 : @SAWCoreScaffolding.Nat), @SAWCoreVectorsAsCoqVectors.Vec n1 (@SAWCoreScaffolding.Bool) -> @SAWCoreScaffolding.Nat in + @IsLtNat (@SAWCoreVectorsAsCoqVectors.bvToNat n v1) (@SAWCoreVectorsAsCoqVectors.bvToNat n v2) . + +Axiom atWithProof : forall (n : @SAWCoreScaffolding.Nat), forall (a : Type), a -> @SAWCoreVectorsAsCoqVectors.Vec n a -> forall (i : @SAWCoreScaffolding.Nat), @IsLtNat i n -> a . + +Axiom updWithProof : forall (n : @SAWCoreScaffolding.Nat), forall (a : Type), @SAWCoreVectorsAsCoqVectors.Vec n a -> forall (i : @SAWCoreScaffolding.Nat), a -> @IsLtNat i n -> @SAWCoreVectorsAsCoqVectors.Vec n a . + +Axiom sliceWithProof : forall (a : Type), forall (n : @SAWCoreScaffolding.Nat), forall (off : @SAWCoreScaffolding.Nat), forall (len : @SAWCoreScaffolding.Nat), @IsLeNat (@addNat off len) n -> @SAWCoreVectorsAsCoqVectors.Vec n a -> @SAWCoreVectorsAsCoqVectors.Vec len a . + +Axiom updSliceWithProof : forall (a : Type), forall (n : @SAWCoreScaffolding.Nat), forall (off : @SAWCoreScaffolding.Nat), forall (len : @SAWCoreScaffolding.Nat), @IsLeNat (@addNat off len) n -> @SAWCoreVectorsAsCoqVectors.Vec n a -> @SAWCoreVectorsAsCoqVectors.Vec len a -> @SAWCoreVectorsAsCoqVectors.Vec n a . + +(* Prelude.CompM was skipped *) + +(* Prelude.returnM was skipped *) + +(* Prelude.bindM was skipped *) + +(* Prelude.composeM was skipped *) + +(* Prelude.errorM was skipped *) + +(* Prelude.catchM was skipped *) + +(* Prelude.fixM was skipped *) + +(* Prelude.LetRecType was skipped *) + +(* Prelude.lrtToType was skipped *) + +(* Prelude.LetRecTypes was skipped *) + +(* Prelude.lrtPi was skipped *) + +(* Prelude.lrtTupleType was skipped *) + +(* Prelude.multiFixM was skipped *) + +(* Prelude.letRecM was skipped *) + +Definition letRecM1 : forall (a : Type), forall (b : Type), forall (c : Type), ((a -> CompM b) -> a -> CompM b) -> ((a -> CompM b) -> CompM c) -> CompM c := + fun (a : Type) (b : Type) (c : Type) (fn : (a -> CompM b) -> a -> CompM b) (body : (a -> CompM b) -> CompM c) => @CompM.letRecM (@CompM.LRT_Cons (@CompM.LRT_Fun a (fun (_1 : a) => @CompM.LRT_Ret b)) (@CompM.LRT_Nil)) c (fun (f : a -> CompM b) => pair (fn f) tt) (fun (f : a -> CompM b) => body f). + +(* Prelude.test_fun0 was skipped *) + +(* Prelude.test_fun1 was skipped *) + +(* Prelude.test_fun2 was skipped *) + +(* Prelude.test_fun3 was skipped *) + +(* Prelude.test_fun4 was skipped *) + +(* Prelude.test_fun5 was skipped *) + +(* Prelude.test_fun6 was skipped *) + +Axiom Array : Type -> Type -> Type . + +Axiom arrayConstant : forall (a : Type), forall (b : Type), b -> @Array a b . + +Axiom arrayLookup : forall (a : Type), forall (b : Type), @Array a b -> a -> b . + +Axiom arrayUpdate : forall (a : Type), forall (b : Type), @Array a b -> a -> b -> @Array a b . + +Axiom arrayEq : forall (a : Type), forall (b : Type), @Array a b -> @Array a b -> @SAWCoreScaffolding.Bool . + +(* Prelude.bveq_sameL was skipped *) + +(* Prelude.bveq_sameR was skipped *) + +(* Prelude.bveq_same2 was skipped *) + +(* Prelude.bvNat_bvToNat was skipped *) + +(* Prelude.ite_split_cong was skipped *) + +(* Prelude.ite_join_cong was skipped *) + +(* Prelude.map_map was skipped *) + +End SAWCorePrelude. diff --git a/saw-core-coq/coq/handwritten/CryptolToCoq/CompM.v b/saw-core-coq/coq/handwritten/CryptolToCoq/CompM.v new file mode 100644 index 0000000000..7e7e47cee3 --- /dev/null +++ b/saw-core-coq/coq/handwritten/CryptolToCoq/CompM.v @@ -0,0 +1,925 @@ +(*** + *** A version of the computation monad using the option-set monad + ***) + +From Coq Require Import Program.Basics. +From Coq Require Export Morphisms Setoid. +From Coq Require Import Strings.String. + +(*** + *** The Monad Typeclasses + ***) + +(* The monad equivalence relation *) +Class MonadEqOp (M:Type -> Type) : Type := + eqM : forall {A}, M A -> M A -> Prop. + +Infix "~=" := eqM (at level 70, no associativity). + +(* The class for the monadic return operation *) +Class MonadReturnOp (M:Type -> Type) : Type := + returnM : forall {A}, A -> M A. + +(* The class for the monadic bind operation *) +Class MonadBindOp (M:Type -> Type) : Type := + bindM : forall {A B}, M A -> (A -> M B) -> M B. + +Infix ">>=" := bindM (at level 58, left associativity). +Notation "m1 >> m2" := (m1 >>= fun _ => m2) (at level 58, left associativity). + +(* A monad is a collection of monad operations that satisfy the monad laws *) +Class Monad M `{MonadEqOp M} `{MonadReturnOp M} `{MonadBindOp M} : Prop := + { Equivalence_eqM :> forall A, Equivalence (eqM (A:=A)); + Proper_bindM :> forall A B, + Proper (eqM (A:=A) ==> (pointwise_relation A (eqM (A:=B))) ==> eqM) bindM; + returnM_bindM : forall A B a (f:A -> M B), returnM a >>= f ~= f a; + bindM_returnM : forall A (m:M A), m >>= (fun x => returnM x) ~= m; + bindM_bindM : forall A B C (m:M A) (f:A -> M B) (g:B -> M C), + (m >>= f) >>= g ~= m >>= (fun x => f x >>= g) }. + +(* This is not strictly necessary, but it speed up rewriting w.r.t. eq *) +Instance Proper_eq_bindM A B `{Monad} : + Proper (eq ==> (pointwise_relation A (@eq (M B))) ==> eqM) bindM. +Proof. + intros m1 m2 e_m; rewrite e_m. + intros f1 f2 ef; eapply Proper_bindM; [ reflexivity | ]. + intros a; rewrite (ef _). reflexivity. +Qed. + + +(** Monads with Errors **) + +(* The error operation *) +Class MonadErrorOp (M:Type -> Type) : Type := + errorM : forall {A}, string -> M A. + +(* A monad with errors *) +Class MonadError M `{Monad M} `{MonadErrorOp M} : Prop := + { errorM_bindM : forall A B str (f:A -> M B), errorM str >>= f ~= errorM str }. + + +(** Monads with Fixed-points **) + +(* The domain ordering for a fixed-point monad *) +Class MonadLeqOp (M:Type -> Type) : Type := + leqM : forall {A}, M A -> M A -> Prop. + +(* The class for the fixed-point operation *) +Class MonadFixOp (M:Type -> Type) : Type := + fixM : forall {A B}, ((forall (a:A), M (B a)) -> (forall (a:A), M (B a))) -> + (forall (a:A), M (B a)). + +(* Typeclass for dependent functions that respect the domain order *) +(* FIXME: this doesn't need to be a typeclass *) +Class ProperFixFun {A B M} `{MonadLeqOp M} + (F:(forall (a:A), M (B a)) -> (forall (a:A), M (B a))) : Prop := + { properFixFun : forall f1 f2, (forall a, leqM (f1 a) (f2 a)) -> + (forall a, leqM (F f1 a) (F f2 a)) }. + +Class MonadFix M `{Monad M} `{MonadLeqOp M} `{MonadFixOp M} : Prop := + { PreOrder_leqM :> forall A, PreOrder (leqM (A:=A)); + (* FIXME: does this need Properness of F? + Proper_fixM :> forall A B, + Proper (((eq ==> eqM) ==> eq ==> eqM) ==> eq ==> eqM) (fixM (A:=A) (B:=B)); *) + eqM_leqM : forall A (m1 m2:M A), m1 ~= m2 <-> leqM m1 m2 /\ leqM m2 m1; + fixM_F_fixM : forall A (B:A -> Type) (F:(forall a, M (B a)) -> (forall a, M (B a))) + {prp:ProperFixFun F} a, + eqM (fixM F a) (F (fixM F) a) + }. + + +(*** + *** The Set Monad + ***) + +(* The set monad = the sets over a given type *) +Definition SetM (A:Type) : Type := A -> Prop. + +(* Equivalence of two sets = they contain the same elements *) +Instance MonadEqOp_SetM : MonadEqOp SetM := + fun A m1 m2 => forall a, m1 a <-> m2 a. + +Instance Equivalence_SetM_eqM A : Equivalence (@eqM SetM _ A). +Proof. + split. + { intros m a; reflexivity. } + { intros m1 m2 eq_m a. symmetry. apply eq_m. } + { intros m1 m2 m3 eq12 eq23 a. transitivity (m2 a); [ apply eq12 | apply eq23 ]. } +Qed. + +(* Return for the set monad = the set with a single element *) +Instance MonadReturnOp_SetM : MonadReturnOp SetM := + fun A a a' => a = a'. + +(* Bind for the set monad = set map + union *) +Instance MonadBindOp_SetM : MonadBindOp SetM := + fun A B m f b => exists2 a, m a & f a b. + +Instance Monad_SetM : Monad SetM. +Proof. + split; intros. + { typeclasses eauto. } + { intros m1 m2 Rm f1 f2 Rf b; split; unfold bindM; intros [ a in_m in_fa ]; + exists a; try (apply Rm; assumption); + try apply (Rf a); assumption. } + { split; unfold bindM, returnM; intro. + { destruct H as [ x in_a in_fa ]. rewrite in_a. assumption. } + { exists a; [ reflexivity | assumption ]. } } + { split; unfold bindM, returnM; intro. + { destruct H as [ x in_a in_fa ]. rewrite <- in_fa. assumption. } + { exists a; [ assumption | reflexivity ]. } } + { split; unfold bindM; intro. + { destruct H as [ y [ x in_m in_fx ] in_gy ]. exists x; try assumption. + exists y; assumption. } + { destruct H as [ x in_m [ y in_fx in_gy ]]. exists y; try assumption. + exists x; assumption. } } +Qed. + + +Instance MonadLeqOp_SetM : MonadLeqOp SetM := + fun A m1 m2 => forall a, m1 a -> m2 a. + +(* The class for the fixed-point operation *) +Instance MonadFixOp_SetM : MonadFixOp SetM := + fun A B F a b => forall f, (forall a', leqM (F f a') (f a')) -> f a b. + +(* Helper for splitting eqM on SetM into to leqM requirements *) +Lemma split_SetM_eqM A (m1 m2:SetM A) : leqM m1 m2 -> leqM m2 m1 -> eqM m1 m2. +Proof. + intros l12 l21 a; split; [ apply l12 | apply l21 ]. +Qed. + +(* Helper for proving that fixM is a fixed-point: that fixM F is F-closed *) +Lemma SetM_fixM_F_closed {A B} F {prp:ProperFixFun (A:=A) (B:=B) F} a : + leqM (F (fixM F) a) (fixM F a). +Proof. + intros b in_F_fixM f f_F_closed. apply f_F_closed. + refine (properFixFun (F:=F) (fixM F) f _ a _ in_F_fixM). + intros a' b' in_fixM_b'. apply (in_fixM_b' f f_F_closed). +Qed. + +(* Helper for proving that fixM is a fixed-point: that fixM F is <= any F-closed f *) +Lemma SetM_fixM_leq_F_closed A B (F:(forall (a:A), SetM (B a)) -> forall a, SetM (B a)) f : + (forall a, leqM (F f a) (f a)) -> forall a, leqM (fixM F a) (f a). +Proof. + intros f_F_closed a b fixM_ab. apply (fixM_ab f f_F_closed). +Qed. + + +Instance MonadFix_SetM : MonadFix SetM. +Proof. + split. + { intro A; split. + { intros m a m_a; assumption. } + { intros m1 m2 m3 l12 l23 a m1_a. apply l23. apply l12. assumption. } } + (* FIXME: finish proving that fixM is Proper + { intros A B F1 F2 RF a1 a2 Ra b. rewrite Ra. + split; intro Fab; apply Fab; intros a' b' F_fixM_a'b'. + { apply Fab. *) + { intros A m1 m2; split. + { intros eq12; split; intro a; destruct (eq12 a); assumption. } + { intros [leq12 leq21] a; split; [ apply leq12 | apply leq21 ]. } } + { intros A B F prp a. apply split_SetM_eqM. + { revert a. apply SetM_fixM_leq_F_closed. intro a. + apply properFixFun. intro a'. apply SetM_fixM_F_closed. assumption. } + { apply SetM_fixM_F_closed. assumption. } } +Qed. + + +(*** + *** The Option Monad Transformer + ***) + +(* The option transformer just adds "option" around the type A *) +Definition OptionT (M:Type -> Type) (A:Type) : Type := M (option A). + +(* Equivalence in OptionT is just the underlying equivlence *) +Instance MonadEqOp_OptionT M `{MonadEqOp M} : MonadEqOp (OptionT M) := + fun A m1 m2 => eqM (A:=option A) m1 m2. + +(* Return for the option monad = underlying return of Some *) +Instance MonadReturnOp_OptionT M `{MonadReturnOp M} : MonadReturnOp (OptionT M) := + fun A a => returnM (Some a). + +(* Bind for the option monad = pattern-match *) +Instance MonadBindOp_OptionT M `{MonadReturnOp M} `{MonadBindOp M} : MonadBindOp (OptionT M) := + fun A B m f => + bindM (A:=option A) m + (fun opt_a => + match opt_a with + | Some a => f a + | None => returnM None + end). + +Instance Monad_OptionT M `{Monad M} : Monad (OptionT M). +Proof. + split. + { intro A; apply (Equivalence_eqM (option A)). } + { intros A B m1 m2 Rm f1 f2 Rf. + apply (Proper_bindM (M:=M)); [ assumption | ]. + intros opt_a; destruct opt_a; [ apply Rf | ]; reflexivity. } + { intros. + unfold returnM, MonadReturnOp_OptionT, bindM, MonadBindOp_OptionT. + unfold eqM, MonadEqOp_OptionT. + rewrite (returnM_bindM (M:=M)). reflexivity. } + { intros. + unfold returnM, MonadReturnOp_OptionT, bindM, MonadBindOp_OptionT. + unfold eqM, MonadEqOp_OptionT. + etransitivity; [ | apply (bindM_returnM (M:=M)) ]. + apply Proper_bindM; [ reflexivity | ]. + intros opt; destruct opt; reflexivity. } + { intros. + unfold returnM, MonadReturnOp_OptionT, bindM, MonadBindOp_OptionT; + unfold eqM, MonadEqOp_OptionT. + rewrite (bindM_bindM (M:=M)). + apply Proper_bindM; [ reflexivity | ]. + intros opt_a; destruct opt_a. + { apply Proper_bindM; [ reflexivity | ]. + intros opt_b; destruct opt_b; reflexivity. } + { rewrite returnM_bindM. reflexivity. } } +Qed. + + +Instance MonadErrorOp_OptionT M `{MonadReturnOp M} : MonadErrorOp (OptionT M) := + fun A _ => returnM None. + +Instance MonadError_OptionT M `{Monad M} : MonadError (OptionT M). +Proof. + split. + { intros. + unfold errorM, MonadErrorOp_OptionT, bindM, MonadBindOp_OptionT. + rewrite returnM_bindM. reflexivity. } +Qed. + + +Instance MonadLeqOp_OptionT M `{MonadLeqOp M} : MonadLeqOp (OptionT M) := + fun A m1 m2 => leqM (M:=M) m1 m2. + +Instance MonadFixOp_OptionT M `{MonadFixOp M} : MonadFixOp (OptionT M) := + fun A B F a => fixM (M:=M) F a. + +Instance MonadFix_OptionT M `{MonadFix M} : MonadFix (OptionT M). +Proof. + split. + { intros A; apply (PreOrder_leqM (M:=M)). } + { intros. apply (eqM_leqM (M:=M)). } + { intros. apply (fixM_F_fixM (M:=M) _ (fun a => option (B a))). + constructor. apply (properFixFun (ProperFixFun:=prp)). } +Qed. + + +(*** + *** The Set of Sets Monad + ***) + +(* +FIXME: can we get this to work as a predicate monad for SetM? +- The hard part is defining bindM: the current version fails associativity + because it requires finding a choice function +- I could imagine P >> Q is the union over all Q a for any a in mA in P, or the + union_(s in P) (intersection_(a in s) (Q a)) +- But all of these have issues! +- e.g., if P contains the empty set, so should P >>= Q! + +(* A SetSetM computation is a set of subsets of a type *) +Definition SetSetM (A:Type) := SetM A -> Prop. + +(* Close off a SetSetM under extensional equivalence *) +Definition inSetSetM {A} (P:SetSetM A) : SetSetM A := + fun m => exists2 m', m' ~= m & P m'. + +(* Equivalence of two sets = they contain the same elements *) +Instance MonadEqOp_SetSetM : MonadEqOp SetSetM := + fun A P1 P2 => forall m, inSetSetM P1 m <-> inSetSetM P2 m. + +Instance Proper_eqM_inSetSetM {A} : + Proper (eqM ==> eqM ==> iff) (inSetSetM (A:=A)). +Proof. + intros P1 P2 eqP m1 m2 eqm. + split; intros [ m' eq_m' in_m' ]; apply eqP; exists m'; try assumption. + - transitivity m1; assumption. + - transitivity m2; [ | symmetry ]; assumption. +Qed. + +Instance Equivalence_SetSetM_eqM A : Equivalence (eqM (M:=SetSetM) (A:=A)). +Proof. + split. + { intros m a; reflexivity. } + { intros m1 m2 eq_m a. symmetry. apply eq_m. } + { intros m1 m2 m3 eq12 eq23 a. etransitivity; [ apply eq12 | apply eq23 ]. } +Qed. + +Instance MonadReturnOp_SetSetM : MonadReturnOp SetSetM := + fun A a m => m ~= returnM a. + +Lemma SetSetM_returnM A (m:SetM A) a : + inSetSetM (returnM a) m <-> m ~= returnM a. +Proof. + split. + - intros [ m' eq_m' in_P ]. transitivity m'; [ symmetry; assumption | apply in_P ]. + - intro e_m; exists (returnM a); [ symmetry; assumption | intro; reflexivity ]. +Qed. + +Instance MonadBindOp_SetSetM : MonadBindOp SetSetM := + fun A B P Q m => + exists2 mA, inSetSetM P mA & + exists2 f, (forall a, mA a -> inSetSetM (Q a) (f a)) & + m ~= mA >>= f. + +Lemma SetSetM_bindM_elim {A B P} {Q:A -> SetSetM B} {m} : + inSetSetM (P >>= Q) m -> + exists2 mA, inSetSetM P mA & + exists2 f, (forall a, mA a -> inSetSetM (Q a) (f a)) & m ~= mA >>= f. +Proof. + intros [ m' eq_m [ mA in_P_mA [ f in_Q_f eq_m' ]]]. + exists mA; [ assumption | ]. + exists f; [ apply in_Q_f | ]. + rewrite <- eq_m; assumption. +Qed. + + +Lemma SetSetM_bindM_intro {A B P} {Q:A -> SetSetM B} {m} mA f : + inSetSetM P mA -> (forall a, mA a -> inSetSetM (Q a) (f a)) -> m ~= mA >>= f -> + inSetSetM (P >>= Q) m. +Proof. + intros [ mA' eq_mA in_mA' ] in_Q_f eq_m. + exists (mA >>= f); [ symmetry; assumption | ]. + exists mA; [ exists mA'; assumption | ]. + exists f; [ | reflexivity ]. apply in_Q_f. +Qed. + +Instance Monad_SetSetM : Monad SetSetM. +Proof. + split; intros. + { typeclasses eauto. } + { intros P1 P2 RP Q1 Q2 RQ m; split; + intros [ m' eq_m [ mA in_P_mA [ f in_Q_f eq_m' ] ] ]; + exists m'; try assumption; exists mA; try (apply RP; assumption); + exists f; try assumption; + intros a in_mA; apply (RQ a a eq_refl); apply in_Q_f; assumption. } + { intro m; split. + { intro in_m. + destruct (SetSetM_bindM_elim in_m) as [ mA in_mA [ g in_g eq_m ]]. + rewrite eq_m. + rewrite SetSetM_returnM in in_mA. rewrite in_mA. rewrite returnM_bindM. + apply in_g. rewrite (in_mA a). apply eq_refl. } + { intro in_m. apply (SetSetM_bindM_intro (returnM a) (fun _ => m)). + - apply SetSetM_returnM; reflexivity. + - intros a' eq_a_a'; compute in eq_a_a'. rewrite <- eq_a_a'. assumption. + - rewrite returnM_bindM. reflexivity. } } + { intro s; split. + { intro in_s. + destruct (SetSetM_bindM_elim in_s) as [ mA in_mA [ g in_g eq_s ]]. + assert (eq_s_mA : s ~= mA); [ | rewrite eq_s_mA; assumption ]. + transitivity (mA >>= g); [ assumption | ]. + transitivity (mA >>= returnM); [ | apply bindM_returnM ]. + intro a; split; intros [ a' in_a' in_f_a' ]; exists a'; try assumption. + - destruct (in_g a' in_a') as [ s' eq_s' in_s']. + rewrite <- (in_s' a). rewrite (eq_s' a). assumption. + - destruct (in_g a' in_a') as [ s' eq_s' in_s']. + rewrite <- (eq_s' a). apply in_s'. assumption. } + { intros [ s' eq_s' in_m_s' ]. exists s'; [ assumption | ]. + exists s'; [ exists s'; [ reflexivity | assumption ] | ]. + exists returnM; [ | symmetry; apply bindM_returnM ]. + intros a in_s'. exists (returnM a); [ reflexivity | ]. + intro a'; reflexivity. } } + { intro sC; split; intro in_sC. + { destruct (SetSetM_bindM_elim in_sC) as [ sB in_sB [ sg in_sg eq_sC ]]. + destruct (SetSetM_bindM_elim in_sB) as [ sA in_sA [ sf in_sf eq_sB ]]. + apply (SetSetM_bindM_intro sA (fun x => sf x >>= sg)); try assumption; + [ | rewrite eq_sC; rewrite eq_sB; rewrite bindM_bindM; reflexivity ]. + intros a in_a. + apply (SetSetM_bindM_intro (sf a) sg); [ apply in_sf; assumption | | reflexivity ]. + intros b in_b. apply in_sg. rewrite (eq_sB b). + exists a; assumption. } + { destruct (SetSetM_bindM_elim in_sC) as [ sA in_sA [ sfg in_sfg eq_sC ]]. + apply (SetSetM_bindM_intro sA sfg). + + + admit. } } + + apply (SetSetM_bindM_intro sA sfg); try assumption. + + destruct (SetSetM_bindM_elim in_sB) as [ sA in_sA [ sf in_sf eq_sB ]]. + + intros [ sC' eq_sC' [ sB [ sB' eq_sB' [ sA eq_sA in_sA ] ] eq_sB ] ]. destruct in_sC'. + *) + + +(*** + *** The Computation Monad = the Option-Set Monad + ***) + +Definition CompM : Type -> Type := OptionT SetM. + + +(*** + *** Letrec and Mutual Fixed-points in CompM + ***) + +(* An inductive description of a type A1 -> A2 -> ... -> An -> CompM B *) +Inductive LetRecType : Type := +| LRT_Ret (B:Type) : LetRecType +| LRT_Fun (A:Type) (lrtF:A -> LetRecType) : LetRecType +. + +(* Convert a LetRecType to the type it represents *) +Fixpoint lrtToType (lrt:LetRecType) : Type := + match lrt with + | LRT_Ret B => CompM B + | LRT_Fun A lrtF => forall a, lrtToType (lrtF a) + end. + +(* Convert the argument types of a LetRecType to their "flat" version of the +form { x1:A1 & { x2:A2 & ... { xn:An & unit } ... }} *) +Fixpoint lrtToFlatArgs (lrt:LetRecType) : Type := + match lrt with + | LRT_Ret _ => unit + | LRT_Fun A lrtF => sigT (fun (a:A) => lrtToFlatArgs (lrtF a)) + end. + +(* Get the dependent return type fun (args:lrtToFlatArgs) => B x.1 ... of +a LetRecType in terms of the flat arguments *) +Fixpoint lrtToFlatRet (lrt:LetRecType) : lrtToFlatArgs lrt -> Type := + match lrt return lrtToFlatArgs lrt -> Type with + | LRT_Ret B => fun _ => B + | LRT_Fun A lrtF => + fun args => lrtToFlatRet (lrtF (projT1 args)) (projT2 args) + end. + +(* Extract out the "flat" version of a LetRecType *) +Definition lrtToFlatType lrt := + forall (args:lrtToFlatArgs lrt), CompM (lrtToFlatRet lrt args). + +(* "Flatten" a function described by a LetRecType *) +Fixpoint flattenLRTFun lrt : lrtToType lrt -> lrtToFlatType lrt := + match lrt return lrtToType lrt -> lrtToFlatType lrt with + | LRT_Ret _ => fun f _ => f + | LRT_Fun A lrtF => + fun f args => flattenLRTFun (lrtF (projT1 args)) (f (projT1 args)) (projT2 args) + end. + +(* "Unflatten" a function described by a LetRecType *) +Fixpoint unflattenLRTFun lrt : lrtToFlatType lrt -> lrtToType lrt := + match lrt return lrtToFlatType lrt -> lrtToType lrt with + | LRT_Ret _ => fun f => f tt + | LRT_Fun A lrtF => + fun f a => unflattenLRTFun (lrtF a) (fun args => f (existT _ a args)) + end. + +(* A list of types (FIXME: use a Coq list?) *) +Inductive LetRecTypes : Type := +| LRT_Nil : LetRecTypes +| LRT_Cons : LetRecType -> LetRecTypes -> LetRecTypes +. + +(* Construct type type (F1, (F2, ... (Fn, unit) .. )) from a LetRecTypes list of +descriptions of the types F1, ..., Fn *) +Fixpoint lrtTupleType (lrts:LetRecTypes) : Type := + match lrts with + | LRT_Nil => unit + | LRT_Cons lrt lrts' => prod (lrtToType lrt) (lrtTupleType lrts') + end. + +(* Construct type type F1 -> ... -> Fn -> B from a LetRecTypes list of +descriptions of the types F1, ..., Fn *) +Fixpoint lrtPi (lrts:LetRecTypes) (B:Type) : Type := + match lrts with + | LRT_Nil => B + | LRT_Cons lrt lrts' => lrtToType lrt -> lrtPi lrts' B + end. + +(* Construct a multi-arity function of type lrtPi lrts B from one of type +lrtTupleType lrts -> B *) +Fixpoint lrtLambda {lrts B} : (lrtTupleType lrts -> B) -> lrtPi lrts B := + match lrts return (lrtTupleType lrts -> B) -> lrtPi lrts B with + | LRT_Nil => fun F => F tt + | LRT_Cons _ lrts' => fun F f => lrtLambda (fun fs => F (f, fs)) + end. + +(* Apply a multi-arity function of type lrtPi lrts B to an lrtTupleType lrts *) +Fixpoint lrtApply {lrts B} : lrtPi lrts B -> lrtTupleType lrts -> B := + match lrts return lrtPi lrts B -> lrtTupleType lrts -> B with + | LRT_Nil => fun F _ => F + | LRT_Cons _ lrts' => fun F fs => lrtApply (F (fst fs)) (snd fs) + end. + +(* Build a multi-argument fixed-point of type A1 -> ... -> An -> CompM B *) +Definition multiArgFixM (lrt:LetRecType) (F:lrtToType lrt -> + lrtToType lrt) : lrtToType lrt := + unflattenLRTFun + lrt + (fixM (fun f => flattenLRTFun lrt (F (unflattenLRTFun lrt f)))). + +(* Construct a mutual fixed-point over tuples of LRT functions *) +Fixpoint multiTupleFixM (lrts:LetRecTypes) : (lrtTupleType lrts -> lrtTupleType lrts) -> + lrtTupleType lrts := + match lrts return (lrtTupleType lrts -> lrtTupleType lrts) -> lrtTupleType lrts with + | LRT_Nil => fun _ => tt + | LRT_Cons lrt lrts' => + fun F => + let f1 := multiArgFixM lrt (fun f => fst (F (f, multiTupleFixM lrts' (fun fs => snd (F (f, fs)))))) in + (f1, multiTupleFixM lrts' (fun fs => snd (F (f1, fs)))) + end. + +(* A nicer version of multiTupleFixM that abstracts the functions one at a time *) +Definition multiFixM {lrts:LetRecTypes} + (F:lrtPi lrts (lrtTupleType lrts)) : lrtTupleType lrts := + multiTupleFixM lrts (fun fs => lrtApply F fs). + +(* A letrec construct for binding 0 or more mutually recursive functions *) +Definition letRecM {lrts : LetRecTypes} {B} (F: lrtPi lrts (lrtTupleType lrts)) + (body:lrtPi lrts (CompM B)) : CompM B := + lrtApply body (multiFixM F). + + +(*** + *** Refinement Proofs + ***) + +Definition refinesM {A} (m1 m2:CompM A) : Prop := forall a, m1 a -> m2 a. + +Infix "|=" := refinesM (at level 70, no associativity). + +Instance PreOrder_refinesM A : PreOrder (refinesM (A:=A)). +Proof. + split. + { intros m a in_a; assumption. } + { intros m1 m2 m3 R12 R23 a in_m1. apply R23. apply R12. assumption. } +Qed. + +Instance Proper_eqM_refinesM A : Proper (eqM ==> eqM ==> iff) (refinesM (A:=A)). +Proof. + intros m1 m1' e1 m2 m2' e2. + split; intros R12 a in_a; apply e2; apply R12; apply e1; assumption. +Qed. + +Instance Proper_refinesM_bindM A B : + Proper (refinesM ==> (pointwise_relation A refinesM) ==> refinesM) (bindM (A:=A) (B:=B)). +Proof. + intros m1 m2 Rm f1 f2 Rf opt_b [ opt_a in_opt_a in_opt_b ]. + exists opt_a; [ apply Rm; assumption | ]. + destruct opt_a; [ | assumption ]. + apply (Rf a); assumption. +Qed. + +Lemma refinesM_returnM A (a1 a2:A) : a1 = a2 -> returnM a1 |= returnM a2. +Proof. + intro e; rewrite e. reflexivity. +Qed. + +Lemma refinesM_errorM_returnM A s (a:A) : ~ errorM s |= returnM a. +Proof. + intro H; vm_compute in H. + apply (fun H => H None eq_refl) in H. + discriminate H. +Qed. + +Lemma refinesM_returnM_errorM A (a:A) s : ~ returnM a |= errorM s. +Proof. + intro H; vm_compute in H. + apply (fun H => H (Some a) eq_refl) in H. + discriminate H. +Qed. + +(* If a monadic function f is F-closed w.r.t. the refinement relation, then the +least fixed-point of F refines f *) +Lemma refinesM_fixM_l A B (F : (forall (a:A), CompM (B a)) -> + (forall (a:A), CompM (B a))) f : + (forall a, F f a |= f a) -> forall a, fixM F a |= f a. +Proof. + intros F_closed a opt_b in_fix. + apply in_fix. intros a' opt_b' in_F. apply F_closed. apply in_F. +Qed. + +Lemma refinesM_fixM_lr A B (F G : (forall (a:A), CompM (B a)) -> + (forall (a:A), CompM (B a))) : + (forall f a, F f a |= G f a) -> forall a, fixM F a |= fixM G a. +Proof. + intros leq_FG a opt_b in_fixF f G_closed. + apply (refinesM_fixM_l _ _ F); [ | assumption ]. + intros a' opt_b' in_F. apply G_closed. apply leq_FG. assumption. +Qed. + +(* Lift refinesM to monadic functions *) +Fixpoint refinesFun {lrt} : relation (lrtToType lrt) := + match lrt return relation (lrtToType lrt) with + | LRT_Ret B => refinesM + | LRT_Fun A lrtF => forall_relation (fun a => @refinesFun (lrtF a)) + end. + +Instance PreOrder_refinesFun lrt : PreOrder (@refinesFun lrt). +Proof. + induction lrt. + - apply PreOrder_refinesM. + - split. + { intros f a. reflexivity. } + { intros f1 f2 f3 H1 H2 a. transitivity (f2 a); [ apply H1 | apply H2 ]. } +Qed. + +Instance subrelation_forall_const_pointwise A B (R : relation B) + : subrelation (forall_relation (fun _ => R)) (pointwise_relation A R). +Proof. vm_compute; auto. Qed. + +(* A convenient specialization of refinesFun *) +Definition refinesFun1 {A} {B:A -> Type} : (forall a, CompM (B a)) -> (forall a, CompM (B a)) -> Prop := + refinesFun (lrt:=LRT_Fun _ (fun _ => LRT_Ret _)). + +(* Lift refinesM to tuples of monadic functions *) +Fixpoint refinesFunTuple {lrts} : relation (lrtTupleType lrts) := + match lrts return relation (lrtTupleType lrts) with + | LRT_Nil => fun _ _ => True + | LRT_Cons lrt lrts' => + fun tup1 tup2 => refinesFun (fst tup1) (fst tup2) /\ + refinesFunTuple (snd tup1) (snd tup2) + end. + +Fixpoint respectfulLRTPi {lrts} {B} : relation (lrtPi lrts (CompM B)) := + match lrts with + | LRT_Nil => refinesM + | LRT_Cons _ _ => respectful refinesFun respectfulLRTPi + end. + +(* `ProperLRTFun F` is just `Proper (refinesFun ==> ... ==> refinesFun ==> refinesM) F` *) +Class ProperLRTFun {lrts} {B} (F : lrtPi lrts (CompM B)) : Prop := + { properLRTFun : Proper respectfulLRTPi F }. + +(* All constant functions are proper *) +Instance ProperLRTFun_const lrts B b : @ProperLRTFun lrts B (lrtLambda (fun _ => b)). +Proof. + split; induction lrts; vm_compute; intros; assumption. +Qed. + +(* FIXME Get rid of this *) +Instance ProperLRTFun_any lrts B F : @ProperLRTFun lrts B F. +Proof. + admit. (* FIXME *) +Admitted. + +Instance Proper_lrtApply lrts B + : Proper (respectfulLRTPi ==> refinesFunTuple ==> refinesM) (@lrtApply lrts (CompM B)). +Proof. + unfold Proper, respectful; intros F G H1 fs gs H2. + induction lrts; simpl in F,G,H1,fs,gs,H2; simpl. + - exact H1. + - destruct fs as [f fs]; destruct gs as [g gs]; destruct H2 as [H2 H3]; simpl in *. + apply IHlrts. + + unfold respectful in H1. + apply H1. + assumption. + + assumption. +Qed. + +Lemma refinesFunTuple_multiFixM lrts (F:lrtPi lrts (lrtTupleType lrts)) tup : + refinesFunTuple (lrtApply F tup) tup -> refinesFunTuple (multiFixM F) tup. +Proof. + admit. (* FIXME *) +Admitted. + +Lemma refinesFun_multiFixM_fst lrt (F:lrtPi (LRT_Cons lrt LRT_Nil) + (lrtTupleType (LRT_Cons lrt LRT_Nil))) f + (ref_f:refinesFun (fst (F f)) f) : + refinesFun (fst (multiFixM F)) f. +Proof. + refine (proj1 (refinesFunTuple_multiFixM (LRT_Cons lrt LRT_Nil) _ (f, tt) _)). + split; [ | constructor ]. + apply ref_f. +Qed. + +Lemma letRecM_Nil B F P : @letRecM LRT_Nil B F P = P. +Proof. + reflexivity. +Qed. + +Lemma refinesM_letRecM_Nil_l B F P Q : P |= Q -> @letRecM LRT_Nil B F P |= Q. +Proof. + rewrite letRecM_Nil. trivial. +Qed. + +Lemma multiFixM_const lrts fs + : multiFixM (lrts:=lrts) (lrtLambda (fun _ => fs)) = fs. +Proof. + admit. (* FIXME *) +Admitted. + +Lemma refinesM_letRecM_const_r lrts B (F : lrtPi lrts (lrtTupleType lrts)) + (G : lrtTupleType lrts) (P Q : lrtPi lrts (CompM B)) + `{ProperLRTFun _ _ P} `{ProperLRTFun _ _ Q} + : refinesFunTuple (multiFixM F) G -> + lrtApply P G |= lrtApply Q G -> + @letRecM lrts B F P |= @letRecM lrts B (lrtLambda (fun _ => G)) Q. +Proof. + destruct H as [ProperP]; destruct H0 as [ProperQ]. + intros. + unfold letRecM. + rewrite H, H0, multiFixM_const. + reflexivity. +Qed. + +Lemma lrtApply_const lrts B (b : B) (F : lrtTupleType lrts) + : lrtApply (lrts:=lrts) (lrtLambda (fun _ => b)) F = b. +Proof. + induction lrts. + - reflexivity. + - destruct F as [ F0 F1 ]. + simpl; rewrite (IHlrts F1). + reflexivity. +Qed. + +Lemma refinesM_letRecM_match_r lrts B F P Q `{ProperLRTFun _ _ P} + : forall (G : lrtTupleType lrts), + @letRecM lrts B F P |= @letRecM lrts B (lrtLambda (fun _ => G)) (lrtLambda (fun _ => Q)) -> + @letRecM lrts B F P |= Q. +Proof. + intros. + rewrite H0. + unfold letRecM. + rewrite lrtApply_const. + reflexivity. +Qed. + +Lemma refinesM_if_l {A} (m1 m2:CompM A) b P : + (b = true -> m1 |= P) -> (b = false -> m2 |= P) -> + (if b then m1 else m2) |= P. +Proof. + intros ref1 ref2; destruct b; [ apply ref1 | apply ref2 ]; reflexivity. +Qed. + +Lemma refinesM_if_r {A} (m1 m2:CompM A) b P : + (b = true -> P |= m1) -> (b = false -> P |= m2) -> + P |= (if b then m1 else m2). +Proof. + intros ref1 ref2; destruct b; [ apply ref1 | apply ref2 ]; reflexivity. +Qed. + +Lemma simpl_letRecM0 B F body : @letRecM LRT_Nil B F body = body. +Proof. + reflexivity. +Qed. + +Lemma refinesM_sigT_rect_l {A1 A2 B} F P (s: {x:A1 & A2 x}) : + (forall a1 a2, s = existT _ a1 a2 -> F a1 a2 |= P) -> + sigT_rect (fun _ => CompM B) F s |= P. +Proof. + destruct s; intros. + apply H. reflexivity. +Qed. + +Lemma refinesM_sigT_rect_r {A1 A2 B} F P (s: {x:A1 & A2 x}) : + (forall a1 a2, s = existT _ a1 a2 -> P |= F a1 a2) -> + P |= sigT_rect (fun _ => CompM B) F s. +Proof. + destruct s; intros. + apply H. reflexivity. +Qed. + + +(** Existential Specifications **) + +Definition existsM {A B} (P: A -> CompM B) : CompM B := + fun b => exists a, P a b. + +Lemma refinesM_existsM_r {A B} (P: A -> CompM B) m a : + m |= (P a) -> m |= (existsM P). +Proof. + intros r b in_b. exists a. apply r. assumption. +Qed. + +Lemma refinesM_existsM_l A B (P: A -> CompM B) Q : + (forall a, P a |= Q) -> existsM P |= Q. +Proof. + intros r b [ a in_b ]. apply (r a). assumption. +Qed. + +Lemma refinesM_existsM_lr A B (P Q : A -> CompM B) : + (forall a, P a |= Q a) -> existsM P |= existsM Q. +Proof. + intros r b [ a in_b ]. exists a. apply r. assumption. +Qed. + +Lemma existsM_bindM A B C (P: A -> CompM B) (Q: B -> CompM C) : + (existsM P) >>= Q ~= existsM (fun x => P x >>= Q). +Proof. + intros c; split. + - intros [ opt_b [ a in_b ] in_c ]. exists a. exists opt_b; assumption. + - intros [ a [ opt_b in_b in_c ] ]. exists opt_b; [ | assumption ]. + exists a; assumption. +Qed. + +Definition noErrorsSpec {A} : CompM A := existsM (fun a => returnM a). +Arguments noErrorsSpec /. + + +(** Universal Specifications **) + +Definition forallM {A B} (P: A -> CompM B) : CompM B := + fun b => forall a, P a b. + +Lemma refinesM_forallM_r {A B} P (Q: A -> CompM B) : + (forall a, P |= (Q a)) -> P |= (forallM Q). +Proof. + intros r b in_b a. apply r. assumption. +Qed. + +Lemma refinesM_forallM_l {A B} (P: A -> CompM B) Q a : + P a |= Q -> forallM P |= Q. +Proof. + intros r b in_b. apply r. apply in_b. +Qed. + +(* NOTE: the other direction does not hold *) +Lemma forallM_bindM A B C (P: A -> CompM B) (Q: B -> CompM C) : + refinesM ((forallM P) >>= Q) (forallM (fun x => P x >>= Q)). +Proof. + intros c [ opt_b H ] a. exists opt_b; [ apply (H _) | assumption ]. +Qed. + + +(** Conjuctive and disjunctive specifications **) + +Definition orM {A} (m1 m2 : CompM A) : CompM A := + fun b => m1 b \/ m2 b. + +Lemma refinesM_orM_r {A} (m1 m2 : CompM A) P : + P |= m1 \/ P |= m2 -> P |= (orM m1 m2). +Proof. + intros r b in_b; destruct r; [ left | right ]; apply H; assumption. +Qed. + +Lemma refinesM_orM_l {A} (m1 m2 : CompM A) P : + m1 |= P -> m2 |= P -> orM m1 m2 |= P. +Proof. + intros r1 r2 b in_b; destruct in_b; [ apply r1 | apply r2 ]; assumption. +Qed. + +Lemma orM_bindM A B (m1 m2 : CompM A) (P : A -> CompM B) : + (orM m1 m2) >>= P ~= orM (m1 >>= P) (m2 >>= P). +Proof. + intros c; split. + - intros [ opt_b [ r1 | r2 ] in_c ]; [ left | right ]; exists opt_b; assumption. + - intros [ [ opt_b in_b in_c ] | [ opt_b in_b in_c ] ]; (exists opt_b; [ | assumption ]); + [ left | right ]; assumption. +Qed. + +Definition andM {A} (m1 m2:CompM A) : CompM A := + fun b => m1 b /\ m2 b. + +Lemma refinesM_andM_r {A} (m1 m2 : CompM A) P : + P |= m1 -> P |= m2 -> P |= andM m1 m2. +Proof. + intros r1 r2 b in_b. split; [ apply r1 | apply r2 ]; assumption. +Qed. + +Lemma refinesM_andM_l {A} (m1 m2 : CompM A) P : + m1 |= P \/ m2 |= P -> andM m1 m2 |= P. +Proof. + intros r b in_b; destruct r; destruct in_b; apply H; assumption. +Qed. + +Lemma andM_bindM A B (m1 m2 : CompM A) (P : A -> CompM B) : + refinesM ((andM m1 m2) >>= P) (andM (m1 >>= P) (m2 >>= P)). +Proof. + intros c [ opt_b [ r1 r2 ] in_c ]; split; exists opt_b; assumption. +Qed. + + +(** Assertions and Assumptions **) + +Definition assertM (P:Prop) : CompM unit := + existsM (fun pf:P => returnM tt). + +Definition assertM_eq (P:Prop) (pf:P) : assertM P ~= returnM tt. +Proof. + intro opt_a; split. + - intros [ _ H ]; assumption. + - intros H. exists pf. assumption. +Qed. + +Lemma refinesM_bindM_assertM_r {A} (P:Prop) (m1 m2: CompM A) : + P -> m1 |= m2 -> m1 |= assertM P >> m2. +Proof. + intro pf; rewrite (assertM_eq P pf). rewrite returnM_bindM. intro; assumption. +Qed. + +Lemma refinesM_bindM_assertM_l {A} (P:Prop) (m1 m2: CompM A) : + (P -> m1 |= m2) -> assertM P >> m1 |= m2. +Proof. + intro H. unfold assertM; rewrite existsM_bindM. + apply refinesM_existsM_l. + rewrite returnM_bindM; assumption. +Qed. + +Definition assumingM {A} (P:Prop) (m:CompM A) : CompM A := + forallM (fun pf:P => m). + +Lemma refinesM_assumingM_r {A} (P:Prop) (m1 m2: CompM A) : + (P -> m1 |= m2) -> m1 |= assumingM P m2. +Proof. + apply refinesM_forallM_r. +Qed. + +Lemma refinesM_assumingM_l {A} (P:Prop) (m1 m2 : CompM A) : + P -> m1 |= m2 -> assumingM P m1 |= m2. +Proof. + apply refinesM_forallM_l. +Qed. diff --git a/saw-core-coq/coq/handwritten/CryptolToCoq/CompMExtra.v b/saw-core-coq/coq/handwritten/CryptolToCoq/CompMExtra.v new file mode 100644 index 0000000000..3c7c64cef6 --- /dev/null +++ b/saw-core-coq/coq/handwritten/CryptolToCoq/CompMExtra.v @@ -0,0 +1,548 @@ +(*** + *** Extra Proofs for CompM that Rely on SAWCorePrelude + ***) + +From Coq Require Import Logic. +From Coq Require Import Strings.String. +From CryptolToCoq Require Import SAWCorePrelude. +From CryptolToCoq Require Import SAWCoreScaffolding. +From CryptolToCoq Require Import SAWCoreVectorsAsCoqVectors. +From CryptolToCoq Require Import SAWCoreBitvectors. +From CryptolToCoq Require Export CompM. + +(*** + *** Some useful Ltac + ***) + +Ltac get_last_hyp tt := + match goal with H: _ |- _ => constr:(H) end. + +Tactic Notation "unfold_projs" := + unfold SAWCoreScaffolding.fst; + cbn [ Datatypes.fst Datatypes.snd projT1 ]. + +Tactic Notation "unfold_projs" "in" constr(N) := + unfold SAWCoreScaffolding.fst in N; + cbn [ Datatypes.fst Datatypes.snd projT1 ] in N. + +Tactic Notation "unfold_projs" "in" "*" := + unfold SAWCoreScaffolding.fst in *; + cbn [ Datatypes.fst Datatypes.snd projT1 ] in *. + +Ltac split_prod_goal := + repeat match goal with + | |- _ /\ _ => split + | |- { _ : _ & _ } => split + | |- _ * _ => split + | |- unit => exact tt + | |- True => trivial + end. + + +(*** + *** Extra lemmas about refinement that rely on SAWCorePrelude + ***) + +Lemma refinesM_either_l {A B C} (f:A -> CompM C) (g:B -> CompM C) eith P : + (forall a, eith = SAWCorePrelude.Left _ _ a -> f a |= P) -> + (forall b, eith = SAWCorePrelude.Right _ _ b -> g b |= P) -> + SAWCorePrelude.either _ _ _ f g eith |= P. +Proof. + destruct eith; intros; simpl. + - apply H; reflexivity. + - apply H0; reflexivity. +Qed. + +Lemma refinesM_either_r {A B C} (f:A -> CompM C) (g:B -> CompM C) eith P : + (forall a, eith = SAWCorePrelude.Left _ _ a -> P |= f a) -> + (forall b, eith = SAWCorePrelude.Right _ _ b -> P |= g b) -> + P |= SAWCorePrelude.either _ _ _ f g eith. +Proof. + destruct eith; intros; simpl. + - apply H; reflexivity. + - apply H0; reflexivity. +Qed. + +Lemma refinesM_maybe_l {A B} (x : CompM B) (f : A -> CompM B) mb P : + (mb = SAWCorePrelude.Nothing _ -> x |= P) -> + (forall a, mb = SAWCorePrelude.Just _ a -> f a |= P) -> + SAWCorePrelude.maybe _ _ x f mb |= P. +Proof. + destruct mb; intros; simpl. + - apply H; reflexivity. + - apply H0; reflexivity. +Qed. + +Lemma refinesM_maybe_r {A B} (x : CompM B) (f : A -> CompM B) mb P : + (mb = SAWCorePrelude.Nothing _ -> P |= x) -> + (forall a, mb = SAWCorePrelude.Just _ a -> P |= f a) -> + P |= SAWCorePrelude.maybe _ _ x f mb. +Proof. + destruct mb; intros; simpl. + - apply H; reflexivity. + - apply H0; reflexivity. +Qed. + +Lemma returnM_if A (b : bool) (x y : A) : + @returnM CompM _ A (if b then x else y) ~= if b then returnM x else returnM y. +Proof. destruct b. setoid_reflexivity. setoid_reflexivity. Qed. + +Lemma refinesM_returnM_if_l A (b : bool) (x y : A) P : + ((if b then returnM x else returnM y) |= P) -> + (returnM (if b then x else y) |= P). +Proof. rewrite returnM_if. trivial. Qed. + +Lemma refinesM_returnM_if_r A (b : bool) (x y : A) P : + (P |= (if b then returnM x else returnM y)) -> + (P |= returnM (if b then x else y)). +Proof. rewrite returnM_if. trivial. Qed. + +Lemma returnM_injective : forall (A : Type) (x y : A), + returnM (M:=CompM) x ~= returnM y -> x = y. +Proof. + intros. unfold returnM in H. unfold MonadReturnOp_OptionT in H. + unfold eqM in H. unfold MonadEqOp_OptionT in H. unfold eqM in H. unfold MonadEqOp_SetM in H. + assert (Some x = Some y) as Hxy. + { rewrite H. reflexivity. } + inversion Hxy; subst. reflexivity. +Qed. + + +(*** + *** Automation for proving refinement + ***) + +Create HintDb refinesM. +Create HintDb refinesFun. + +Hint Extern 999 (_ |= _) => shelve : refinesM. + +Hint Resolve refinesM_letRecM_Nil_l : refinesM. + +Hint Extern 1 (@letRecM ?lrts _ _ _ |= @letRecM ?lrts _ (lrtLambda (fun _ => _)) _) => + apply refinesM_letRecM_const_r; try apply ProperLRTFun_any; + try (apply refinesFunTuple_multiFixM; unfold refinesFunTuple; split_prod_goal); + unfold lrtApply, lrtLambda; unfold_projs : refinesM. + +Inductive ArgName := Any | Either | Maybe | SigT | If | Assert | Assuming | Exists | Forall. +Ltac argName n := + match n with + | Any => fresh "a" + | Either => fresh "e_either" + | Maybe => fresh "e_maybe" + | SigT => fresh "e_either" + | If => fresh "e_if" + | Assert => fresh "e_assert" + | Assuming => fresh "e_assuming" + | Exists => fresh "e_exists" + | Forall => fresh "e_forall" + end. + +Definition IntroArg (_ : ArgName) A (goal : A -> Prop) := forall a, goal a. + +Lemma IntroArg_fold n A goal : forall a, IntroArg n A goal -> goal a. +Proof. unfold IntroArg; intros a H; exact (H a). Qed. + +Lemma IntroArg_unfold n A (goal : A -> Prop) : (forall a, goal a) -> IntroArg n A goal. +Proof. unfold IntroArg; intro H; exact H. Qed. + +Lemma IntroArg_and n P Q (goal : P /\ Q -> Prop) + : IntroArg n P (fun p => IntroArg n Q (fun q => goal (conj p q))) -> IntroArg n _ goal. +Proof. unfold IntroArg; intros H [ p q ]; apply H. Qed. + +Lemma IntroArg_or n P Q (goal : P \/ Q -> Prop) + : IntroArg n P (fun p => goal (or_introl p)) -> + IntroArg n Q (fun q => goal (or_intror q)) -> IntroArg n _ goal. +Proof. unfold IntroArg; intros Hl Hr [ p | q ]; [ apply Hl | apply Hr ]. Qed. + +Lemma IntroArg_sigT n A P (goal : {a : A & P a} -> Prop) + : IntroArg n A (fun a => IntroArg n (P a) (fun p => goal (existT _ a p))) -> IntroArg n _ goal. +Proof. unfold IntroArg; intros H [ a p ]; apply H. Qed. + +Lemma IntroArg_prod n P Q (goal : P * Q -> Prop) + : IntroArg n P (fun p => IntroArg n Q (fun q => goal (pair p q))) -> IntroArg n _ goal. +Proof. unfold IntroArg; intros H [ p q ]; apply H. Qed. + +Lemma IntroArg_sum n P Q (goal : P + Q -> Prop) + : IntroArg n P (fun p => goal (inl p)) -> + IntroArg n Q (fun q => goal (inr q)) -> IntroArg n _ goal. +Proof. unfold IntroArg; intros Hl Hr [ p | q ]; [ apply Hl | apply Hr ]. Qed. + +Lemma IntroArg_unit n (goal : unit -> Prop) : goal tt -> IntroArg n _ goal. +Proof. unfold IntroArg; intros H []. apply H. Qed. + +Lemma IntroArg_eq_sigT_const n A B (a a' : A) (b b' : B) (goal : Prop) + : IntroArg n (a = a') (fun _ => IntroArg n (b = b') (fun _ => goal)) -> + IntroArg n (existT _ a b = existT _ a' b') (fun _ => goal). +Proof. + unfold IntroArg; intros H eq. + injection eq; intros. + apply H; assumption. +Qed. + +Hint Resolve IntroArg_and IntroArg_or IntroArg_sigT IntroArg_prod IntroArg_sum + IntroArg_unit IntroArg_eq_sigT_const | 1 : refinesFun. + +Hint Extern 2 (IntroArg ?n (@eq bool _ _) _) => + let e := fresh in + apply IntroArg_unfold; intro e; unfold_projs in e; + progress (compute_bv_funs in e; autorewrite with SAWCoreBitvectors in e); + apply (IntroArg_fold n _ _ e); clear e : refinesFun. + +Hint Extern 3 (IntroArg ?n (isBvsle _ _ _) _) => + let e := argName n in + let e' := fresh in + apply IntroArg_unfold; intro e; assert (e' := e); + unfold isBvsle in e'; try rewrite e'; clear e' : refinesFun. +Hint Extern 3 (IntroArg ?n (isBvslt _ _ _) _) => + let e := argName n in + let e' := fresh in + apply IntroArg_unfold; intro e; assert (e' := e); + unfold isBvslt in e'; try rewrite e'; clear e' : refinesFun. +Hint Extern 3 (IntroArg ?n (isBvule _ _ _) _) => + let e := argName n in + let e' := fresh in + apply IntroArg_unfold; intro e; assert (e' := e); + unfold isBvule in e'; try rewrite e'; clear e' : refinesFun. +Hint Extern 3 (IntroArg ?n (isBvult _ _ _) _) => + let e := argName n in + let e' := fresh in + apply IntroArg_unfold; intro e; assert (e' := e); + unfold isBvult in e'; try rewrite e'; clear e' : refinesFun. + +Hint Extern 3 (IntroArg ?n (@eq ?T _ _) _) => + let e := argName n in + apply IntroArg_unfold; intro e; unfold_projs in e; + (match T with + | bitvector _ => idtac + | _ => try discriminate e; unfold_projs; try rewrite e + end); + try (match T with + | Either _ _ => let e' := argName n in injection e; intro e'; try rewrite <- e' + | Maybe _ => let e' := argName n in injection e; intro e'; try rewrite <- e' + | {_ : _ & _ } => let e' := argName n in let e'' := argName n in + injection e; intros e' e''; clear e'; try rewrite <- e'' + end) : refinesFun. + +Hint Extern 4 (IntroArg ?n _ _) => + let e := argName n in + apply IntroArg_unfold; intro e; compute_bv_funs in e : refinesFun. + +Definition refinesM_either_l' {A B C} (f:A -> CompM C) (g:B -> CompM C) eith P : + (IntroArg Any _ (fun a => IntroArg Either (eith = SAWCorePrelude.Left _ _ a) (fun _ => f a |= P))) -> + (IntroArg Any _ (fun b => IntroArg Either (eith = SAWCorePrelude.Right _ _ b) (fun _ => g b |= P))) -> + SAWCorePrelude.either _ _ _ f g eith |= P := refinesM_either_l f g eith P. +Definition refinesM_either_r' {A B C} (f:A -> CompM C) (g:B -> CompM C) eith P : + (IntroArg Any _ (fun a => IntroArg Either (eith = SAWCorePrelude.Left _ _ a) (fun _ => P |= f a))) -> + (IntroArg Any _ (fun b => IntroArg Either (eith = SAWCorePrelude.Right _ _ b) (fun _ => P |= g b))) -> + P |= SAWCorePrelude.either _ _ _ f g eith := refinesM_either_r f g eith P. + +Hint Resolve refinesM_either_l' refinesM_either_r' | 1 : refinesM. + +Definition refinesM_maybe_l' {A B} (x : CompM B) (f : A -> CompM B) mb P : + (IntroArg Maybe (mb = SAWCorePrelude.Nothing _) (fun _ => x |= P)) -> + (IntroArg Any _ (fun a => IntroArg Maybe (mb = SAWCorePrelude.Just _ a) (fun _ => f a |= P))) -> + SAWCorePrelude.maybe _ _ x f mb |= P := refinesM_maybe_l x f mb P. +Definition refinesM_maybe_r' {A B} (x : CompM B) (f : A -> CompM B) mb P : + (IntroArg Maybe (mb = SAWCorePrelude.Nothing _) (fun _ => P |= x)) -> + (IntroArg Any _ (fun a => IntroArg Maybe (mb = SAWCorePrelude.Just _ a) (fun _ => P |= f a))) -> + P |= SAWCorePrelude.maybe _ _ x f mb := refinesM_maybe_r x f mb P. + +Hint Resolve refinesM_maybe_l' refinesM_maybe_r' | 1 : refinesM. + +Definition refinesM_sigT_rect_l' {A1 A2 B} F P (s: {x:A1 & A2 x}) : + (IntroArg Any _ (fun a1 => IntroArg Any _ (fun a2 => + IntroArg SigT (s = existT _ a1 a2) (fun _ => F a1 a2 |= P)))) -> + sigT_rect (fun _ => CompM B) F s |= P := refinesM_sigT_rect_l F P s. + +Definition refinesM_sigT_rect_r' {A1 A2 B} F P (s: {x:A1 & A2 x}) : + (IntroArg Any _ (fun a1 => IntroArg Any _ (fun a2 => + IntroArg SigT (s = existT _ a1 a2) (fun _ => P |= F a1 a2)))) -> + P |= sigT_rect (fun _ => CompM B) F s := refinesM_sigT_rect_r F P s. + +Hint Resolve refinesM_sigT_rect_l' refinesM_sigT_rect_r' | 1 : refinesM. + +Definition refinesM_if_l' {A} (m1 m2:CompM A) b P : + (IntroArg If (b = true) (fun _ => m1 |= P)) -> + (IntroArg If (b = false) (fun _ => m2 |= P)) -> + (if b then m1 else m2) |= P := refinesM_if_l m1 m2 b P. + +Definition refinesM_if_r' {A} (m1 m2:CompM A) b P : + (IntroArg If (b = true) (fun _ => P |= m1)) -> + (IntroArg If (b = false) (fun _ => P |= m2)) -> + P |= (if b then m1 else m2) := refinesM_if_r m1 m2 b P. + +Hint Resolve refinesM_if_l' refinesM_if_r' | 1 : refinesM. + +Hint Extern 1 (returnM (if _ then _ else _) |= _) => + apply refinesM_returnM_if_l : refinesM. +Hint Extern 1 (_ |= returnM (if _ then _ else _)) => + apply refinesM_returnM_if_r : refinesM. + +Definition refinesM_bindM_assertM_l' {A} (P:Prop) (m1 m2: CompM A) : + (IntroArg Assert P (fun _ => m1 |= m2)) -> assertM P >> m1 |= m2 := + refinesM_bindM_assertM_l P m1 m2. +Definition refinesM_assumingM_r' {A} (P:Prop) (m1 m2: CompM A) : + (IntroArg Assuming P (fun _ => m1 |= m2)) -> m1 |= assumingM P m2 := + refinesM_assumingM_r P m1 m2. + +Hint Resolve refinesM_bindM_assertM_l' refinesM_assumingM_r' | 1 : refinesM. + +Hint Extern 2 (_ |= assertM _ >> _) => + eapply refinesM_bindM_assertM_r; shelve : refinesM. +Hint Extern 2 (assumingM _ _ |= _) => + eapply refinesM_assumingM_l; shelve : refinesM. + +Definition refinesM_existsM_l' A B (P: A -> CompM B) Q : + (IntroArg Exists _ (fun a => P a |= Q)) -> existsM P |= Q := + refinesM_existsM_l A B P Q. +Definition refinesM_forallM_r' {A B} P (Q: A -> CompM B) : + (IntroArg Forall _ (fun a => P |= (Q a))) -> P |= (forallM Q) := + refinesM_forallM_r P Q. + +Hint Resolve refinesM_existsM_l' refinesM_forallM_r' | 2 : refinesM. + +(* Hint Extern 2 (existsM _ |= _) => apply refinesM_existsM_l; intro_destruct_prods_sums : refinesM. *) +(* Hint Extern 2 (_ |= forallM _) => apply refinesM_forallM_r; intro_destruct_prods_sums : refinesM. *) +Hint Extern 3 (_ |= existsM _) => eapply refinesM_existsM_r; shelve : refinesM. +Hint Extern 3 (forallM _ |= _) => eapply refinesM_forallM_l; shelve : refinesM. + +Hint Extern 3 (returnM _ |= returnM _) => + apply refinesM_returnM; (reflexivity || shelve) : refinesM. + +Hint Extern 1 (orM _ _ |= _) => apply refinesM_orM_l : refinesM. +Hint Extern 1 (_ |= andM _ _) => apply refinesM_andM_r : refinesM. +(* Hint Extern 99 (_ |= orM _ _) => apply refinesM_orM_r : refinesM. *) +(* Hint Extern 99 (andM _ _ |= _) => apply refinesM_andM_l : refinesM. *) + +Hint Extern 1 ((returnM _ >>= _) |= _) => rewrite returnM_bindM : refinesM. +Hint Extern 1 (_ |= (returnM _ >>= _)) => rewrite returnM_bindM : refinesM. +Hint Extern 1 ((existsM _ >>= _) |= _) => rewrite existsM_bindM : refinesM. +Hint Extern 1 (_ |= (existsM _ >>= _)) => rewrite existsM_bindM : refinesM. +Hint Extern 1 ((orM _ _ >>= _) |= _) => rewrite orM_bindM : refinesM. +Hint Extern 1 (_ |= (orM _ _ >>= _)) => rewrite orM_bindM : refinesM. +Hint Extern 1 ((errorM _ >>= _) |= _) => rewrite errorM_bindM : refinesM. +Hint Extern 1 (_ |= (errorM _ >>= _)) => rewrite errorM_bindM : refinesM. +Hint Extern 1 (((_ >>= _) >>= _) |= _) => rewrite bindM_bindM : refinesM. +Hint Extern 1 (_ |= ((_ >>= _) >>= _)) => rewrite bindM_bindM : refinesM. + +Create HintDb refinement_proofs. +Hint Extern 1 (_ _ >>= _ |= _) => + progress (try (rewrite_strat (outermost (hints refinement_proofs)))) : refinesM. + +(*** + *** Rewriting rules + ***) + +Lemma existT_eta A (B:A -> Type) (s: {a:A & B a}) : + existT B (projT1 s) (projT2 s) = s. +Proof. + destruct s; reflexivity. +Qed. + +Lemma existT_eta_unit A (s: {_:A & unit}) : existT (fun _ => unit) (projT1 s) tt = s. +Proof. + destruct s; destruct u; reflexivity. +Qed. + +Hint Rewrite existT_eta existT_eta_unit : refinesM. + +(* +Lemma function_eta A B (f:A -> B) : pointwise_relation A eq (fun x => f x) f. +Proof. + intro; reflexivity. +Qed. +*) + +(* Specialized versions of monad laws for CompM to make rewriting faster, +probably because Coq doesn't have to search for the instances...? *) + +Definition returnM_bindM_CompM A B (a:A) (f:A -> CompM B) : returnM a >>= f ~= f a := + returnM_bindM (M:=CompM) A B a f. + +Definition bindM_returnM_CompM A (m:CompM A) : m >>= (fun x => returnM x) ~= m := + bindM_returnM (M:=CompM) A m. + +Definition bindM_bindM_CompM A B C (m : CompM A) (f : A -> CompM B) (g : B -> CompM C) : + m >>= f >>= g ~= m >>= (fun x : A => f x >>= g) := + bindM_bindM (M:=CompM) A B C m f g. + +Hint Rewrite returnM_bindM_CompM bindM_returnM_CompM bindM_bindM_CompM : refinesM. + +(* +FIXME: do we need these rules? + +Lemma bvEq_sym n x y : bvEq n x y = bvEq n y x. + admit. +Admitted. + +From Coq Require Import Nat. + +Lemma bvEq_eqb n x y : bvEq n (bvNat n x) (bvNat n y) = eqb x y. + admit. +Admitted. +*) + + +(*** + *** Automation for proving function refinement + ***) + +(* Create HintDb refinesFun. *) +Hint Extern 999 (_ |= _) => shelve : refinesFun. +Hint Extern 999 (refinesFun _ _) => shelve : refinesFun. + +Definition MaybeDestructArg A (a:A) (goal:Prop) : Prop := goal. +Definition noDestructArg A a (goal:Prop) : goal -> MaybeDestructArg A a goal := fun g => g. + +Definition refinesFun_multiFixM_fst' lrt (F:lrtPi (LRT_Cons lrt LRT_Nil) + (lrtTupleType (LRT_Cons lrt LRT_Nil))) f + (ref_f:refinesFun (SAWCoreScaffolding.fst (F f)) f) : + refinesFun (fst (multiFixM F)) f := refinesFun_multiFixM_fst lrt F f ref_f. + +Definition refinesFun_fst lrt B f1 (fs:B) f2 (r:@refinesFun lrt f1 f2) : + refinesFun (SAWCoreScaffolding.fst (f1, fs)) f2 := r. + +Hint Resolve refinesFun_fst | 1 : refinesFun. +Hint Resolve refinesFun_multiFixM_fst' | 1 : refinesFun. +Hint Resolve noDestructArg | 5 : refinesFun. + +(* If a goal contains W64List_rect applied to l, then destruct l *) +Ltac destructArg_W64List := + (lazymatch goal with + | |- MaybeDestructArg ?W64list ?l ?g => + match g with + | context [SAWCorePrelude.W64List_rect _ _ _ l] => + induction l; let IH := get_last_hyp tt in + try simpl in IH; try unfold MaybeDestructArg in IH; + simpl; apply noDestructArg + end + end). +Hint Extern 1 (MaybeDestructArg _ _ _) => destructArg_W64List :refinesFun. + +(* If a goal contains list_rect applied to l, then destruct l *) +Ltac destructArg_list := + (lazymatch goal with + | |- MaybeDestructArg (list _) ?l ?g => + match g with + | context [Datatypes.list_rect _ _ _ l] => + induction l; let IH := get_last_hyp tt in + try simpl in IH; try unfold MaybeDestructArg in IH; + simpl; apply noDestructArg + end + end). +Hint Extern 1 (MaybeDestructArg _ _ _) => destructArg_list :refinesFun. + +Definition refinesFunBase B m1 m2 (r: m1 |= m2) : @refinesFun (LRT_Ret B) m1 m2 := r. +Definition refinesFunStep A lrtF f1 f2 + (r: IntroArg Any _ (fun a => MaybeDestructArg A a (@refinesFun (lrtF a) (f1 a) (f2 a)))) : + @refinesFun (LRT_Fun A lrtF) f1 f2 := r. + +Hint Extern 5 (@refinesFun (LRT_Ret _) _ _) => + simple apply refinesFunBase; unfold_projs : refinesFun. + +Hint Extern 5 (@refinesFun (LRT_Fun _ _) _ _) => + simple apply refinesFunStep : refinesFun. + + +(*** + *** Top-level tactics to put it all together + ***) + +Ltac prove_refinement_core := + unshelve (typeclasses eauto with refinesM refinesFun); + try (unshelve (rewrite_strat (bottomup (hints refinesM)))); + unfold_projs in *; split_prod_goal; + try reflexivity || contradiction. + +(* Automatically prove refinements of the form `refinesFun F G` or of the + form` P |= Q`, where P,Q may contain matching calls to `letRecM`. *) +Ltac prove_refinement := + unfold_projs; compute_bv_funs; + prove_refinement_core. + +(* After a call to `prove_refinement`, give user input as to whether to continue + proof automation in the left or right branch of an `orM`/`andM`. *) +Ltac continue_prove_refinement_left := + match goal with + | |- _ |= orM _ _ => apply refinesM_orM_r; left; prove_refinement_core + | |- andM _ _ |= _ => apply refinesM_andM_l; left; prove_refinement_core + end. +Ltac continue_prove_refinement_right := + match goal with + | |- _ |= orM _ _ => apply refinesM_orM_r; right; prove_refinement_core + | |- andM _ _ |= _ => apply refinesM_andM_l; right; prove_refinement_core + end. + +(* For refinements of the form `refinesFun F G` or `P |= Q` where a subexpression + on the left has a call to `letRecM` which does not match one on the right, + this tactic tries to prove the refinement by transitivity, where the new + middle expression has a `letRecM` which matches the one on the left as per + `refinesM_letRecM_match_r`. After giving values for each of the needed + functions, call `prove_refinement` to continue automation. *) +Ltac prove_refinement_match_letRecM_l := + unshelve (typeclasses eauto with refinesM refinesFun); + unshelve (eapply refinesM_letRecM_match_r); + [ unfold lrtTupleType, lrtToType; repeat split | apply ProperLRTFun_any | ]. + +(* It's important for the tactic above that `letRecM` is opaque! Otherwise + `eauto` will unfold it too soon. *) +Hint Opaque letRecM : refinesM refinesFun. + +(* Ltac prove_refinesFun := unshelve (typeclasses eauto with refinesFun). *) + +(* +Ltac rewrite_refinesM := + try ((rewrite returnM_bindM || rewrite bindM_returnM || rewrite bindM_bindM || + rewrite errorM_bindM || rewrite existsM_bindM); rewrite_refinesM). +*) + + +(*** FIXME: old stuff below ***) + +Ltac old_prove_refinesM := + lazymatch goal with + (* Bind cases *) + | |- (returnM _ >>= _) |= _ => rewrite returnM_bindM; old_prove_refinesM + | |- _ |= (returnM _ >>= _) => rewrite returnM_bindM; old_prove_refinesM + | |- (existsM _ >>= _) |= _ => rewrite existsM_bindM; old_prove_refinesM + | |- _ |= (existsM _ >>= _) => rewrite existsM_bindM; old_prove_refinesM + | |- (errorM >>= _) |= _ => rewrite errorM_bindM; old_prove_refinesM + | |- _ |= (errorM >>= _) => rewrite errorM_bindM; old_prove_refinesM + | |- ((_ >>= _) >>= _) |= _ => rewrite bindM_bindM; old_prove_refinesM + | |- _ |= ((_ >>= _) >>= _) => rewrite bindM_bindM; old_prove_refinesM + + (* letRecM cases *) + | |- letRecM tt _ |= _ => apply refinesM_letRecM_Nil_l; old_prove_refinesM + + (* either *) + | |- SAWCorePrelude.either _ _ _ _ _ _ |= _ => + apply refinesM_either_l; intros; old_prove_refinesM + | |- _ |= SAWCorePrelude.either _ _ _ _ _ _ => + apply refinesM_either_r; intros; old_prove_refinesM + | |- sigT_rect _ _ _ |= _ => + + (* sigT_rect *) + apply refinesM_sigT_rect_l; intros; old_prove_refinesM + | |- _ |= sigT_rect _ _ _ => + apply refinesM_sigT_rect_r; intros; old_prove_refinesM + + (* if *) + | |- (if _ then _ else _) |= _ => + apply refinesM_if_l; intros; old_prove_refinesM + | |- _ |= (if _ then _ else _) => + apply refinesM_if_r; intros; old_prove_refinesM + + (* quantifiers *) + | |- existsM _ |= _ => apply refinesM_existsM_l; intros; old_prove_refinesM + | |- _ |= forallM _ => apply refinesM_forallM_r; intros; old_prove_refinesM + | |- _ |= existsM _ => eapply refinesM_existsM_r; old_prove_refinesM + | |- forallM _ |= _ => eapply refinesM_forallM_l; old_prove_refinesM + | |- returnM _ |= returnM _ => apply refinesM_returnM; intros; try reflexivity + + (* default: give up! *) + | _ => idtac (* try (progress (autorewrite with refinesM) ; old_prove_refinesM) *) + end. + +Ltac old_prove_refinesFun := + apply refinesFun_multiFixM_fst; simpl; intros; old_prove_refinesM. diff --git a/saw-core-coq/coq/handwritten/CryptolToCoq/CompM_ITrees.v b/saw-core-coq/coq/handwritten/CryptolToCoq/CompM_ITrees.v new file mode 100644 index 0000000000..e96df61806 --- /dev/null +++ b/saw-core-coq/coq/handwritten/CryptolToCoq/CompM_ITrees.v @@ -0,0 +1,512 @@ +(*** + *** A version of the computation monad using the option-set monad + ***) + +From Coq Require Export Morphisms Setoid Program.Equality. +From ITree Require Export ITree ITreeFacts. +From Paco Require Import paco. + +Infix ">>=" := ITree.bind (at level 58, left associativity). +Notation "m1 >> m2" := (m1 >>= fun _ => m2) (at level 58, left associativity). + +Variant SpecEvent (E:Type -> Type) (A:Type) : Type := +| Spec_vis : E A -> SpecEvent E A +| Spec_forall : SpecEvent E A +| Spec_exists : SpecEvent E A +. + +Arguments Spec_vis {E A}. +Arguments Spec_forall {E A}. +Arguments Spec_exists {E A}. + +(* An ITree that defines a set of ITrees *) +Definition itree_spec E A : Type := itree (SpecEvent E) A. + +(* The body of an itree_spec, inside the observe projection *) +Definition itree_spec' E A : Type := itree' (SpecEvent E) A. + +Inductive satisfiesF {E A} (satisfies : itree_spec E A -> itree E A -> Prop) + : itree_spec' E A -> itree' E A -> Prop := +| Satisfies_Ret a : satisfiesF satisfies (RetF a) (RetF a) +| Satisfies_Tau spec tree : + satisfies spec tree -> + satisfiesF satisfies (TauF spec) (TauF tree) +| Satisfies_TauL spec tree : + satisfiesF satisfies (observe spec) tree -> + satisfiesF satisfies (TauF spec) tree +| Satisfies_TauR spec tree : + satisfiesF satisfies spec (observe tree) -> + satisfiesF satisfies spec (TauF tree) +| Satisfies_Vis X (e:E X) spec tree : + (forall x, satisfies (spec x) (tree x)) -> + satisfiesF satisfies (VisF (Spec_vis e) spec) (VisF e tree) +| Satisfies_Forall X spec tree : + (forall x:X, satisfies (spec x) tree) -> + satisfiesF satisfies (VisF Spec_forall spec) (observe tree) +| Satisfies_Exists X spec tree : + (exists x:X, satisfies (spec x) tree) -> + satisfiesF satisfies (VisF Spec_exists spec) (observe tree) +. + +Hint Constructors satisfiesF. + +Instance Proper_satisfies_satisfiesF {E A} : + Proper (pointwise_relation _ (pointwise_relation _ Basics.impl) ==> + eq ==> eq ==> Basics.impl) (@satisfiesF E A). +Proof. + intros R1 R2 implR spec1 spec2 e_spec tree1 tree2 e_tree sats. + rewrite <- e_spec; rewrite <- e_tree. + clear e_spec spec2 e_tree tree2. + induction sats; constructor; intros; try (apply implR; apply H); try assumption. + destruct H as [ x H ]. exists x. apply implR; assumption. +Qed. + +Lemma satisfiesF_mono {E A} (sats1 sats2:itree_spec E A -> itree E A -> Prop) + (sub_sats:forall spec tree, sats1 spec tree -> sats2 spec tree) : + forall spec tree, + satisfiesF sats1 spec tree -> satisfiesF sats2 spec tree. +Proof. + intros. + apply (Proper_satisfies_satisfiesF sats1 sats2 sub_sats _ _ eq_refl _ _ eq_refl H). +Qed. + +Definition satisfies_ {E A} satisfies spec tree := + @satisfiesF E A satisfies (observe spec) (observe tree). + + +Lemma satisfies__mono E A : monotone2 (@satisfies_ E A). +Proof. + intros spec tree r1 r2 sats sub12. unfold satisfies_. + induction sats; constructor; try assumption. + { apply sub12; assumption. } + { intros; apply sub12. apply H. } + { intros; apply sub12. apply H. } + { destruct H as [ x H ]. exists x. apply sub12. apply H. } +Qed. + +Hint Resolve satisfies__mono : paco. + +Definition satisfies {E A} spec tree := paco2 (@satisfies_ E A) bot2 spec tree. + +Instance Proper_observing_paco2_satisfies_impl E A r : + Proper (observing eq ==> observing eq ==> iff) (paco2 (@satisfies_ E A) r). +Proof. + intros spec1 spec2 [ Rspec ] tree1 tree2 [ Rtree ]. + split; intro; punfold H; pfold; unfold satisfies_; + [ rewrite <- Rtree; rewrite <- Rspec | rewrite Rtree; rewrite Rspec ]; + apply H. +Qed. + +Instance Proper_observing_satisfies E A : + Proper (observing eq ==> observing eq ==> iff) (@satisfies E A). +Proof. + apply Proper_observing_paco2_satisfies_impl. +Qed. + +Ltac simpobs x := apply simpobs in x. + +Ltac weaken_bis Hb := match type of Hb with ?x ≅ ?y => assert (x ≈ y); try (rewrite Hb; reflexivity) end. + +Lemma satisfies_eutt_spec_tau_vis_aux: forall (E : Type -> Type) (A u : Type) (e : SpecEvent E u) + (k1 k2 : u -> itree (SpecEvent E) A), + (forall v : u, paco2 (eqit_ eq true true id) bot2 (k1 v) (k2 v)) -> + forall (r : itree_spec E A -> itree E A -> Prop) (tree0 : itree E A), + (forall (P1 P2 : itree_spec E A) (tree : itree E A), + satisfies P1 tree -> P1 ≈ P2 -> r P2 tree) -> + satisfiesF (upaco2 satisfies_ bot2) (VisF e k1) (observe tree0) -> + satisfiesF (upaco2 satisfies_ r) (VisF e k2) (observe tree0). +Proof. + intros E A u e k1 k2 REL r tree0 CIH H. + dependent induction H. + - rewrite <- x. constructor. eapply IHsatisfiesF; eauto. + - rewrite <- x. constructor. intros. right. + pclearbot. eapply CIH; eauto. apply H. + - rewrite <- x. constructor. right. pclearbot; eapply CIH; eauto. + apply H. + - rewrite <- x. constructor. destruct H as [x' Hx' ]. pclearbot. + exists x'. right. eapply CIH; eauto. +Qed. + +Lemma satisfiesF_TauL: forall (E : Type -> Type) (A : Type) (t1 : itree (SpecEvent E) A) + (tree0 : itree E A), + satisfiesF (upaco2 satisfies_ bot2) (TauF t1) (observe tree0) -> + satisfiesF (upaco2 satisfies_ bot2) (observe t1) (observe tree0). +Proof. + intros E A t1 tree0 H. + dependent induction H; auto. + - pclearbot. rewrite <- x. constructor. punfold H. + - rewrite <- x. constructor. eapply IHsatisfiesF; eauto. +Qed. + +(* Requires coinduction because the forall and exist states *) +Lemma satisfies_TauR: + forall (E : Type -> Type) (A : Type) (P : itree_spec E A) (t : itree E A), + satisfies P (Tau t) -> + satisfies P t. +Proof. + intros E A. pcofix CIH. intros P t HP. + pfold. red. + punfold HP. red in HP. dependent induction HP; pclearbot; auto. + - rewrite <- x. constructor. pstep_reverse. eapply paco2_mon; eauto. + intuition. + - rewrite <- x. constructor. eapply IHHP; eauto. + - pstep_reverse. clear IHHP. eapply paco2_mon with (r := bot2); intuition. + - rewrite <- x0. cbn in x. constructor. right. + eapply CIH; eauto. pfold. red. cbn. rewrite <- x. pstep_reverse. + - rewrite <- x0. constructor. destruct H as [x' Hx']. pclearbot. + exists x'. right. eapply CIH. pfold. red. rewrite <- x. pstep_reverse. +Qed. + +Lemma satisfies_eutt_spec_l E A (P1 P2:itree_spec E A) tree : + satisfies P1 tree -> eutt eq P1 P2 -> satisfies P2 tree. +Proof. + revert P1 P2 tree. pcofix CIH. intros P1 P2 tree HP HP12. + punfold HP. red in HP. pfold. red. punfold HP12. red in HP12. + dependent induction HP. + - rewrite <- x. rewrite <- x0 in HP12. dependent induction HP12; auto. + + rewrite <- x. constructor. + + rewrite <- x. constructor. eapply IHHP12; eauto. + - pclearbot. + remember (observe P2) as oP2. clear HeqoP2 P2. + assert ((exists P2', oP2 = TauF P2') \/ (forall P2', oP2 <> TauF P2') ). + { destruct oP2; eauto; right; repeat intro; discriminate. } + rewrite <- x. rewrite <- x0 in HP12. clear x0 x. + destruct H0 as [ [P2' HP2'] | HP2' ]. + + subst. constructor. right. eapply CIH; eauto. + rewrite <- tau_eutt. setoid_rewrite <- tau_eutt at 3. + pfold. auto. + + inversion HP12; try (exfalso; eapply HP2'; eauto; fail); subst. + clear HP12. punfold H. red in H. + dependent induction REL; intros; subst; + try (exfalso; eapply HP2'; eauto; fail). + * constructor. rewrite <- x in H. + clear CIH HP2' x. dependent induction H; try constructor. + ++ rewrite <- x. constructor. + ++ rewrite <- x. constructor. apply IHsatisfiesF; auto. + * rewrite <- x in H. constructor. pclearbot. + eapply satisfies_eutt_spec_tau_vis_aux; eauto. + * eapply IHREL; auto. rewrite <- x in H. + eapply satisfiesF_TauL; eauto. + - eapply IHHP; eauto. rewrite <- x in HP12. + assert (Tau spec ≈ P2); try (pfold; auto; fail). + rewrite tau_eutt in H. punfold H. + - rewrite <- x. constructor. eapply IHHP; eauto. + - rewrite <- x. rewrite <- x0 in HP12. dependent induction HP12. + + rewrite <- x. constructor. pclearbot. intros. right. eapply CIH; eauto. + apply H. + + rewrite <- x. constructor. eapply IHHP12; eauto. + - rewrite <- x0 in HP12. dependent induction HP12. + + rewrite <- x. constructor. pclearbot. intros. right. eapply CIH; eauto. + pfold. red. rewrite <- x1. + specialize (H x2). punfold H. + + rewrite <- x. constructor. eapply IHHP12; eauto. + - rewrite <- x0 in HP12. rewrite <- x. clear x tree. dependent induction HP12. + + rewrite <- x. constructor. destruct H as [x' Hx']. pclearbot. + exists x'. right. eapply CIH; eauto. + + rewrite <- x. constructor. eapply IHHP12; eauto. +Qed. + +Lemma satisfies_eutt_spec_r E A (P:itree_spec E A) (t1 t2 : itree E A) : + satisfies P t1 -> t1 ≈ t2 -> satisfies P t2. +Proof. + revert P t1 t2. pcofix CIH. intros P t1 t2 HP Ht12. + pfold. red. punfold Ht12. red in Ht12. punfold HP. red in HP. + dependent induction Ht12. + - rewrite <- x. rewrite <- x0 in HP. clear x x0. + dependent induction HP; auto; + try (rewrite <- x; auto). + + rewrite <- x0. pclearbot. constructor. + intros. right. eapply CIH; try apply H. reflexivity. + + rewrite <- x0. constructor. destruct H as [x' Hx']. pclearbot. + exists x'. right. eapply CIH; eauto. reflexivity. + (* Tau Tau case *) + - pclearbot. remember (observe P) as oP. clear HeqoP P. + assert ( (exists P, oP = TauF P) \/ (forall P, oP <> TauF P) ). + { destruct oP; eauto; right; repeat intro; discriminate. } + destruct H as [ [P HoP] | HoP]. + + subst. rewrite <- x. constructor. right. eapply CIH; eauto. + apply satisfies_TauR. pfold. red. apply satisfiesF_TauL. simpl. + rewrite x0. auto. + + rewrite <- x. rewrite <- x0 in HP. + inversion HP; try (exfalso; eapply HoP; eauto; fail). + * subst. clear HP. clear x x0. punfold REL. red in REL. constructor. + dependent induction H1; try (exfalso; eapply HoP; eauto; fail). + ++ rewrite <- x in REL. clear x. dependent induction REL; + try (rewrite <- x; auto). + ++ eapply IHsatisfiesF; auto. pstep_reverse. + assert (m1 ≈ m2); try (pfold; auto; fail). simpobs x. rewrite x in H. + rewrite tau_eutt in H. auto. + ++ rewrite <- x in REL. clear x. dependent induction REL. + ** rewrite <- x; auto. constructor. right. + pclearbot. eapply CIH; eauto. apply H. + ** rewrite <- x. constructor. eapply IHREL; eauto. + ++ pclearbot. constructor. right. eapply CIH; eauto. pfold. red. + rewrite <- x. pstep_reverse. + ++ constructor. destruct H as [x' Hx']. pclearbot. exists x'. right. + eapply CIH; eauto. simpobs x. rewrite <- itree_eta in x. rewrite <- x. + pfold. auto. + * constructor. constructor. right. pclearbot. eapply CIH; eauto. + apply satisfies_TauR. pfold. red. cbn. rewrite <- H. pstep_reverse. + * constructor. constructor. destruct H1 as [x' Hx' ]. pclearbot. + exists x'. right. eapply CIH; eauto. symmetry in H. simpobs H. + rewrite H. rewrite tau_eutt. auto. + - rewrite <- x. rewrite <- x0 in HP. clear x x0. dependent induction HP. + + rewrite <- x. constructor. eapply IHHP; eauto. + + rewrite <- x. constructor. intros. right. + pclearbot. eapply CIH; eauto. apply H. + + rewrite <- x0. pclearbot. + assert (VisF e k2 = observe (Vis e k2) ); auto. rewrite H0. + constructor. intros. right. eapply CIH; try apply H. + symmetry in x. simpobs x. rewrite x. + pfold. red. constructor. auto. + + rewrite <- x0. assert (VisF e k2 = observe (Vis e k2) ); auto. + rewrite H0. constructor. destruct H as [x' Hx']. pclearbot. + exists x'. right. eapply CIH; eauto. symmetry in x. simpobs x. + rewrite x. pfold. constructor. left. auto. + - eapply IHHt12; auto. rewrite <- x in HP. pstep_reverse. + apply satisfies_TauR. pfold. auto. + - rewrite <- x. constructor. + eapply IHHt12; eauto. +Qed. + +Instance proper_eutt_satisfies E R : Proper (@eutt (SpecEvent E) R R eq ==> eutt eq ==> iff) satisfies. +Proof. + intros P Q HPQ t1 t2 Ht12. split; intros. + - eapply satisfies_eutt_spec_r; eauto. eapply satisfies_eutt_spec_l; eauto. + - symmetry in HPQ. symmetry in Ht12. eapply satisfies_eutt_spec_r; eauto. eapply satisfies_eutt_spec_l; eauto. +Qed. + +(* infinte forall exist chains *) + +CoFixpoint top_spec {E: Type -> Type} {A : Type} : itree_spec E A := Vis Spec_forall (fun _ : unit => top_spec). + +Lemma top_spec_is_top : forall E R (t : itree E R), satisfies top_spec t. +Proof. + intros E R. pcofix CIH. intros. pfold. red. cbn. constructor. intros. right. auto. +Qed. + +Definition bottom_spec {E : Type -> Type} {A : Type} : itree_spec E A := Vis Spec_exists (fun v : void => match v with end). + +Lemma bottom_spec_is_bottom : forall E R (t : itree E R), ~ satisfies bottom_spec t. +Proof. + intros E R t Hcontra. punfold Hcontra. red in Hcontra. cbn in *. dependent induction Hcontra; eauto. + destruct H as [ [] _ ]. +Qed. + +Definition and_spec {E : Type -> Type} {A : Type} (P Q : itree_spec E A) := + Vis Spec_forall (fun b : bool => if b then P else Q). + +Definition or_spec {E : Type -> Type} {A : Type} (P Q : itree_spec E A) := + Vis Spec_exists (fun b : bool => if b then P else Q). + +Lemma and_spec_is_and : forall E R (t : itree E R) (P Q : itree_spec E R), + satisfies (and_spec P Q) t <-> (satisfies P t /\ satisfies Q t). +Proof. + split; [split | idtac]; intros. + - punfold H. red in H. pfold. red. cbn in H. dependent induction H. + + rewrite <- x. constructor. eauto. + + simpobs x. rewrite <- itree_eta in x. pclearbot. pstep_reverse. + specialize (H true). cbn in *. rewrite x. auto. + - punfold H. red in H. pfold. red. cbn in H. dependent induction H. + + rewrite <- x. constructor. eauto. + + simpobs x. rewrite <- itree_eta in x. pclearbot. pstep_reverse. + specialize (H false). cbn in *. rewrite x. auto. + - destruct H. pfold. red. cbn. constructor. intros; destruct x; left; auto. +Qed. + +Lemma or_spec_is_or : forall E R (t : itree E R) (P Q : itree_spec E R), + satisfies (or_spec P Q) t <-> (satisfies P t \/ satisfies Q t). +Proof. + split; intros; [idtac | destruct H] . + - punfold H. red in H. cbn in *. dependent induction H; [ simpobs x | idtac ]. + + setoid_rewrite x. setoid_rewrite tau_eutt. eapply IHsatisfiesF; eauto. + + simpobs x. rewrite <- itree_eta in x. setoid_rewrite x. + destruct H as [ [ | ] H ]; pclearbot; eauto. + - pfold. red. cbn. constructor. exists true. auto. + - pfold. red. cbn. constructor. exists false. auto. +Qed. + +Lemma or_spec_bind : forall E R S (P Q : itree_spec E R) (k : R -> itree_spec E S), + (or_spec P Q) >>= k ≈ or_spec (P >>= k) (Q >>= k). +Proof. + intros. unfold or_spec. rewrite bind_vis. pfold. constructor. + intros; left. + enough ( (if v then P else Q) >>= k ≈ if v then P >>= k else Q >>= k ); auto. + destruct v; reflexivity. +Qed. + +Lemma and_spec_bind : forall E R S (P Q : itree_spec E R) (k : R -> itree_spec E S), + (and_spec P Q) >>= k ≈ and_spec (P >>= k) (Q >>= k). +Proof. + intros. unfold and_spec. + pfold. red. cbn. constructor. + intros; left. + enough ( (if v then P else Q) >>= k ≈ if v then P >>= k else Q >>= k ); auto. + destruct v; reflexivity. +Qed. + +(* +Definition imp_spec {E R} (P Q : itree_spec E R) := + Vis Spec_forall (fun _ : satisfies P t => Q) +*) + + +(* The proposition that a is returned by an itree along some path *) +Inductive is_itree_retval' {E A} : itree' E A -> A -> Prop := +| iirv_ret a : is_itree_retval' (RetF a) a +| iirv_tau tree a : + is_itree_retval' (observe tree) a -> is_itree_retval' (TauF tree) a +| iirv_vis {X} (ev:E X) tree a x : + is_itree_retval' (observe (tree x)) a -> + is_itree_retval' (VisF ev tree) a +. + +Definition is_itree_retval {E A} tree a := @is_itree_retval' E A (observe tree) a. + +Instance Proper_observing_is_itree_retval E A : + Proper (observing eq ==> eq ==> iff) (@is_itree_retval E A). +Proof. + intros m1 m2 [ em ] a1 a2 ea. rewrite <- ea. unfold is_itree_retval. + rewrite em. reflexivity. +Qed. + + +Lemma bind_satisfies_bind E A B (P:itree_spec E A) (Q:A -> itree_spec E B) + (m:itree E A) (f:A -> itree E B) : + satisfies P m -> + (forall a, is_itree_retval m a -> satisfies (Q a) (f a)) -> + satisfies (P >>= Q) (m >>= f). +Proof. + intro sats; revert P m sats. pcofix CIH. + intros P m sats satsQ; punfold sats. unfold satisfies_ at 1 in sats. + remember (observe P) as obsP eqn: e_obsP. + remember (observe m) as obsm eqn: e_obsm. + revert P m e_obsP e_obsm satsQ. induction sats; intros. + { rewrite <- (observing_intros _ (Ret a) _ e_obsP). + rewrite <- (observing_intros _ (Ret a) _ e_obsm). + repeat rewrite bind_ret_. + eapply paco2_mon_bot; [ apply satsQ | intros; eassumption ]. + rewrite <- (observing_intros _ (Ret a) _ e_obsm). constructor. } + { rewrite <- (observing_intros _ (Tau _) _ e_obsP). + rewrite <- (observing_intros _ (Tau _) _ e_obsm). + repeat rewrite bind_tau_. + pfold. apply Satisfies_Tau. right. pclearbot. apply CIH; [ assumption | ]. + intros a iirv. apply satsQ. + rewrite <- (observing_intros _ (Tau _) _ e_obsm). + constructor. assumption. } + { rewrite <- (observing_intros _ (Tau _) _ e_obsP). rewrite bind_tau_. + pfold. apply Satisfies_TauL. + set (IHapp := IHsats spec m eq_refl e_obsm satsQ). punfold IHapp. } + { rewrite <- (observing_intros _ (Tau _) _ e_obsm). rewrite bind_tau_. + pfold. apply Satisfies_TauR. + assert (paco2 satisfies_ r (P >>= Q) (tree >>= f)) as IHapp; + [ | punfold IHapp ]. + apply IHsats; [ assumption | reflexivity | ]. + intros. apply satsQ. rewrite <- (observing_intros _ (Tau _) _ e_obsm). + constructor. assumption. } + { rewrite <- (observing_intros _ (Vis _ _) _ e_obsP). + rewrite <- (observing_intros _ (Vis _ _) _ e_obsm). + repeat rewrite bind_vis_. pfold. + apply Satisfies_Vis. intro x. right. apply CIH. + - pclearbot. apply H. + - intros. apply satsQ. rewrite <- (observing_intros _ (Vis _ _) _ e_obsm). + econstructor. eassumption. } + { rewrite <- (observing_intros _ (Vis _ _) _ e_obsP). + rewrite <- (observing_intros _ _ _ e_obsm). + rewrite bind_vis_. pfold. apply Satisfies_Forall. intro x. right. apply CIH. + - pclearbot. apply H. + - intros. apply satsQ. + rewrite <- (observing_intros _ _ _ e_obsm). assumption. } + { rewrite <- (observing_intros _ (Vis _ _) _ e_obsP). + rewrite <- (observing_intros _ _ _ e_obsm). + rewrite bind_vis_. pfold. + destruct H as [ x H ]. apply Satisfies_Exists. exists x. right. apply CIH. + - pclearbot. apply H. + - intros. apply satsQ. + rewrite <- (observing_intros _ _ _ e_obsm). assumption. } +Qed. + +Notation " x : T <- m1 ;; m2" := (ITree.bind m1 (fun x : T=> m2) ) (at level 40). + +Section l_bind_satisfies_bind_counter. + Variant NonDet : Type -> Type := Choose : NonDet bool. + + Definition m_counter : itree NonDet unit := + x : bool <- ITree.trigger Choose ;; + if x then Ret tt else y : bool <- ITree.trigger Choose;; Ret tt. + + Definition P_counter : itree_spec NonDet unit := + x : bool <- ITree.trigger (Spec_vis Choose);; Ret tt. + + Definition Q_counter : unit -> itree_spec NonDet unit := + fun _ => or_spec (Ret tt) ( x : bool <- ITree.trigger (Spec_vis Choose);; Ret tt ). + + Lemma m_counter_sats_P_bind_Q_counter : satisfies (P_counter >>= Q_counter) m_counter. + Proof. + pfold. red. cbn. constructor. left. destruct x. + - pfold. red. cbn. + assert (RetF (E:= NonDet) tt = observe (Ret tt)); auto. + rewrite H. constructor. exists true. left. pfold; constructor. + - pfold. red. cbn. assert (VisF Choose (fun x : bool => _ : bool <- Ret x;; Ret tt) = + observe (Vis Choose (fun x : bool => _ : bool <- Ret x;; Ret tt) ) ); auto. + rewrite H. constructor. exists false. left. pfold. red. cbn. + rewrite H. constructor. intros [ | ]; left; pfold; red; cbn; auto. + Qed. + + Lemma satifies_P_counter : forall m, satisfies P_counter m -> + m ≈ (x : bool <- ITree.trigger Choose;; Ret tt). + Proof. + intros. unfold P_counter in *. punfold H. red in H. pfold. red. cbn in *. + dependent induction H. + - rewrite <- x. constructor; auto. + - rewrite <- x. constructor. left. pclearbot. specialize (H v). + assert (satisfies (_ : bool <- Ret v;; Ret tt) (tree v) ); auto. + enough (tree v ≈ ( _ : bool <- Ret v;; Ret tt) ); auto. rewrite bind_ret_l. + rewrite bind_ret_l in H0. symmetry. clear x H m. + pfold. red. punfold H0. red in H0. cbn in *. + remember (observe (tree v) ) as ot. clear Heqot tree v. dependent induction H0; auto. + Qed. + + Definition m0_counter : itree NonDet unit := x : bool <- ITree.trigger Choose;; Ret tt. + + Lemma m0_counter_no_continuation : forall k, + ~ m0_counter >>= k ≈ m_counter . + Proof. + unfold m0_counter, m_counter. + intros k Hcontra. repeat rewrite bind_trigger in Hcontra. + rewrite bind_vis in Hcontra. apply eqit_inv_vis in Hcontra as [_ Hcontra] . + specialize (Hcontra true) as Hktrue. specialize (Hcontra false) as Hkfalse. + cbn in *. rewrite bind_ret_l in Hktrue. rewrite bind_ret_l in Hkfalse. + rewrite Hktrue in Hkfalse. pinversion Hkfalse. + Qed. + + Lemma not_l_bind_satisfies_bind_aux : exists E R S + (m : itree E R) (P : itree_spec E S) (Q : S -> itree_spec E R), + satisfies (P >>= Q) m /\ (forall m0 k, satisfies P m0 -> ~ (m0 >>= k ≈ m) ). + Proof. + exists NonDet, unit, unit, m_counter, P_counter, Q_counter. + split; try apply m_counter_sats_P_bind_Q_counter. + intros. apply satifies_P_counter in H. rewrite H. fold m0_counter. + apply m0_counter_no_continuation. + Qed. + + +End l_bind_satisfies_bind_counter. + +Lemma not_l_bind_satisfies_bind : ~ forall E R S + (m : itree E R) (P : itree_spec E S) (Q : S -> itree_spec E R), + satisfies (P >>= Q) m -> exists m0 k, satisfies P m0 /\ (forall a, is_itree_retval m0 a -> satisfies (Q a) (k a) ) /\ (m0 >>= k ≈ m). +Proof. + destruct not_l_bind_satisfies_bind_aux as [ E [R [S [m [P [Q [H0 H1] ] ] ] ] ] ]. + intros Hcontra. specialize (Hcontra E R S m P Q H0). + destruct Hcontra as [m0 [k [Hsat [ _ Heutt] ] ] ]. eapply H1; eauto. +Qed. + +(* Our event type = errors *) +Inductive CompMEvent : Type -> Type := +| ErrorEvent : CompMEvent False +. + +(* Our computations are sets of ITrees. That is, they are really more like +specifications of computations *) +Definition CompM (A:Type) : Type := itree_spec CompMEvent A. diff --git a/saw-core-coq/coq/handwritten/CryptolToCoq/CoqVectorsExtra.v b/saw-core-coq/coq/handwritten/CryptolToCoq/CoqVectorsExtra.v new file mode 100644 index 0000000000..ab41a550ff --- /dev/null +++ b/saw-core-coq/coq/handwritten/CryptolToCoq/CoqVectorsExtra.v @@ -0,0 +1,27 @@ +(* This file contains definitions that seemed missing from Coq.Vectors.Vector *) + +From Coq Require Import PeanoNat. +From Coq.Vectors Require Vector. + +Fixpoint zip {a b : Type} {n : nat} (xs : Vector.t a n) (ys : Vector.t b n) : Vector.t (a * b) n. + refine ( + match + xs in Vector.t _ n' + return Vector.t _ n' -> Vector.t _ n' + with + | Vector.nil _ => fun _ => Vector.nil _ + | Vector.cons _ x pn xs => + fun ys => + match + ys in Vector.t _ n' + return S pn = n' -> Vector.t _ n' + with + | Vector.nil _ => fun absurd => False_rect _ (Nat.neq_succ_0 _ absurd) + | Vector.cons _ y pn' ys => + fun eq => + let xs' := eq_rect _ _ xs _ (eq_add_S _ _ eq) in + Vector.cons _ (x, y) pn' (zip _ _ _ xs' ys) + end eq_refl + end ys + ). +Defined. diff --git a/saw-core-coq/coq/handwritten/CryptolToCoq/CryptolPrimitivesForSAWCoreExtra.v b/saw-core-coq/coq/handwritten/CryptolToCoq/CryptolPrimitivesForSAWCoreExtra.v new file mode 100644 index 0000000000..46ed0cfa92 --- /dev/null +++ b/saw-core-coq/coq/handwritten/CryptolToCoq/CryptolPrimitivesForSAWCoreExtra.v @@ -0,0 +1,107 @@ +(* This module contains additional definitions that can only be defined after *) +(* the Cryptol prelude has been defined. *) + +From Coq Require Import Lists.List. +From Coq Require Import String. +From Coq Require Import Vectors.Vector. +From CryptolToCoq Require Import SAWCoreScaffolding. +From CryptolToCoq Require Import SAWCorePrelude. +Import SAWCorePrelude. +From CryptolToCoq Require Import SAWCorePreludeExtra. +From CryptolToCoq Require Import SAWCoreVectorsAsCoqVectors. +From CryptolToCoq Require Import CryptolPrimitivesForSAWCore. +Import CryptolPrimitivesForSAWCore. + +Import ListNotations. + +(** It is annoying to have to wrap natural numbers into [TCNum] to use them at +type [Num], so these coercions will do it for us. + *) +Coercion TCNum : Nat >-> Num. +Definition natToNat (n : nat) : Nat := n. +Coercion natToNat : nat >-> Nat. + +Theorem Eq_TCNum a b : a = b -> Eq _ (TCNum a) (TCNum b). +Proof. + intros EQ. + rewrite EQ. + reflexivity. +Qed. + +Theorem min_S n : min n (S n) = n. +Proof. + rewrite PeanoNat.Nat.min_comm. + induction n. + { reflexivity. } + { simpl in *. intuition. } +Qed. + +Ltac solveUnsafeAssertStep := + match goal with + | [ |- context [ Succ ] ] => unfold Succ + | [ n : Num |- _ ] => destruct n + | [ |- Eq Num (TCNum _) (TCNum _) ] => apply Eq_TCNum + | [ |- Eq Num _ _ ] => reflexivity + | [ |- context [ minNat _ _ ] ] => rewrite minNat_min + | [ |- min ?n (S ?n) = ?n ] => apply min_S + end. + +Ltac solveUnsafeAssert := repeat (solveUnsafeAssertStep; simpl). + +Definition cbc_enc_helper n : Eq Num (tcMin n (tcAdd (TCNum 1) n)) n := + ltac:(solveUnsafeAssert). + +(* +Goal forall n p b, Eq Num (tcAdd n (tcAdd (TCNum 32) p)) (tcMul (tcAdd (TCNum 2) b) (TCNum 16)). + intros. + simpl. + solve_unsafeAssert_step. simpl. + +Goal forall n0, Eq Num TCInf + (TCNum + (S + (S + (S + (S + (S + (S + (S + (S + (S + (S + (S + (S + (S + (S + (S + (S + (S + (S + (S + (S + (S + (S + (S + (S + (S + (S + (S + (S + (S (S (S (S (mulNat n0 16)))))))))))))))))))))))))))))))))). + intros. + solve_unsafeAssert. +*) + +Fixpoint iterNat {a : Type} (n : nat) (f : a -> a) : a -> a := + match n with + | O => fun x => x + | S n' => fun x => iterNat n' f (f x) (* TODO: check that this is what iter is supposed to do *) + end +. + +Fixpoint iter {a : Type} (n : Num) (f : a -> a) : a -> a := + match n with + | TCNum n => fun xs => iterNat n f xs + | TCInf => fun xs => xs + end +. diff --git a/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCoreBitvectors.v b/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCoreBitvectors.v new file mode 100644 index 0000000000..bf059331f6 --- /dev/null +++ b/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCoreBitvectors.v @@ -0,0 +1,311 @@ +(*** + *** Lemmas about the bitvectors from SAWCoreVectorsAsCoqVectors + ***) + +From Coq Require Import Program.Basics. +From Coq Require Import Vectors.Vector. + +From CryptolToCoq Require Import SAWCorePrelude. +From CryptolToCoq Require Import SAWCoreScaffolding. +From CryptolToCoq Require Import SAWCoreVectorsAsCoqVectors. + +Import SAWCorePrelude. + +Create HintDb SAWCoreBitvectors. + + +(* Computing opaque bitvector functions *) + +Ltac compute_bv_binrel_in_goal H f w1 w2 a b := + let e := eval vm_compute in (f w1 (intToBv w2 a) (intToBv w2 b)) in + replace (f w1 (intToBv w2 a) (intToBv w2 b)) with e by reflexivity. +Ltac compute_bv_binrel_in H f w1 w2 a b := + let e := eval vm_compute in (f w1 (intToBv w2 a) (intToBv w2 b)) in + replace (f w1 (intToBv w2 a) (intToBv w2 b)) with e in H by reflexivity. + +Ltac compute_bv_binop_in_goal H f w1 w2 w3 a b := + let e := eval vm_compute in (sbvToInt w2 (f w1 (intToBv w2 a) (intToBv w2 b))) in + try (replace (f w1 (intToBv w2 a) (intToBv w2 b)) with (intToBv w2 e) by reflexivity). +Ltac compute_bv_binop_in H f w1 w2 a b := + let e := eval vm_compute in (sbvToInt w2 (f w1 (intToBv w2 a) (intToBv w2 b))) in + try (replace (f w1 (intToBv w2 a) (intToBv w2 b)) with (intToBv w2 e) in H by reflexivity). + +Ltac compute_bv_unrel_in_goal H f w1 w2 a := + let e := eval vm_compute in (f w1 (intToBv w2 a)) in + try (replace (f w1 (intToBv w2 a)) with e by reflexivity). +Ltac compute_bv_unrel_in H f w1 w2 a := + let e := eval vm_compute in (f w1 (intToBv w2 a)) in + try (replace (f w1 (intToBv w2 a)) with e in H by reflexivity). + +Ltac compute_bv_unop_in_goal H f w1 w2 a := + let e := eval vm_compute in (sbvToInt w2 (f w1 (intToBv w2 a))) in + try (replace (f w1 (intToBv w2 a)) with (intToBv w2 e) by reflexivity). +Ltac compute_bv_unop_in H f w1 w2 a := + let e := eval vm_compute in (sbvToInt w2 (f w1 (intToBv w2 a))) in + try (replace (f w1 (intToBv w2 a)) with (intToBv w2 e) in H by reflexivity). + +Ltac compute_bv_funs_tac H t compute_bv_binrel compute_bv_binop + compute_bv_unrel compute_bv_unop := + match t with + | context [?f ?w1 (intToBv ?w2 ?a) (intToBv ?w2 ?b)] => + match f with + | bvsle => compute_bv_binrel H bvsle w1 w2 a b + | bvslt => compute_bv_binrel H bvslt w1 w2 a b + | bvule => compute_bv_binrel H bvule w1 w2 a b + | bvult => compute_bv_binrel H bvult w1 w2 a b + | bvEq => compute_bv_binrel H bvEq w1 w2 a b + | bvAdd => compute_bv_binop H bvAdd w1 w2 a b + | bvSub => compute_bv_binop H bvSub w1 w2 a b + | bvMul => compute_bv_binop H bvMul w1 w2 a b + end + | context [?f ?w1 (intToBv ?w2 ?a)] => + match f with + | msb => compute_bv_unrel H msb w1 w2 a + | bvNeg => compute_bv_unop H bvNeg w1 w2 a + end + end. + +Ltac unfold_bv_funs := unfold bvultWithProof, bvuleWithProof, + bvsge, bvsgt, bvuge, bvugt, bvSCarry, bvSBorrow, + xor, xorb. + +Tactic Notation "compute_bv_funs" := + unfold_bv_funs; repeat match goal with + | |- ?t => let H := fresh "H" in + try (compute_bv_funs_tac H t compute_bv_binrel_in_goal compute_bv_binop_in_goal compute_bv_unrel_in_goal compute_bv_unop_in_goal) + end. + +Tactic Notation "compute_bv_funs" "in" ident(H) := + unfold_bv_funs; repeat match goal with + | H': ?t |- _ => match H' with + | H => try (compute_bv_funs_tac H t compute_bv_binrel_in compute_bv_binop_in compute_bv_unrel_in compute_bv_unop_in) + end + end. + + +(** Bitvector maximum and minimum values **) + +Definition bvsmax w : bitvector w := + match w with + | O => nil _ + | S w => cons _ false _ (gen w _ (fun _ => true)) + end. +Definition bvsmin w : bitvector w := + match w with + | O => nil _ + | S w => cons _ true _ (gen w _ (fun _ => false)) + end. + +Definition bvumax w : bitvector w := gen w _ (fun _ => true). +Definition bvumin w : bitvector w := gen w _ (fun _ => false). + + +(** Bitvector inquality propositions, and their preorders **) + +Definition isBvsle w a b : Prop := bvsle w a b = true. +Definition isBvsle_def w a b : bvsle w a b = true <-> isBvsle w a b := reflexivity _. +Definition isBvsle_def_opp w a b : bvslt w a b = false <-> isBvsle w b a. Admitted. +Hint Rewrite isBvsle_def isBvsle_def_opp : SAWCoreBitvectors. +Instance PreOrder_isBvsle w : PreOrder (isBvsle w). Admitted. + +Definition isBvslt w a b : Prop := bvslt w a b = true. +Definition isBvslt_def w a b : bvslt w a b = true <-> isBvslt w a b := reflexivity _. +Definition isBvslt_def_opp w a b : bvsle w a b = false <-> isBvslt w b a. Admitted. +Hint Rewrite isBvslt_def isBvslt_def_opp : SAWCoreBitvectors. +Instance PreOrder_isBvslt w : PreOrder (isBvslt w). Admitted. + +Definition isBvule w a b : Prop := bvule w a b = true. +Definition isBvule_def w a b : bvule w a b = true <-> isBvule w a b := reflexivity _. +Definition isBvule_def_opp w a b : bvult w a b = false <-> isBvule w b a. Admitted. +Hint Rewrite isBvule_def isBvule_def_opp : SAWCoreBitvectors. +Instance PreOrder_isBvule w : PreOrder (isBvule w). Admitted. + +Definition isBvult w a b : Prop := bvult w a b = true. +Definition isBvult_def w a b : bvult w a b = true <-> isBvult w a b := reflexivity _. +Definition isBvult_def_opp w a b : bvule w a b = false <-> isBvult w b a. Admitted. +Hint Rewrite isBvult_def isBvult_def_opp : SAWCoreBitvectors. +Instance PreOrder_isBvult w : PreOrder (isBvult w). Admitted. + + +(** Converting between bitvector inqualities **) + +Definition isBvslt_to_isBvsle w a b : isBvslt w a b -> isBvsle w a b. Admitted. +Instance Proper_isBvslt_isBvsle w : Proper (isBvsle w --> isBvsle w ==> impl) (isBvslt w). Admitted. + +Definition isBvult_to_isBvule w a b : isBvult w a b -> isBvule w a b. Admitted. +Instance Proper_isBvult_isBvule w : Proper (isBvule w --> isBvule w ==> impl) (isBvult w). Admitted. + +Definition isBvslt_to_isBvsle_suc w a b : isBvslt w a b -> + isBvsle w (bvAdd w a (intToBv w 1)) b. +Admitted. + +Definition isBvult_to_isBvule_suc w a b : isBvult w a b -> + isBvule w (bvAdd w a (intToBv w 1)) b. +Admitted. + +Definition isBvult_to_isBvslt_pos w a b : isBvsle w (intToBv w 0) a -> + isBvsle w (intToBv w 0) b -> + isBvult w a b <-> isBvslt w a b. +Admitted. + +Definition isBvule_to_isBvsle_pos w a b : isBvsle w (intToBv w 0) a -> + isBvsle w (intToBv w 0) b -> + isBvule w a b <-> isBvsle w a b. +Admitted. + + +(** Other lemmas about bitvector inequalities **) + +Definition isBvsle_suc_r w (a : bitvector w) : isBvsle w a (bvsmax w) -> + isBvsle w a (bvAdd w a (intToBv w 1)). +Admitted. + +Definition isBvslt_antirefl w a : ~ isBvslt w a a. +Admitted. + +Definition isBvule_n_zero w a : isBvule w a (intToBv w 0) <-> a = intToBv w 0. +Admitted. + +Definition isBvult_n_zero w a : ~ isBvult w a (intToBv w 0). +Admitted. + +Definition isBvsle_antisymm w a b : isBvsle w a b -> isBvsle w b a -> a = b. +Admitted. + + +(** Lemmas about bitvector equality **) + +Lemma bvEq_eq w a b : bvEq w a b = true <-> a = b. Admitted. +Lemma bvEq_neq w a b : bvEq w a b = false <-> a <> b. Admitted. +Hint Rewrite bvEq_eq bvEq_neq : SAWCoreBitvectors. + +Lemma bv_eq_if_true (b : bool) : (if b then intToBv 1 1 else intToBv 1 0) = intToBv 1 1 <-> b = true. +Proof. split; intro H; destruct b; reflexivity || inversion H. Qed. +Lemma bv_eq_if_false (b : bool) : (if b then intToBv 1 1 else intToBv 1 0) = intToBv 1 0 <-> b = false. +Proof. split; intro H; destruct b; reflexivity || inversion H. Qed. + +Hint Rewrite bv_eq_if_true bv_eq_if_false : SAWCoreBitvectors. + +Lemma bv_neq_if_true (b : bool) : (if b then intToBv 1 1 else intToBv 1 0) <> intToBv 1 1 <-> b = false. +Proof. + split; intro H; destruct b; try reflexivity || inversion H. + - pose (H0 := H (reflexivity _)); inversion H0. + - intro H0; inversion H0. +Qed. + +Lemma bv_neq_if_false (b : bool) : (if b then intToBv 1 1 else intToBv 1 0) <> intToBv 1 0 <-> b = true. +Proof. + split; intro H; destruct b; try reflexivity || inversion H. + - pose (H0 := H (reflexivity _)); inversion H0. + - intro H0; inversion H0. +Qed. + +Hint Rewrite bv_neq_if_true bv_neq_if_false : SAWCoreBitvectors. + + +(** Lemmas about bitvector addition **) + +Lemma bvAdd_id_l w a : bvAdd w (intToBv w 0) a = a. Admitted. +Lemma bvAdd_id_r w a : bvAdd w a (intToBv w 0) = a. Admitted. +Lemma bvAdd_comm w a b : bvAdd w a b = bvAdd w b a. Admitted. +Lemma bvAdd_assoc w a b c : bvAdd w (bvAdd w a b) c = bvAdd w a (bvAdd w b c). Admitted. + + +(** Lemmas about subtraction, negation, and sign bits **) + +Lemma bvSub_zero_bvNeg w a : bvSub w (intToBv w 0) a = bvNeg w a. +Admitted. + +Hint Rewrite bvSub_zero_bvNeg : SAWCoreBitvectors. + +Lemma bvNeg_msb w a : msb w (bvNeg (Succ w) a) = not (msb w a). +Admitted. + +Hint Rewrite bvNeg_msb : SAWCoreBitvectors. + +Lemma bvslt_bvSub_r w a b : isBvslt w a b <-> isBvslt w (intToBv w 0) (bvSub w b a). +Admitted. + +Lemma bvslt_bvSub_l w a b : isBvslt w a b <-> isBvslt w (bvSub w a b) (intToBv w 0). +Admitted. + +Lemma bvEq_bvSub_r w a b : a = b <-> intToBv w 0 = bvSub w b a. +Admitted. + +Lemma bvEq_bvSub_l w a b : a = b <-> bvSub w a b = intToBv w 0. +Admitted. + +Lemma bvSub_eq_bvAdd_neg w a b : bvSub w a b = bvAdd w a (bvNeg w b). +Admitted. + +Lemma bvule_msb_l w a b : isBvule (Succ w) a b -> msb w a = true -> msb w b = true. +Admitted. + +Lemma bvule_msb_r w a b : isBvule (Succ w) a b -> msb w b = false -> msb w a = false. +Admitted. + + +(** Other rewriting hints not directly involving bitvectors **) + +Lemma and_bool_eq_true_lemma (b c : bool) : and b c = true <-> (b = true) /\ (c = true). +Proof. + split. + - destruct b, c; auto. + - intro; destruct H; destruct b, c; auto. +Qed. + +Lemma and_bool_eq_false_lemma (b c : bool) : and b c = false <-> (b = false) \/ (c = false). +Proof. + split. + - destruct b, c; auto. + - intro; destruct H; destruct b, c; auto. +Qed. + +Hint Rewrite and_bool_eq_true_lemma and_bool_eq_false_lemma : SAWCoreBitvectors. + +Lemma or_bool_eq_true_lemma (b c : bool) : or b c = true <-> (b = true) \/ (c = true). +Proof. + split. + - destruct b, c; auto. + - intro; destruct H; destruct b, c; auto. +Qed. + +Lemma or_bool_eq_false_lemma (b c : bool) : or b c = false <-> (b = false) /\ (c = false). +Proof. + split. + - destruct b, c; auto. + - intro; destruct H; destruct b, c; auto. +Qed. + +Hint Rewrite or_bool_eq_true_lemma or_bool_eq_false_lemma : SAWCoreBitvectors. + +Lemma not_bool_eq_true_lemma (b : bool) : not b = true <-> b = false. +Proof. split; destruct b; auto. Qed. + +Lemma not_bool_eq_false_lemma (b : bool) : not b = false <-> b = true. +Proof. split; destruct b; auto. Qed. + +Hint Rewrite not_bool_eq_true_lemma not_bool_eq_false_lemma : SAWCoreBitvectors. + +(* Lemma sym_bool_true_eq_lemma (b : bool) : true = b <-> b = true. *) +(* Proof. split; auto. Qed. *) + +(* Lemma sym_bool_false_eq_lemma (b : bool) : false = b <-> b = false. *) +(* Proof. split; auto. Qed. *) + +(* Hint Rewrite sym_bool_true_eq_lemma sym_bool_false_eq_lemma : SAWCoreBitvectors. *) + +Lemma boolEq_eq a b : boolEq a b = true <-> a = b. Admitted. +Lemma boolEq_neq a b : boolEq a b = false <-> a <> b. Admitted. +Hint Rewrite boolEq_eq boolEq_neq : SAWCoreBitvectors. + +Lemma bool_eq_if_true (b : bool) : (if b then true else false) = true <-> b = true. +Proof. split; intro H; destruct b; reflexivity || inversion H. Qed. +Lemma bool_eq_if_false (b : bool) : (if b then true else false) = false <-> b = false. +Proof. split; intro H; destruct b; reflexivity || inversion H. Qed. +Lemma bool_eq_if_inv_true (b : bool) : (if b then false else true) = true <-> b = false. +Proof. split; intro H; destruct b; reflexivity || inversion H. Qed. +Lemma bool_eq_if_inv_false (b : bool) : (if b then false else true) = false <-> b = true. +Proof. split; intro H; destruct b; reflexivity || inversion H. Qed. + +Hint Rewrite bool_eq_if_true bool_eq_if_false bool_eq_if_false bool_eq_if_true : SAWCoreBitvectors. diff --git a/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCorePreludeExtra.v b/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCorePreludeExtra.v new file mode 100644 index 0000000000..e42ce6f819 --- /dev/null +++ b/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCorePreludeExtra.v @@ -0,0 +1,61 @@ +From Coq Require Import Lists.List. +Import ListNotations. +From Coq Require Import String. +From Coq Require Import Vectors.Vector. +From CryptolToCoq Require Import SAWCoreScaffolding. +From CryptolToCoq Require Import SAWCorePrelude. +Import SAWCorePrelude. + +Fixpoint Nat_cases2_match a f1 f2 f3 (x y : nat) : a := + match (x, y) with + | (O, _) => f1 y + | (S x, O) => f2 x + | (S x, S y) => f3 x y (Nat_cases2_match a f1 f2 f3 x y) + end. + +Theorem Nat_cases2_match_spec a f1 f2 f3 x y : + Nat_cases2 a f1 f2 f3 x y = Nat_cases2_match a f1 f2 f3 x y. +Proof. + revert y. + induction x; intros y. + { + reflexivity. + } + { + destruct y. + { + reflexivity. + } + { + simpl. + now rewrite IHx. + } + } +Qed. + +Theorem minNat_min a b : minNat a b = min a b. +Proof. + revert b. + induction a; intros b. + { + reflexivity. + } + { + destruct b; simpl; intuition. + } +Qed. + +Theorem minNat_Succ n : minNat n (Succ n) = n. +Proof. + unfold minNat. + rewrite Nat_cases2_match_spec. + induction n. + { + reflexivity. + } + { + unfold Succ in *. + simpl. + intuition. + } +Qed. diff --git a/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCorePrelude_proofs.v b/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCorePrelude_proofs.v new file mode 100644 index 0000000000..9c8ba122b1 --- /dev/null +++ b/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCorePrelude_proofs.v @@ -0,0 +1,168 @@ +From Coq Require Import Init.Nat. +From Coq Require Import Lists.List. +From Coq Require Import Morphisms. +From Coq Require Import String. +From Coq Require Import Vectors.Vector. + +From CryptolToCoq Require Import SAWCorePrelude. +From CryptolToCoq Require Import SAWCoreScaffolding. +From CryptolToCoq Require Import SAWCoreVectorsAsCoqVectors. + +From mathcomp Require Import eqtype. +From mathcomp Require Import ssrbool. +From mathcomp Require Import ssreflect. +From mathcomp Require Import ssrnat. + +Import ProperNotations. +Import SAWCorePrelude. + +Global Instance Proper_gen n a : + Proper (@pointwise_relation _ _ eq ==> eq) (@gen n a). +Proof. + induction n. + { + now simpl. + } + { + intros f g FG. + simpl. + f_equal. + { + now apply FG. + } + { + setoid_rewrite IHn. + { + reflexivity. + } + { + intro. + apply FG. + } + { + constructor. + } + } + } +Qed. + +Global Instance Proper_genOrdinal n a : + Proper (@pointwise_relation _ _ eq ==> eq) (@genOrdinal n a). +Proof. + induction n. + { + now simpl. + } + { + intros f g FG. + simpl. + f_equal. + { + now apply FG. + } + { + setoid_rewrite IHn. + { + reflexivity. + } + { + intro. + apply FG. + } + { + constructor. + } + } + } +Qed. + +Global Instance Proper_Nat__rec p T : + Proper + ( + (forall_relation (fun _ => eq ==> eq)%signature) + ==> + (forall_relation (fun _ => eq)) + ) + (@Nat__rec p T). +Proof. + intros tSucc1 tSucc2 TSucc n. + induction n. + { + simpl. + reflexivity. + } + { + simpl. + now erewrite TSucc. + } +Qed. + +Theorem rewrite_addNat m n : addNat m n = m + n. +Proof. + induction m. + { reflexivity. } + { + simpl. + rewrite IHm. + intuition. + } +Defined. + +Theorem sawAt_zero T size h t : + sawAt (S size) T (cons T h size t) 0 = h. +Proof. + unfold sawAt. now simpl. +Qed. + +Theorem sawAt_S T size h t index : + sawAt (S size) T (cons T h size t) (S index) = sawAt size T t index. +Proof. + unfold sawAt. now simpl. +Qed. + +Lemma gen_sawAt T + : forall (m : Nat) a, gen m T (fun i => sawAt m T a i) = a. +Proof. + apply Vector.t_ind. + { + simpl. + reflexivity. + } + { + move => h n t IH. + simpl. + f_equal. + setoid_rewrite sawAt_S. + apply IH. + } +Qed. + +Lemma append_cons m n T h t v + : append m.+1 n T (cons T h m t) v + = + cons T h _ (append m n T t v). +Proof. + reflexivity. +Qed. + +Theorem rewrite_append T n (w : Vec n T) + : forall m (v : Vec m T), + existT _ (addNat m n) (append m n T v w) + = + existT _ (m + n) (Vector.append v w). +Proof. + apply Vector.t_ind. + { + simpl. + f_equal. + unfold append. + rewrite gen_sawAt. + reflexivity. + } + { + simpl => h m t IH. + setoid_rewrite append_cons. + dependent rewrite IH. + reflexivity. + } +Qed. diff --git a/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCoreScaffolding.v b/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCoreScaffolding.v new file mode 100644 index 0000000000..558bd1b407 --- /dev/null +++ b/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCoreScaffolding.v @@ -0,0 +1,301 @@ +From Coq Require Import Numbers.Cyclic.ZModulo.ZModulo. +From Coq Require Import ZArith.BinInt. +From Coq Require Import ZArith.Zdiv. +From Coq Require Import Lists.List. +From Coq Require Numbers.NatInt.NZLog. +From Coq Require Import Strings.String. +From CryptolToCoq Require Export CompM. + +Definition sort (n : nat) := Type. + +Axiom error : forall (a : Type), String.string -> a. + +Definition String := String.string. + +Definition equalString (s1 s2: String) : bool := + match String.string_dec s1 s2 with + | left _ => true + | right _ => false + end. + +Definition appendString : String -> String -> String := + String.append. + +Definition Unit := tt. +Definition UnitType := unit. +Definition UnitType__rec := unit_rect. + +Definition Bool := bool. +Definition Eq := identity. +Definition Eq__rec := identity_rect. +Definition Refl := identity_refl. +Definition EqP := @eq. +Definition ReflP := @eq_refl. +Definition true := true. +Definition ite (a : Type) (b : Bool) (t e : a) : a := if b then t else e. +Definition and := andb. +Definition false := false. +Definition not := negb. +Definition or := orb. +Definition xor := xorb. +Definition boolEq := Coq.Bool.Bool.eqb. + +(* SAW uses an alternate form of eq_rect where the motive function P also +depends on the equality proof itself *) +Definition EqP__rec (A : Type) (x : A) (P: forall y, x=y -> Type) (p:P x eq_refl) y (e:x=y) : + P y e. + dependent inversion e; assumption. +Defined. + +Theorem boolEq__eq (b1 b2:Bool) : Eq Bool (boolEq b1 b2) (ite Bool b1 b2 (not b2)). +Proof. + destruct b1, b2; reflexivity. +Qed. + +Definition coerce (a b : sort 0) (eq : Eq (sort 0) a b) (x : a) : b := + match eq in identity _ a' return a' with + | identity_refl _ => x + end +. + +(** Typeclass for `eq` **) +(* NOTE: SAW core prelude's eq is not being used much by the translation at the +moment, so we skip it. The following type class declaration could be used if +one wanted to translate `eq`. However, it would require more work in the +translation, because calls to `eq T a b` in SAW must be translated to either `eq +a b` or `@eq T _ a b`, where the underscore stands for the dictionary. As a +result, this would not be an identifier-to-identifier translation, but rather a +term-to-term translation, and would require knowing the number of arguments +expected before the dicitonary. *) +(* +Class eqClass `(a : Type) := + { + eq : a -> a -> bool; + eq_refl : forall (x : a), Eq Bool (eq x x) True; + }. + +Global Instance eqClassBool : eqClass Bool := + { + eq := boolEq; + }. ++ destruct x; reflexivity. +Defined. + +Theorem eq_Bool : Eq (Bool -> Bool -> Bool) eq boolEq. +Proof. + reflexivity. +Qed. + +Global Instance eqClass_sawVec (n : nat) (a : Type) `(A : eqClass a) : eqClass (sawVec n a) := + { + eq := Vector.eqb _ eq; + }. ++ induction 0 as [|? ? ? IH]. + - reflexivity. + - simpl. + rewrite eq_refl. + rewrite IH. + reflexivity. +Defined. +*) + +(* SAW's prelude defines iteDep as a Bool eliminator whose arguments are +reordered to look more like if-then-else. *) +Definition iteDep (P : Bool -> Type) (b : Bool) : P true -> P false -> P b := + fun Ptrue Pfalse => bool_rect P Ptrue Pfalse b. + +Definition ite_eq_iteDep : forall (a : Type) (b : Bool) (x y : a), + @identity a (ite a b x y) (iteDep (fun _ => a) b x y). +Proof. + reflexivity. +Defined. + +Definition iteDep_True : forall (p : Bool -> Type), forall (f1 : p true), forall (f2 : p false), (@identity (p true) (iteDep p true f1 f2)) f1. +Proof. + reflexivity. +Defined. + +Definition iteDep_False : forall (p : Bool -> Type), forall (f1 : p true), forall (f2 : p false), (@identity (p false) (iteDep p false f1 f2)) f2. +Proof. + reflexivity. +Defined. + +Definition not__eq (b : Bool) : @identity Bool (not b) (ite Bool b false true). +Proof. + reflexivity. +Defined. + +Definition and__eq (b1 b2 : Bool) : @identity Bool (and b1 b2) (ite Bool b1 b2 false). +Proof. + reflexivity. +Defined. + +Definition or__eq (b1 b2 : Bool) : @identity Bool (or b1 b2) (ite Bool b1 true b2). +Proof. + reflexivity. +Defined. + +Definition xor__eq (b1 b2 : Bool) : @identity Bool (xor b1 b2) (ite Bool b1 (not b2) b2). +Proof. + destruct b1; destruct b2; reflexivity. +Defined. + +(* +Definition eq__eq (b1 b2 : Bool) : @identity Bool (eq b1 b2) (ite Bool b1 b2 (not b2)). +Proof. + destruct b1; destruct b2; reflexivity. +Defined. +*) + +Theorem ite_bit (b c d : Bool) : Eq Bool (ite Bool b c d) (and (or (not b) c) (or b d)). +Proof. + destruct b, c, d; reflexivity. +Qed. + +(* TODO: doesn't actually coerce *) +Definition sawCoerce {T : Type} (a b : Type) (_ : T) (x : a) := x. + +(* TODO: doesn't actually coerce *) +Definition sawUnsafeCoerce (a b : Type) (x : a) := x. + +Definition Nat := nat. +Definition Nat_rect := nat_rect. + +(* Definition minNat := Nat.min. *) + +Definition uncurry (a b c : Type) (f : a -> b -> c) (p : a * (b * unit)) : c := + f (fst p) (fst (snd p)). + +Definition widthNat (n : Nat) : Nat := 1 + Nat.log2 n. + +Definition divModNat (x y : Nat) : (Nat * Nat) := + match y with + | 0 => (y, y) + | S y'=> + let (p, q) := Nat.divmod x y' 0 y' in + (p, y' - q) + end. + +Definition id := @id. +Definition PairType := prod. +Definition PairValue := @pair. +Definition Pair__rec := prod_rect. +Definition fst {A B} := @fst A B. +Definition snd {A B} := @snd A B. +Definition Zero := O. +Definition Succ := S. + + +Definition Integer := Z. +Definition intAdd : Integer -> Integer -> Integer := Z.add. +Definition intSub : Integer -> Integer -> Integer := Z.sub. +Definition intMul : Integer -> Integer -> Integer := Z.mul. +Definition intDiv : Integer -> Integer -> Integer := Z.div. +Definition intMod : Integer -> Integer -> Integer := Z.modulo. +Definition intMin : Integer -> Integer -> Integer := Z.min. +Definition intMax : Integer -> Integer -> Integer := Z.max. +Definition intNeg : Integer -> Integer := Z.opp. +Definition intAbs : Integer -> Integer := Z.abs. +Definition intEq : Integer -> Integer -> Bool := Z.eqb. +Definition intLe : Integer -> Integer -> Bool := Z.leb. +Definition intLt : Integer -> Integer -> Bool := Z.ltb. +Definition intToNat : Integer -> Nat := Z.to_nat. +Definition natToInt : Nat -> Integer := Z.of_nat. + +(* NOTE: the following will be nonsense for values of n <= 1 *) +Definition IntMod (n : nat) := Z. +Definition toIntMod (n : Nat) : Integer -> IntMod n := fun i => Z.modulo i (Z.of_nat n). +Definition fromIntMod (n : Nat) : (IntMod n) -> Integer := ZModulo.to_Z (Pos.of_nat n). +Local Notation "[| a |]_ n" := (to_Z (Pos.of_nat n) a) (at level 0, a at level 99). +Definition intModEq (n : Nat) (a : IntMod n) (b : IntMod n) : Bool + := Z.eqb [| a |]_n [| b |]_n. +Definition intModAdd : forall (n : Nat), (IntMod n) -> (IntMod n) -> IntMod n + := fun _ => ZModulo.add. +Definition intModSub : forall (n : Nat), (IntMod n) -> (IntMod n) -> IntMod n + := fun _ => ZModulo.sub. +Definition intModMul : forall (n : Nat), (IntMod n) -> (IntMod n) -> IntMod n + := fun _ => ZModulo.mul. +Definition intModNeg : forall (n : Nat), (IntMod n) -> IntMod n + := fun _ => ZModulo.opp. + + +(*** + *** A simple typeclass-based implementation of SAW record types + *** + *** The idea is to support a projection term recordProj e "field" on an element + *** e of a record type without having to find "field" in the record type of e, + *** by using typeclass resolution to find it for us. + ***) + +(* The empty record type *) +Variant RecordTypeNil : Type := + RecordNil : RecordTypeNil. + +(* A non-empty record type *) +Variant RecordTypeCons (str:String.string) (tp:Type) (rest_tp:Type) : Type := + RecordCons (x:tp) (rest:rest_tp) : RecordTypeCons str tp rest_tp. + +Arguments RecordTypeCons str%string_scope tp rest_tp. +Arguments RecordCons str%string_scope {tp rest_tp} x rest. + +(* Get the head element of a non-empty record type *) +Definition recordHead {str tp rest_tp} (r:RecordTypeCons str tp rest_tp) : tp := + match r with + | RecordCons _ x _ => x + end. + +(* Get the tail of a non-empty record type *) +Definition recordTail {str tp rest_tp} (r:RecordTypeCons str tp rest_tp) : rest_tp := + match r with + | RecordCons _ _ rest => rest + end. + +(* An inductive description of a string being a field in a record type *) +Inductive IsRecordField (str:String) : Type -> Type := +| IsRecordField_Base tp rtp : IsRecordField str (RecordTypeCons str tp rtp) +| IsRecordField_Step str' tp rtp : IsRecordField str rtp -> + IsRecordField str (RecordTypeCons str' tp rtp). + +(* We want to use this as a typeclass, with its constructors for instances *) +Existing Class IsRecordField. +Hint Constructors IsRecordField : typeclass_instances. + +(* If str is a field in record type rtp, get its associated type *) +Fixpoint getRecordFieldType rtp str `{irf:IsRecordField str rtp} : Type := + match irf with + | IsRecordField_Base _ tp rtp => tp + | IsRecordField_Step _ _ _ _ irf' => @getRecordFieldType _ _ irf' + end. + +(* If str is a field in record r of record type rtp, get its associated value *) +Fixpoint getRecordField {rtp} str `{irf:IsRecordField str rtp} : + rtp -> getRecordFieldType rtp str := + match irf in IsRecordField _ rtp + return rtp -> getRecordFieldType rtp str (irf:=irf) with + | IsRecordField_Base _ tp rtp' => fun r => recordHead r + | IsRecordField_Step _ _ _ _ irf' => + fun r => @getRecordField _ _ irf' (recordTail r) + end. + +(* Reorder the arguments of getRecordField *) +Definition RecordProj {rtp} (r:rtp) str `{irf:IsRecordField str rtp} : + getRecordFieldType rtp str := + getRecordField str r. + +Arguments RecordProj {_} r str%string {_}. + + +(* Some tests *) + +Definition recordTest1 := RecordCons "fld1" 0 (RecordCons "fld2" true RecordNil). +(* Check recordTest1. *) + +Definition recordTest2 := RecordProj recordTest1 "fld1". +(* Check recordTest2. *) + +(* Definition recordTestFail := RecordProj recordTest1 "fld3". *) + +Definition recordTest4 := + RecordCons "id_fun" (fun (X:Type) (x:X) => x) RecordNil. + +Definition recordTest5 := RecordProj recordTest4 "id_fun" nat 0. diff --git a/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCoreScaffoldingCopy.v b/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCoreScaffoldingCopy.v new file mode 100644 index 0000000000..ad6bd855a6 --- /dev/null +++ b/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCoreScaffoldingCopy.v @@ -0,0 +1,178 @@ +From Coq Require Import Lists.List. +From Coq Require Import Numbers.NatInt.NZLog. +From Coq Require Import Strings.String. + +From Ornamental Require Import Ornaments. + +Set DEVOID search prove equivalence. (* <-- Correctness proofs for search *) +Set DEVOID lift type. (* <-- Prettier types than the ones Coq infers *) + +Module SCS. + + Definition sort (n : nat) := Type. + +End SCS. + +Preprocess Module SCS as SCS'. + + (* Axiom error : forall (a : Type), String.string -> a. *) + + Definition String := String.string. + + Definition Unit := tt. + Definition UnitType := unit. + Definition UnitType__rec := unit_rect. + + Definition Bool := bool. + Definition Eq := identity. + Definition Eq__rec := identity_rect. + Definition Refl := identity_refl. + Definition True := true. + Definition ite (a : Type) (b : Bool) (t e : a) : a := if b then t else e. + Definition and := andb. + Definition False := false. + Definition not := negb. + Definition or := orb. + Definition xor := xorb. + Definition boolEq := Coq.Bool.Bool.eqb. + Theorem boolEq__eq (b1 b2:Bool) : Eq Bool (boolEq b1 b2) (ite Bool b1 b2 (not b2)). + Proof. + destruct b1, b2; reflexivity. + Qed. + + Definition coerce (a b : sort 0) (eq : Eq (sort 0) a b) (x : a) : b := + match eq in identity _ a' return a' with + | identity_refl _ => x + end + . + + (** Typeclass for `eq` **) +(* NOTE: SAW core prelude's eq is not being used much by the translation at the *) + (* moment, so we skip it. The following type class declaration could be used if *) + (* one wanted to translate `eq`. However, it would require more work in the *) + (* translation, because calls to `eq T a b` in SAW must be translated to either `eq *) + (* a b` or `@eq T _ a b`, where the underscore stands for the dictionary. As a *) + (* result, this would not be an identifier-to-identifier translation, but rather a *) + (* term-to-term translation, and would require knowing the number of arguments *) + (* expected before the dicitonary. *) +(* *) + (* Class eqClass `(a : Type) := *) + (* { *) + (* eq : a -> a -> bool; *) + (* eq_refl : forall (x : a), Eq Bool (eq x x) True; *) + (* }. *) + + (* Global Instance eqClassBool : eqClass Bool := *) + (* { *) + (* eq := boolEq; *) + (* }. *) + (* + destruct x; reflexivity. *) + (* Defined. *) + + (* Theorem eq_Bool : Eq (Bool -> Bool -> Bool) eq boolEq. *) + (* Proof. *) + (* reflexivity. *) + (* Qed. *) + + (* Global Instance eqClass_sawVec (n : nat) (a : Type) `(A : eqClass a) : eqClass (sawVec n a) := *) + (* { *) + (* eq := Vector.eqb _ eq; *) + (* }. *) + (* + induction 0 as [|? ? ? IH]. *) + (* - reflexivity. *) + (* - simpl. *) + (* rewrite eq_refl. *) + (* rewrite IH. *) + (* reflexivity. *) + (* Defined. *) + (* *) + +(* SAW's prelude defines iteDep as a Bool eliminator whose arguments are *) + (* reordered to look more like if-then-else. *) + Definition iteDep (P : Bool -> Type) (b : Bool) : P True -> P False -> P b := + fun PTrue PFalse => bool_rect P PTrue PFalse b. + + Definition ite_eq_iteDep : forall (a : Type) (b : Bool) (x y : a), + @identity a (ite a b x y) (iteDep (fun _ => a) b x y). + Proof. + reflexivity. + Defined. + + Definition iteDep_True : forall (p : Bool -> Type), forall (f1 : p True), forall (f2 : p False), (@identity (p True) (iteDep p True f1 f2)) f1. + Proof. + reflexivity. + Defined. + + Definition iteDep_False : forall (p : Bool -> Type), forall (f1 : p True), forall (f2 : p False), (@identity (p False) (iteDep p False f1 f2)) f2. + Proof. + reflexivity. + Defined. + + Definition not__eq (b : Bool) : @identity Bool (not b) (ite Bool b False True). + Proof. + reflexivity. + Defined. + + Definition and__eq (b1 b2 : Bool) : @identity Bool (and b1 b2) (ite Bool b1 b2 False). + Proof. + reflexivity. + Defined. + + Definition or__eq (b1 b2 : Bool) : @identity Bool (or b1 b2) (ite Bool b1 True b2). + Proof. + reflexivity. + Defined. + + Definition xor__eq (b1 b2 : Bool) : @identity Bool (xor b1 b2) (ite Bool b1 (not b2) b2). + Proof. + destruct b1; destruct b2; reflexivity. + Defined. + +(* *) + (* Definition eq__eq (b1 b2 : Bool) : @identity Bool (eq b1 b2) (ite Bool b1 b2 (not b2)). *) + (* Proof. *) + (* destruct b1; destruct b2; reflexivity. *) + (* Defined. *) + (* *) + + Theorem ite_bit (b c d : Bool) : Eq Bool (ite Bool b c d) (and (or (not b) c) (or b d)). + Proof. + destruct b, c, d; reflexivity. + Qed. + + (* TODO: doesn't actually coerce *) + Definition sawCoerce {T : Type} (a b : Type) (_ : T) (x : a) := x. + + (* TODO: doesn't actually coerce *) + Definition sawUnsafeCoerce (a b : Type) (x : a) := x. + + Definition Nat := nat. + Definition Nat_rect := nat_rect. + + (* Definition minNat := Nat.min. *) + + Definition uncurry (a b c : Type) (f : a -> b -> c) (p : a * (b * unit)) : c := + f (fst p) (fst (snd p)). + + Definition widthNat (n : Nat) : Nat := 1 + Nat.log2 n. + + Definition divModNat (x y : Nat) : (Nat * Nat) := + match y with + | 0 => (y, y) + | S y'=> + let (p, q) := Nat.divmod x y' 0 y' in + (p, y' - q) + end. + + Definition id := @id. + Definition PairType := prod. + Definition PairValue := @pair. + Definition Pair__rec := prod_rect. + Definition fst {A B} := @fst A B. + Definition snd {A B} := @snd A B. + Definition Zero := O. + Definition Succ := S. + +End SCS. + +Preprocess Module SCS as SCS'. diff --git a/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCoreVectorsAsCoqLists.v b/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCoreVectorsAsCoqLists.v new file mode 100644 index 0000000000..4655efe87f --- /dev/null +++ b/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCoreVectorsAsCoqLists.v @@ -0,0 +1,87 @@ +From Coq.Lists Require Import List. +From Coq.Numbers.NatInt Require NZLog. +From Coq.Strings Require String. +From CryptolToCoq Require Import SAWCoreScaffolding. + +Import ListNotations. + +Definition Vec (n : nat) (a : Type) : Type := list a. + +Fixpoint gen (n : nat) (a : Type) (f : nat -> a) {struct n} : Vec n a. + refine ( + match n with + | O => [] + | S n' => f O :: gen n' _ (fun n => f (S n)) + end + ). +Defined. + +Fixpoint atWithDefault (n : nat) (a : Type) (default : a) (v : Vec n a) (index : nat) : a. + refine ( + match n with + | O => default + | S n' => + match v with + | [] => default + | h :: t => + match index with + | O => h + | S index' => atWithDefault n' _ default t index' + end + end + end + ). +Defined. + +Definition map (a b : Type) (f : a -> b) (n : Nat) (xs : Vec n a) := + map f xs. + +Fixpoint foldr (a b : Type) (n : Nat) (f : a -> b -> b) (base : b) (v : Vec n a) : b := + match n with + | O => base + | S n' => + match v with + | [] => base + | hd :: tl => f hd (foldr _ _ n' f base tl) + end + end. + +(* Definition atWithDefault := VectorExtra.atWithDefault. *) +Definition EmptyVec := @nil. +(* Definition gen := VectorExtra.gen. *) + +Definition coerceVec (a : sort 0) (m n : Nat) (eq : Eq Nat m n) (v : Vec m a) : Vec n a := + match + identity_sym eq in identity _ n' + return Vec n' a -> Vec n a + with + | identity_refl _ => fun x => x + end v. + +Theorem gen_add m n T : forall f, gen (m + n) T f = gen m T f ++ gen n T (fun x => f (m + x)). +Proof. + induction m; intros. + { + simpl. + reflexivity. + } + { + simpl. + f_equal. + now rewrite IHm. + } +Qed. + +Fixpoint zipFunctional (a b : sort 0) (m n : Nat) (xs : Vec m a) (ys : Vec n b) + : Vec (Nat.min m n) (a * b) := + match (m, n) with + | (S m', S n') => + match (xs, ys) with + | (x :: xs, y :: ys) => (x, y) :: zipFunctional _ _ m' n' xs ys + | _ => [] + end + | _ => [] + end. + +Definition zipWithFunctional (a b c : Type) (f : a -> b -> c) (n : Nat) (xs : Vec n a) (ys : Vec n b) := + map _ _ (fun p => f (fst p) (snd p)) n (zipFunctional _ _ _ _ xs ys). diff --git a/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCoreVectorsAsCoqVectors.v b/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCoreVectorsAsCoqVectors.v new file mode 100644 index 0000000000..df1ae70b16 --- /dev/null +++ b/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCoreVectorsAsCoqVectors.v @@ -0,0 +1,355 @@ +From Bits Require Import operations. +From Bits Require Import spec. + +From Coq Require Import Lists.List. +From Coq Require Numbers.NatInt.NZLog. +From Coq Require Import PeanoNat. +From Coq Require Import Strings.String. +From Coq Require Import Vectors.Vector. +From Coq Require Import Bool.Bool. +From Coq Require Import BinNums. + +From CryptolToCoq Require Import SAWCoreScaffolding. + +From mathcomp Require Import ssreflect. +From mathcomp Require Import ssrnat. +From mathcomp Require Import ssrbool. +From mathcomp Require Import fintype. +From mathcomp Require Import tuple. + +From Coq Require Export ZArith.BinIntDef. + +Import VectorNotations. + +Definition Vec (n : nat) (a : Type) : Type := VectorDef.t a n. + +Fixpoint gen (n : nat) (a : Type) (f : nat -> a) {struct n} : Vec n a. + refine ( + match n with + | O => Vector.nil _ + | S p => Vector.cons _ (f O) _ (gen _ _ (fun n => f (S n))) + end + ). +Defined. + +Theorem gen_domain_eq n T : forall f g (domain_eq : forall i, f i = g i), + gen n T f = gen n T g. +Proof. + move : n. + elim => [|n' IH] f g DEQ. + { reflexivity. } + { + simpl. + f_equal. + { + apply DEQ. + } + { + apply IH. + intuition. + } + } +Qed. + +Fixpoint genOrdinal (n : nat) (a : Type) {struct n} + : forall (f : 'I_n -> a), Vec n a. + refine ( + match n as n' with + | O => fun _ => Vector.nil _ + | S p => + fun f => + Vector.cons + _ + (f (Ordinal (ltn0Sn _))) + _ + (genOrdinal _ _ (fun q => f (rshift 1 q))) + end + ). +Defined. + +Theorem genOrdinal_domain_eq n T : forall f g (domain_eq : forall i, f i = g i), + genOrdinal n T f = genOrdinal n T g. +Proof. + move : n. + elim => [|n' IH] f g DEQ. + { reflexivity. } + { + simpl. + f_equal. + { + apply DEQ. + } + { + apply IH. + intuition. + } + } +Qed. + +Fixpoint atWithDefault (n : nat) (a : Type) (default : a) (v : Vec n a) (index : nat) : a. + refine ( + match v with + | Vector.nil => default + | Vector.cons h n' t => + match index with + | O => h + | S index' => atWithDefault n' _ default t index' + end + end + ). +Defined. + +Definition map (a b : Type) (f : a -> b) (n : Nat) (xs : Vec n a) := + VectorDef.map f xs. + +Fixpoint foldr (a b : Type) (n : Nat) (f : a -> b -> b) (base : b) (v : Vec n a) : b := + match v with + | Vector.nil => base + | Vector.cons hd _ tl => f hd (foldr _ _ _ f base tl) + end. + +Fixpoint foldl_dep (a : Type) (b : Nat -> Type) (n : Nat) + (f : forall n, b n -> a -> b (S n)) (base : b O) (v : Vec n a) : b n := + match v with + | Vector.nil => base + | Vector.cons hd _ tl => foldl_dep a (fun n => b (S n)) _ (fun n => f (S n)) (f _ base hd) tl + end. + +Fixpoint tuple_foldl_dep (a : Type) (b : Nat -> Type) (n : Nat) + (f : forall n, b n -> a -> b (S n)) (base : b O) (t : n .-tuple a) : b n := + match n, t with + | O, _ => base + | S m, t => let (hd, tl) := (thead t, behead_tuple t) + in tuple_foldl_dep a (fun n => b (S n)) _ (fun n => f (S n)) (f _ base hd) tl + end. + +Definition EmptyVec := Vector.nil. + +Definition coerceVec (a : sort 0) (m n : Nat) (eq : Eq Nat m n) (v : Vec m a) : Vec n a := + match + identity_sym eq in identity _ n' + return Vec n' a -> Vec n a + with + | identity_refl => fun x => x + end v. + +Theorem gen_add m n T : forall f, gen (m + n) T f = Vector.append (gen m T f) (gen n T (fun x => f (m + x))). +Proof. + induction m; intros. + { + simpl. + reflexivity. + } + { + simpl. + f_equal. + now rewrite IHm. + } +Qed. + +(* NOTE: This version of `zip` accepts two vectors of different size, unlike the + * one in `CoqVectorsExtra.v` *) +Fixpoint zipFunctional (a b : sort 0) (m n : Nat) (xs : Vec m a) (ys : Vec n b) + : Vec (Nat.min m n) (a * b) := + match + xs in Vector.t _ m' + return Vector.t _ (Nat.min m' n) + with + | Vector.nil => Vector.nil _ + | Vector.cons x pm xs => + match + ys in Vector.t _ n' + return Vector.t _ (Nat.min (S pm) n') + with + | Vector.nil => Vector.nil _ + | Vector.cons y pm' ys => Vector.cons _ (x, y) _ (zipFunctional _ _ _ _ xs ys) + end + end +. + +Definition zipWithFunctional + (a b c : Type) (f : a -> b -> c) (n : Nat) (xs : Vec n a) (ys : Vec n b) := + VectorDef.map (fun p => f (fst p) (snd p)) (zipFunctional _ _ _ _ xs ys). + +Definition bitvector (n : Nat) : Type := Vector.t bool n. + +(* NOTE BITS are stored in reverse order than bitvector *) +Definition bvToBITS {size : nat} : bitvector size -> BITS size + := foldl_dep bool BITS size (fun _ bs b => joinlsb (bs, b)) nilB. + +Arguments bvToBITS : simpl never. + +(* NOTE BITS are stored in reverse order than bitvector *) +Definition bitsToBv {size : nat} : BITS size -> bitvector size + := tuple_foldl_dep bool bitvector size (fun _ bv b => Vector.cons _ b _ bv) (Vector.nil _). + +Arguments bitsToBv : simpl never. + +Definition joinLSB {n} (v : bitvector n) (lsb : bool) : bitvector n.+1 := + Vector.shiftin lsb v. + +(* NOTE This can cause Coq to stack overflow, avoid it as much as possible! *) +Fixpoint bvNat (size : Nat) (number : Nat) : bitvector size := + bitsToBv (fromNat number). +(* if size is size'.+1 *) +(* then joinLSB (bvNat size' (number./2)) (odd number) *) +(* else Vector.nil _ *) +(* . *) + +(* Arguments bvNat : simpl never. *) + +Definition bvToNatFolder (n : nat) (b : bool) := b + n.*2. + +Fixpoint bvToNat (size : Nat) (v : bitvector size) : Nat := + Vector.fold_left bvToNatFolder 0 v. + +(* This is used to write literals of bitvector type, e.g. intToBv 64 3 *) +Definition intToBv (n : Nat) (z : Z) : bitvector n := bitsToBv (fromZ z). + +Arguments intToBv : simpl never. + +Definition bvToInt (n : Nat) (b : bitvector n) : Z := toPosZ (bvToBITS b). + +Definition sbvToInt (n : Nat) (b : bitvector n) : Z + := match n, b with + | O, _ => 0 + | S n, b => toZ (bvToBITS b) + end. + +(* Useful notation for bools *) +Definition boolToInt (b : bool) : Z := if b then 1%Z else 0%Z. +Numeral Notation bool Z.odd boolToInt : bool_scope. + +(* This is annoying to implement, so using BITS conversion *) +Definition bvAdd (n : nat) (a : bitvector n) (b : bitvector n) + : bitvector n + := bitsToBv (addB (bvToBITS a) (bvToBITS b)). +Global Opaque bvAdd. + +(* This is annoying to implement, so using BITS conversion *) +Definition bvSub (n : nat) (a : bitvector n) (b : bitvector n) + : bitvector n + := bitsToBv (subB (bvToBITS a) (bvToBITS b)). +Global Opaque bvSub. + +(* This is annoying to implement, so using BITS conversion *) +Definition bvMul (n : nat) (a : bitvector n) (b : bitvector n) + : bitvector n + := bitsToBv (mulB (bvToBITS a) (bvToBITS b)). +Global Opaque bvMul. + +(* This is annoying to implement, so using BITS conversion *) +Definition bvNeg (n : nat) (a : bitvector n) + : bitvector n + := bitsToBv (invB (bvToBITS a)). +Global Opaque bvNeg. + +(* FIXME this is not implemented *) +Definition bvUDiv (n : nat) (a : bitvector n) (b : bitvector n) + : bitvector n + := a. +Global Opaque bvUDiv. + +(* FIXME this is not implemented *) +Definition bvURem (n : nat) (a : bitvector n) (b : bitvector n) + : bitvector n + := a. +Global Opaque bvURem. + +(* FIXME this is not implemented *) +Definition bvSDiv (n : nat) (a : bitvector n.+1) (b : bitvector n.+1) + : bitvector n.+1 + := a. +Global Opaque bvSDiv. + +(* FIXME this is not implemented *) +Definition bvSRem (n : nat) (a : bitvector n.+1) (b : bitvector n.+1) + : bitvector n.+1 + := a. +Global Opaque bvSRem. + +(* FIXME this is not implemented (base 2 logarithm) *) +Definition bvLg2 (n : nat) (a : bitvector n) + : bitvector n + := a. +Global Opaque bvLg2. + +(* FIXME this is not implemented *) +Definition bvSShr (w : nat) (a : bitvector w.+1) (n : nat) + : bitvector w.+1 + := a. +Global Opaque bvSShr. + +Definition bvShl (w : nat) (a : bitvector w) (n : nat) + : bitvector w + := a. +Global Opaque bvShl. + +Definition bvShr (w : nat) (a : bitvector w) (n : nat) + : bitvector w + := a. +Global Opaque bvShr. + +(* FIXME this is not implemented *) +Definition rotateL (n : nat) (A : Type) (v : Vector.t A n) (i : nat) + : Vector.t A n + := v. +Global Opaque rotateL. + +(* FIXME this is not implemented *) +Definition rotateR (n : nat) (A : Type) (v : Vector.t A n) (i : nat) + : Vector.t A n + := v. +Global Opaque rotateR. + +Fixpoint shiftL (n : nat) (A : Type) (x : A) (v : Vector.t A n) (i : nat) + : Vector.t A n + := match i with + | O => v + | S i' => Vector.tl (Vector.shiftin x (shiftL n A x v i')) + end. + +Fixpoint shiftR (n : nat) (A : Type) (x : A) (v : Vector.t A n) (i : nat) + : Vector.t A n + := match i with + | O => v + | S i' => Vector.shiftout (cons _ x _ (shiftL n A x v i')) + end. + +(* This is annoying to implement, so using BITS conversion *) +Definition bvult (n : nat) (a : bitvector n) (b : bitvector n) : Bool := + ltB (bvToBITS a) (bvToBITS b). +Global Opaque bvult. + +Definition bvugt (n : nat) (a : bitvector n) (b : bitvector n) : Bool := + bvult n b a. + +(* This is annoying to implement, so using BITS conversion *) +Definition bvule (n : nat) (a : bitvector n) (b : bitvector n) : Bool := + leB (bvToBITS a) (bvToBITS b). +Global Opaque bvule. + +Definition bvuge (n : nat) (a : bitvector n) (b : bitvector n) : Bool := + bvule n b a. + +Definition sign {n : nat} (a : bitvector n) : Bool := + match a with + | Vector.nil => false + | Vector.cons b _ _ => b + end. + +Definition bvslt (n : nat) (a : bitvector n) (b : bitvector n) : Bool := + let c := bvSub n a b + in (sign a && ~~ sign b) || (sign a && sign c) || (~~ sign b && sign c). + (* ^ equivalent to: boolEq (bvSBorrow s a b) (sign (bvSub n a b)) *) +Global Opaque bvslt. + +Definition bvsgt (n : nat) (a : bitvector n) (b : bitvector n) : Bool := + bvslt n b a. + +Definition bvsle (n : nat) (a : bitvector n) (b : bitvector n) : Bool := + bvslt n a b || (Vector.eqb _ eqb a b). +Global Opaque bvsle. + +Definition bvsge (n : nat) (a : bitvector n) (b : bitvector n) : Bool := + bvsle n b a. diff --git a/saw-core-coq/saw-core-coq.cabal b/saw-core-coq/saw-core-coq.cabal new file mode 100644 index 0000000000..b157b8d45a --- /dev/null +++ b/saw-core-coq/saw-core-coq.cabal @@ -0,0 +1,41 @@ +name: saw-core-coq +version: 0.1 +license: BSD3 +license-file: LICENSE +author: Galois, Inc. +maintainer: atomb@galois.com +copyright: (c) 2018 Galois Inc. +category: Formal Methods +build-type: Simple +cabal-version: >= 1.8 +synopsis: SAWCore backend for Coq +description: + A backend for translating terms in the SAWCore intermediate language + into the syntax of Coq + +library + build-depends: + base == 4.*, + cryptol, + cryptol-saw-core, + containers, + interpolate, + lens, + mtl, + prettyprinter, + saw-core, + text, + parameterized-utils, + bv-sized, + vector + hs-source-dirs: src + exposed-modules: + Language.Coq.AST + Language.Coq.Pretty + Verifier.SAW.Translation.Coq + Verifier.SAW.Translation.Coq.CryptolModule + Verifier.SAW.Translation.Coq.SAWModule + Verifier.SAW.Translation.Coq.Monad + Verifier.SAW.Translation.Coq.Term + Verifier.SAW.Translation.Coq.SpecialTreatment + ghc-options: -Wall -Werror diff --git a/saw-core-coq/saw/generate_scaffolding.saw b/saw-core-coq/saw/generate_scaffolding.saw new file mode 100644 index 0000000000..645db4a8d3 --- /dev/null +++ b/saw-core-coq/saw/generate_scaffolding.saw @@ -0,0 +1,3 @@ +enable_experimental; +write_coq_sawcore_prelude "../coq/generated/CryptolToCoq/SAWCorePrelude.v" [] []; +write_coq_cryptol_primitives_for_sawcore "../coq/generated/CryptolToCoq/CryptolPrimitivesForSAWCore.v" [] []; diff --git a/saw-core-coq/src/Language/Coq/AST.hs b/saw-core-coq/src/Language/Coq/AST.hs new file mode 100644 index 0000000000..58807e518c --- /dev/null +++ b/saw-core-coq/src/Language/Coq/AST.hs @@ -0,0 +1,75 @@ +{- | +Module : Language.Coq.AST +Copyright : Galois, Inc. 2018 +License : BSD3 +Maintainer : atomb@galois.com +Stability : experimental +Portability : portable +-} + +module Language.Coq.AST where + +type Ident = String + +data Sort + = Prop + | Set + | Type + deriving (Show) + +data Term + = Lambda [Binder] Term + | Fix Ident [Binder] Term Term + | Pi [PiBinder] Term + | Let Ident [Binder] (Maybe Type) Term Term + | If Term Term Term + | App Term [Term] + | Sort Sort + | Var Ident + -- | A variable that needs to be printed with a leading at sign in order to + -- make all arguments explicit + | ExplVar Ident + | NatLit Integer + | ZLit Integer + | List [Term] + | StringLit String + | Scope Term String + | Ltac String + deriving (Show) + +-- | Type synonym useful for indicating when a term is used as a type. +type Type = Term + +data Binder + = Binder Ident (Maybe Type) + deriving (Show) + +data PiBinder + = PiBinder (Maybe Ident) Type + deriving (Show) + +-- Because saw-core does not give very helpful access to the parameters and +-- indices, we just follow their style and define the constructor by its fully +-- applied return type. +data Constructor = Constructor + { constructorName :: Ident + , constructorType :: Term + } + deriving (Show) + +data Inductive = Inductive + { inductiveName :: Ident + , inductiveParameters :: [Binder] + , inductiveIndices :: [PiBinder] + , inductiveSort :: Sort + , inductiveConstructors :: [Constructor] + } + deriving (Show) + +data Decl + = Axiom Ident Type + | Comment String + | Definition Ident [Binder] (Maybe Type) Term + | InductiveDecl Inductive + | Snippet String + deriving (Show) diff --git a/saw-core-coq/src/Language/Coq/Pretty.hs b/saw-core-coq/src/Language/Coq/Pretty.hs new file mode 100644 index 0000000000..7b144cc983 --- /dev/null +++ b/saw-core-coq/src/Language/Coq/Pretty.hs @@ -0,0 +1,189 @@ +{-# LANGUAGE RecordWildCards #-} + +{- | +Module : Language.Coq.Pretty +Copyright : Galois, Inc. 2018 +License : BSD3 +Maintainer : atomb@galois.com +Stability : experimental +Portability : portable +-} + +module Language.Coq.Pretty where + +import Prettyprinter + +import Language.Coq.AST +import Data.Word +import Numeric (showHex) +import Prelude hiding ((<$>), (<>)) + +-- | Replace all occurrences of the double quote character @"@ with the string +-- @""@, i.e., two copies of it, as this is how Coq escapes double quote +-- characters. +escapeStringLit :: String -> String +escapeStringLit = concat . map (\c -> if c == '"' then "\"\"" else [c]) + +text :: String -> Doc ann +text = pretty + +string :: String -> Doc ann +string = pretty + +integer :: Integer -> Doc ann +integer = pretty + +-- TODO: import SAWCore pretty-printer? +tightSepList :: Doc ann -> [Doc ann] -> Doc ann +tightSepList _ [] = mempty +tightSepList _ [d] = d +tightSepList s (d:l) = d <> s <+> tightSepList s l + +looseSepList :: Doc ann -> [Doc ann] -> Doc ann +looseSepList _ [] = mempty +looseSepList _ [d] = d +looseSepList s (d:l) = d <+> s <+> looseSepList s l + +commaSepList, starSepList, semiSepList :: [Doc ann] -> Doc ann +commaSepList = tightSepList comma +starSepList = looseSepList (text "*") +semiSepList = tightSepList semi + +period :: Doc ann +period = text "." + +ppIdent :: Ident -> Doc ann +ppIdent = text + +ppBinder :: Binder -> Doc ann +ppBinder (Binder x Nothing) = ppIdent x +ppBinder (Binder x (Just t)) = parens (ppIdent x <+> colon <+> ppTerm PrecNone t) + +ppPiBinder :: PiBinder -> Doc ann +ppPiBinder (PiBinder Nothing t) = ppTerm PrecApp t <+> text "->" +ppPiBinder (PiBinder (Just x) t) = + text "forall" <+> parens (ppIdent x <+> colon <+> ppTerm PrecNone t) <> comma + +ppBinders :: [Binder] -> Doc ann +ppBinders = hsep . map ppBinder + +ppMaybeTy :: Maybe Type -> Doc ann +ppMaybeTy Nothing = mempty +ppMaybeTy (Just ty) = colon <+> ppTerm PrecNone ty + +ppSort :: Sort -> Doc ann +ppSort Prop = text "Prop" +ppSort Set = text "Set" +ppSort Type = text "Type" + +ppPi :: [PiBinder] -> Doc ann +ppPi bs = hsep (map ppPiBinder bs) + +data Prec + = PrecNone + | PrecLambda + | PrecApp + | PrecAtom + deriving (Eq, Ord) + +parensIf :: Bool -> Doc ann -> Doc ann +parensIf p d = if p then parens d else d + +ppTerm :: Prec -> Term -> Doc ann +ppTerm p e = + case e of + Lambda bs t -> + parensIf (p > PrecLambda) $ + (text "fun" <+> ppBinders bs <+> text "=>" <+> ppTerm PrecLambda t) + Fix ident binders returnType body -> + parensIf (p > PrecLambda) $ + (text "fix" <+> text ident <+> ppBinders binders <+> text ":" + <+> ppTerm PrecNone returnType <+> text ":=" <+> ppTerm PrecLambda body) + Pi bs t -> + parensIf (p > PrecLambda) $ + ppPi bs <+> ppTerm PrecLambda t + Let x bs mty t body -> + parensIf (p > PrecLambda) $ + fillSep + [ text "let" <+> ppIdent x <+> ppBinders bs <+> ppMaybeTy mty <+> + text ":=" <+> ppTerm PrecNone t <+> text "in" + , ppTerm PrecLambda body ] + If c t f -> + parensIf (p > PrecLambda) $ + text "if" <+> ppTerm PrecNone c <+> + text "then" <+> ppTerm PrecNone t <+> + text "else" <+> ppTerm PrecLambda f + App f [] -> + ppTerm p f + App f args -> + parensIf (p > PrecApp) $ + hsep (ppTerm PrecApp f : map (ppTerm PrecAtom) args) + Sort s -> + ppSort s + Var x -> ppIdent x + ExplVar x -> + parensIf (p > PrecApp) $ + string "@" <> ppIdent x + NatLit i -> + integer i + ZLit i -> + -- we use hex unless our integer is a positive or negitive digit + if abs i > 9 then let ui = toInteger (fromInteger i :: Word64) + in text ("0x" ++ showHex ui [] ++ "%Z") + else if i < 0 then text ("(" ++ show i ++ ")%Z") + else text (show i ++ "%Z") + List ts -> + brackets (semiSepList (map (ppTerm PrecNone) ts)) + StringLit s -> + dquotes (string $ escapeStringLit s) + Scope term scope -> + ppTerm PrecAtom term <> text "%" <> text scope + Ltac s -> + text "ltac:" <> parens (string s) + +ppDecl :: Decl -> Doc ann +ppDecl decl = case decl of + Axiom nm ty -> + (nest 2 $ + hsep ([text "Axiom", text nm, text ":", ppTerm PrecNone ty, period])) <> hardline + Comment s -> + text "(*" <+> text s <+> text "*)" <> hardline + Definition nm bs mty body -> + (nest 2 $ + vsep + [ hsep ([text "Definition", text nm] ++ + map ppBinder bs ++ + [ppMaybeTy mty, text ":="]) + , ppTerm PrecNone body <> period + ]) <> hardline + InductiveDecl ind -> ppInductive ind + Snippet s -> text s + +ppConstructor :: Constructor -> Doc ann +ppConstructor (Constructor {..}) = + nest 2 $ + hsep ([ text "|" + , text constructorName + , text ":" + , ppTerm PrecNone constructorType + ] + ) + +ppInductive :: Inductive -> Doc ann +ppInductive (Inductive {..}) = + (vsep + ([ nest 2 $ + hsep ([ text "Inductive" + , text inductiveName + ] + ++ map ppBinder inductiveParameters + ++ [ text ":" ] + ++ map ppPiBinder inductiveIndices + ++ [ ppSort inductiveSort ] + ++ [ text ":="] + ) + ] + <> map ppConstructor inductiveConstructors + <> [ period ] + ) + ) <> hardline diff --git a/saw-core-coq/src/Verifier/SAW/Translation/Coq.hs b/saw-core-coq/src/Verifier/SAW/Translation/Coq.hs new file mode 100644 index 0000000000..e14bcefbe3 --- /dev/null +++ b/saw-core-coq/src/Verifier/SAW/Translation/Coq.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +{- | +Module : Verifier.SAW.Translation.Coq +Copyright : Galois, Inc. 2018 +License : BSD3 +Maintainer : atomb@galois.com +Stability : experimental +Portability : portable +-} + +module Verifier.SAW.Translation.Coq ( + TranslationConfiguration(..), + moduleDeclName, + preamble, + TermTranslation.translateDefDoc, + translateTermAsDeclImports, + translateCryptolModule, + translateSAWModule, + ) where + +import Control.Monad.Reader hiding (fail) +import Data.String.Interpolate (i) +import Prelude hiding (fail) +import Prettyprinter + +import qualified Language.Coq.AST as Coq +import qualified Language.Coq.Pretty as Coq +import Verifier.SAW.Module +import Verifier.SAW.SharedTerm +import Verifier.SAW.Term.Functor +-- import Verifier.SAW.Term.CtxTerm +import qualified Verifier.SAW.Translation.Coq.CryptolModule as CryptolModuleTranslation +import qualified Verifier.SAW.Translation.Coq.SAWModule as SAWModuleTranslation +import Verifier.SAW.Translation.Coq.Monad +import Verifier.SAW.Translation.Coq.SpecialTreatment +import qualified Verifier.SAW.Translation.Coq.Term as TermTranslation +import Verifier.SAW.TypedTerm +--import Verifier.SAW.Term.Pretty +-- import qualified Verifier.SAW.UntypedAST as Un + +--import Debug.Trace + +-- showFTermF :: FlatTermF Term -> String +-- showFTermF = show . Unshared . FTermF + +-- mkCoqIdent :: String -> String -> Ident +-- mkCoqIdent coqModule coqIdent = mkIdent (mkModuleName [coqModule]) coqIdent + +{- +traceFTermF :: String -> FlatTermF Term -> a -> a +traceFTermF ctx tf = traceTerm ctx (Unshared $ FTermF tf) + +traceTerm :: String -> Term -> a -> a +traceTerm ctx t a = trace (ctx ++ ": " ++ showTerm t) a +-} + +-- translateBinder :: +-- TermTranslationMonad m => +-- (Ident, Term) -> m (Coq.Ident, Coq.Term) +-- translateBinder (ident, term) = +-- (,) +-- <$> pure (translateIdent ident) +-- <*> translateTerm term + +-- dropModuleName :: String -> String +-- dropModuleName s = +-- case elemIndices '.' s of +-- [] -> s +-- indices -> +-- let lastIndex = last indices in +-- drop (lastIndex + 1) s + +-- unqualifyTypeWithinConstructor :: Coq.Term -> Coq.Term +-- unqualifyTypeWithinConstructor = go +-- where +-- go (Coq.Pi bs t) = Coq.Pi bs (go t) +-- go (Coq.App t as) = Coq.App (go t) as +-- go (Coq.Var v) = Coq.Var (dropModuleName v) +-- go t = error $ "Unexpected term in constructor: " ++ show t + +-- | This is a convenient helper for when you want to add some bindings before +-- translating a term. +-- translateTermLocallyBinding :: ModuleTranslationMonad m => [String] -> Term -> m Coq.Term +-- translateTermLocallyBinding bindings term = +-- withLocalEnvironment $ do +-- modify $ over environment (bindings ++) +-- translateTerm term + +text :: String -> Doc ann +text = pretty + +-- | Eventually, different modules may want different preambles. For now, +-- we hardcode a sufficient set of imports for all our purposes. +preamble :: TranslationConfiguration -> Doc ann +preamble (TranslationConfiguration { vectorModule, postPreamble }) = text [i| +(** Mandatory imports from saw-core-coq *) +From Coq Require Import Lists.List. +From Coq Require Import String. +From Coq Require Import Vectors.Vector. +From CryptolToCoq Require Import SAWCoreScaffolding. +From CryptolToCoq Require Import #{vectorModule}. +Import ListNotations. + +(** Post-preamble section specified by you *) +#{postPreamble} + +(** Code generated by saw-core-coq *) +|] + +translateTermAsDeclImports :: + TranslationConfiguration -> Coq.Ident -> Term -> Either (TranslationError Term) (Doc ann) +translateTermAsDeclImports configuration name t = do + doc <- TermTranslation.translateDefDoc configuration Nothing [] name t + return $ vcat [preamble configuration, hardline <> doc] + +translateSAWModule :: TranslationConfiguration -> Module -> Doc ann +translateSAWModule configuration m = + let name = show $ translateModuleName (moduleName m) + in + vcat $ [] + ++ [ text $ "Module " ++ name ++ "." + , "" + ] + ++ [ SAWModuleTranslation.translateDecl configuration (Just $ moduleName m) decl + | decl <- moduleDecls m ] + ++ [ text $ "End " ++ name ++ "." + , "" + ] + +translateCryptolModule :: + TranslationConfiguration -> [String] -> CryptolModule -> Either (TranslationError Term) (Doc ann) +translateCryptolModule configuration globalDecls m = + let decls = CryptolModuleTranslation.translateCryptolModule + configuration + globalDecls + m + in + vcat . map Coq.ppDecl <$> decls + +moduleDeclName :: ModuleDecl -> String +moduleDeclName (TypeDecl (DataType { dtName })) = identName dtName +moduleDeclName (DefDecl (Def { defIdent })) = identName defIdent diff --git a/saw-core-coq/src/Verifier/SAW/Translation/Coq/CryptolModule.hs b/saw-core-coq/src/Verifier/SAW/Translation/Coq/CryptolModule.hs new file mode 100644 index 0000000000..8f47a8c931 --- /dev/null +++ b/saw-core-coq/src/Verifier/SAW/Translation/Coq/CryptolModule.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE FlexibleContexts #-} +-- | + +module Verifier.SAW.Translation.Coq.CryptolModule where + +import Control.Lens (over, set, view) +import Control.Monad (forM) +import Control.Monad.State (modify) +import qualified Data.Map as Map + +import Cryptol.ModuleSystem.Name +import Cryptol.Utils.Ident +import qualified Language.Coq.AST as Coq +import Verifier.SAW.Term.Functor +import Verifier.SAW.Translation.Coq.Monad +import qualified Verifier.SAW.Translation.Coq.Term as TermTranslation +import Verifier.SAW.TypedTerm + +translateTypedTermMap :: + TermTranslation.TermTranslationMonad m => Map.Map Name TypedTerm -> m [Coq.Decl] +translateTypedTermMap tm = forM (Map.assocs tm) translateAndRegisterEntry + where + translateAndRegisterEntry (name, symbol) = do + let t = ttTerm symbol + let nameStr = unpackIdent (nameIdent name) + term <- TermTranslation.withLocalLocalEnvironment $ do + modify $ set TermTranslation.localEnvironment [nameStr] + TermTranslation.translateTerm t + let decl = TermTranslation.mkDefinition nameStr term + modify $ over TermTranslation.globalDeclarations (nameStr :) + return decl + +translateCryptolModule :: + TranslationConfiguration -> [String] -> CryptolModule -> Either (TranslationError Term) [Coq.Decl] +translateCryptolModule configuration globalDecls (CryptolModule _ tm) = + case TermTranslation.runTermTranslationMonad + configuration + Nothing + globalDecls + [] + (translateTypedTermMap tm) of + Left e -> Left e + Right (_, st) -> Right (reverse (view TermTranslation.localDeclarations st)) diff --git a/saw-core-coq/src/Verifier/SAW/Translation/Coq/Monad.hs b/saw-core-coq/src/Verifier/SAW/Translation/Coq/Monad.hs new file mode 100644 index 0000000000..f2a441a037 --- /dev/null +++ b/saw-core-coq/src/Verifier/SAW/Translation/Coq/Monad.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +{- | +Module : Verifier.SAW.Translation.Coq +Copyright : Galois, Inc. 2018 +License : BSD3 +Maintainer : atomb@galois.com +Stability : experimental +Portability : portable +-} + +module Verifier.SAW.Translation.Coq.Monad + ( TranslationConfiguration(..) + , TranslationConfigurationMonad + , TranslationMonad + , TranslationError(..) + , runTranslationMonad + ) where + +import qualified Control.Monad.Except as Except +import Control.Monad.Reader hiding (fail) +import Control.Monad.State hiding (fail, state) +import Prelude hiding (fail) + +import Verifier.SAW.SharedTerm +-- import Verifier.SAW.Term.CtxTerm +--import Verifier.SAW.Term.Pretty +-- import qualified Verifier.SAW.UntypedAST as Un + +data TranslationError a + = NotSupported a + | NotExpr a + | NotType a + | LocalVarOutOfBounds a + | BadTerm a + | CannotCreateDefaultValue a + +instance {-# OVERLAPPING #-} Show (TranslationError Term) where + show = showError showTerm + +instance {-# OVERLAPPABLE #-} Show a => Show (TranslationError a) where + show = showError show + +showError :: (a -> String) -> TranslationError a -> String +showError printer err = case err of + NotSupported a -> "Not supported: " ++ printer a + NotExpr a -> "Expecting an expression term: " ++ printer a + NotType a -> "Expecting a type term: " ++ printer a + LocalVarOutOfBounds a -> "Local variable reference is out of bounds: " ++ printer a + BadTerm a -> "Malformed term: " ++ printer a + CannotCreateDefaultValue a -> "Unable to generate a default value of the given type: " ++ printer a + +data TranslationConfiguration = TranslationConfiguration + { notations :: [(String, String)] + -- ^ We currently don't have a nice way of mapping Cryptol notations to Coq + -- notations. Instead, we provide a mapping from the notation symbol to an + -- identifier to use instead. + , monadicTranslation :: Bool + -- ^ Whether to wrap everything in a free monad construction. + -- - Advantage: fixpoints can be readily represented + -- - Disadvantage: pure computations look more gnarly + , postPreamble :: String + -- ^ Text to be concatenated at the end of the Coq preamble, before the code + -- generated by the translation. Usually consists of extra file imports, + -- module imports, scopes openings. + , skipDefinitions :: [String] + , vectorModule :: String + -- ^ all vector operations will be prepended with this module name, i.e. + -- ".append", etc. So that it can be retargeted easily. + -- Current provided options are: + -- - SAWCoreVectorsAsCoqLists + -- - SAWCoreVectorsAsCoqVectors + -- Currently considering adding: + -- - SAWCoreVectorsAsSSReflectSeqs + } + +type TranslationConfigurationMonad m = + ( MonadReader TranslationConfiguration m + ) + +type TranslationMonad s m = + ( Except.MonadError (TranslationError Term) m + , TranslationConfigurationMonad m + , MonadState s m + ) + +runTranslationMonad :: + TranslationConfiguration -> + s -> + (forall m. TranslationMonad s m => m a) -> + Either (TranslationError Term) (a, s) +runTranslationMonad configuration state m = runStateT (runReaderT m configuration) state diff --git a/saw-core-coq/src/Verifier/SAW/Translation/Coq/SAWModule.hs b/saw-core-coq/src/Verifier/SAW/Translation/Coq/SAWModule.hs new file mode 100644 index 0000000000..23dfb81774 --- /dev/null +++ b/saw-core-coq/src/Verifier/SAW/Translation/Coq/SAWModule.hs @@ -0,0 +1,183 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} + +{- | +Module : Verifier.SAW.Translation.Coq +Copyright : Galois, Inc. 2018 +License : BSD3 +Maintainer : atomb@galois.com +Stability : experimental +Portability : portable +-} + +module Verifier.SAW.Translation.Coq.SAWModule where + +import Control.Lens (makeLenses, view) +import qualified Control.Monad.Except as Except +import Control.Monad.Reader hiding (fail) +import Control.Monad.State hiding (fail) +import Prelude hiding (fail) +import Prettyprinter (Doc) + +import qualified Language.Coq.AST as Coq +import qualified Language.Coq.Pretty as Coq +import Verifier.SAW.Module +import Verifier.SAW.SharedTerm +import Verifier.SAW.Term.Functor +import Verifier.SAW.Translation.Coq.Monad +import Verifier.SAW.Translation.Coq.SpecialTreatment +import qualified Verifier.SAW.Translation.Coq.Term as TermTranslation + +-- import Debug.Trace + +data ModuleTranslationState = ModuleTranslationState + { _currentModule :: Maybe ModuleName + } + deriving (Show) +makeLenses ''ModuleTranslationState + +type ModuleTranslationMonad m = TranslationMonad ModuleTranslationState m + +runModuleTranslationMonad :: + TranslationConfiguration -> Maybe ModuleName -> + (forall m. ModuleTranslationMonad m => m a) -> + Either (TranslationError Term) (a, ModuleTranslationState) +runModuleTranslationMonad configuration modname = + runTranslationMonad configuration (ModuleTranslationState modname) + +dropPi :: Coq.Term -> Coq.Term +dropPi (Coq.Pi (_ : t) r) = Coq.Pi t r +dropPi (Coq.Pi _ r) = dropPi r +dropPi t = t + +translateCtor :: + ModuleTranslationMonad m => + [Coq.Binder] -> -- list of parameters to drop from `ctorType` + Ctor -> m Coq.Constructor +translateCtor inductiveParameters (Ctor {..}) = do + maybe_constructorName <- + liftTermTranslationMonad $ TermTranslation.translateIdentToIdent ctorName + let constructorName = case maybe_constructorName of + Just n -> identName n + Nothing -> error "translateCtor: unexpected translation for constructor" + constructorType <- + -- Unfortunately, `ctorType` qualifies the inductive type's name in the + -- return type. + -- dropModuleNameWithinCtor <$> + -- Unfortunately, `ctorType` comes with the inductive parameters universally + -- quantified. + (\ t -> iterate dropPi t !! length inductiveParameters) <$> + (liftTermTranslationMonad (TermTranslation.translateTerm ctorType)) + return $ Coq.Constructor + { constructorName + , constructorType + } + +translateDataType :: ModuleTranslationMonad m => DataType -> m Coq.Decl +-- translateDataType (DataType {..}) +-- | trace ("translateDataType: " ++ show dtName) False = undefined +translateDataType (DataType {..}) = + atDefSite <$> findSpecialTreatment dtName >>= \case + DefPreserve -> translateNamed $ identName dtName + DefRename _ targetName -> translateNamed $ targetName + DefReplace str -> return $ Coq.Snippet str + DefSkip -> return $ skipped dtName + where + translateNamed :: ModuleTranslationMonad m => Coq.Ident -> m Coq.Decl + translateNamed name = do + let inductiveName = name + (inductiveParameters, inductiveIndices) <- + liftTermTranslationMonad $ do + ps <- TermTranslation.translateParams dtParams + ixs <- TermTranslation.translateParams dtIndices + return (ps, map (\(Coq.Binder s (Just t)) -> Coq.PiBinder (Just s) t) ixs) + let inductiveSort = TermTranslation.translateSort dtSort + inductiveConstructors <- mapM (translateCtor inductiveParameters) dtCtors + return $ Coq.InductiveDecl $ Coq.Inductive + { inductiveName + , inductiveParameters + , inductiveIndices + , inductiveSort + , inductiveConstructors + } + +-- translateModuleDecl :: ModuleTranslationMonad m => ModuleDecl -> m Coq.Decl +-- translateModuleDecl = \case +-- TypeDecl dataType -> translateDataType dataType +-- DefDecl definition -> translateDef definition + +_mapped :: Ident -> Ident -> Coq.Decl +_mapped sawIdent newIdent = + Coq.Comment $ show sawIdent ++ " is mapped to " ++ show newIdent + +skipped :: Ident -> Coq.Decl +skipped sawIdent = + Coq.Comment $ show sawIdent ++ " was skipped" + +translateDef :: ModuleTranslationMonad m => Def -> m Coq.Decl +translateDef (Def {..}) = {- trace ("translateDef " ++ show defIdent) $ -} do + specialTreatment <- findSpecialTreatment defIdent + translateAccordingly (atDefSite specialTreatment) + + where + + translateAccordingly :: ModuleTranslationMonad m => DefSiteTreatment -> m Coq.Decl + translateAccordingly DefPreserve = translateNamed $ identName defIdent + translateAccordingly (DefRename _ targetName) = translateNamed $ targetName + translateAccordingly (DefReplace str) = return $ Coq.Snippet str + translateAccordingly DefSkip = return $ skipped defIdent + + translateNamed :: ModuleTranslationMonad m => Coq.Ident -> m Coq.Decl + translateNamed name = liftTermTranslationMonad (go defQualifier defBody) + + where + + go :: TermTranslation.TermTranslationMonad m => DefQualifier -> Maybe Term -> m Coq.Decl + go NoQualifier Nothing = error "Terms should have a body (unless axiom/primitive)" + go NoQualifier (Just body) = Coq.Definition + <$> pure name + <*> pure [] + <*> (Just <$> TermTranslation.translateTerm defType) + <*> TermTranslation.translateTerm body + go AxiomQualifier _ = Coq.Axiom + <$> pure name + <*> TermTranslation.translateTerm defType + go PrimQualifier _ = Coq.Axiom + <$> pure name + <*> TermTranslation.translateTerm defType + +liftTermTranslationMonad :: + (forall n. TermTranslation.TermTranslationMonad n => n a) -> + (forall m. ModuleTranslationMonad m => m a) +liftTermTranslationMonad n = do + configuration <- ask + cur_mod <- view currentModule <$> get + let r = TermTranslation.runTermTranslationMonad configuration cur_mod [] [] n + case r of + Left e -> Except.throwError e + Right (a, _) -> do + return a + +translateDecl :: TranslationConfiguration -> Maybe ModuleName -> ModuleDecl -> Doc ann +translateDecl configuration modname decl = + case decl of + TypeDecl td -> do + case runModuleTranslationMonad configuration modname (translateDataType td) of + Left e -> error $ show e + Right (tdecl, _) -> Coq.ppDecl tdecl + DefDecl dd -> do + case runModuleTranslationMonad configuration modname (translateDef dd) of + Left e -> error $ show e + Right (tdecl, _) -> Coq.ppDecl tdecl diff --git a/saw-core-coq/src/Verifier/SAW/Translation/Coq/SpecialTreatment.hs b/saw-core-coq/src/Verifier/SAW/Translation/Coq/SpecialTreatment.hs new file mode 100644 index 0000000000..bd2a5b71cb --- /dev/null +++ b/saw-core-coq/src/Verifier/SAW/Translation/Coq/SpecialTreatment.hs @@ -0,0 +1,486 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} + +{- | +Module : Verifier.SAW.Translation.Coq +Copyright : Galois, Inc. 2018 +License : BSD3 +Maintainer : atomb@galois.com +Stability : experimental +Portability : portable +-} + +module Verifier.SAW.Translation.Coq.SpecialTreatment where + +import Control.Lens (_1, _2, over) +import Control.Monad.Reader (ask) +import qualified Data.Map as Map +import Data.String.Interpolate (i) +import qualified Data.Text as Text +import Prelude hiding (fail) + +import qualified Language.Coq.AST as Coq +import Verifier.SAW.SharedTerm +import Verifier.SAW.Translation.Coq.Monad +import Verifier.SAW.Term.Functor + +data SpecialTreatment = SpecialTreatment + { moduleRenaming :: Map.Map ModuleName String + , identSpecialTreatment :: Map.Map ModuleName (Map.Map String IdentSpecialTreatment) + } + +data DefSiteTreatment + = DefPreserve + | DefRename (Maybe ModuleName) String -- optional module rename, then identifier itself + | DefReplace String + | DefSkip + +data UseSiteTreatment + = UsePreserve + | UseRename (Maybe ModuleName) String + | UseReplaceDropArgs Int Coq.Term + +data IdentSpecialTreatment = IdentSpecialTreatment + { atDefSite :: DefSiteTreatment + , atUseSite :: UseSiteTreatment + } + +moduleRenamingMap :: Map.Map ModuleName ModuleName +moduleRenamingMap = Map.fromList $ + over _1 (mkModuleName . (: [])) <$> + over _2 (mkModuleName . (: [])) <$> + [ ("Cryptol", "CryptolPrimitivesForSAWCore") + , ("Prelude", "SAWCorePrelude") + ] + +translateModuleName :: ModuleName -> ModuleName +translateModuleName mn = + Map.findWithDefault mn mn moduleRenamingMap + +findSpecialTreatment :: + TranslationConfigurationMonad m => + Ident -> m IdentSpecialTreatment +findSpecialTreatment ident = do + configuration <- ask + let moduleMap = + Map.findWithDefault Map.empty (identModule ident) (specialTreatmentMap configuration) + let defaultTreatment = + IdentSpecialTreatment + { atDefSite = DefPreserve + , atUseSite = UsePreserve + } + pure $ Map.findWithDefault defaultTreatment (identName ident) moduleMap + +-- Use `mapsTo` for identifiers whose definition has a matching definition +-- already on the Coq side. As such, their definition can be skipped, and use +-- sites can be replaced by the appropriate call. +mapsTo :: ModuleName -> String -> IdentSpecialTreatment +mapsTo targetModule targetName = IdentSpecialTreatment + { atDefSite = DefSkip + , atUseSite = UseRename (Just targetModule) targetName + } + +-- Use `realize` for axioms that can be realized, or for primitives that must be +-- realized. While some primitives can be written directly in a standalone Coq +-- module, some primitives depend on code from the extracted module, and are +-- depended upon by following code in the same module. Such primitives can +-- therefore *neither* be defined a priori, *nor* a posteriori, and must be +-- realized where they were originally declared. +realize :: String -> IdentSpecialTreatment +realize code = IdentSpecialTreatment + { atDefSite = DefReplace code + , atUseSite = UsePreserve + } + +-- Use `rename` for identifiers whose definition can be translated, but has to +-- be renamed. This is useful for certain definitions whose name on the +-- SAWCore/Cryptol side clashes with names on the Coq side. For instance, `at` +-- is a reserved Coq keyword, but is used as a function name in SAWCore Prelude. +-- Also useful for translation notations, until they are better supported. +rename :: String -> IdentSpecialTreatment +rename ident = IdentSpecialTreatment + { atDefSite = DefRename Nothing ident + , atUseSite = UseRename Nothing ident + } + +-- Replace any occurrences of identifier applied to @n@ arguments with the +-- supplied Coq term. If @n=0@ and the supplied Coq term is an identifier then +-- this is the same as 'rename'. +replaceDropArgs :: Int -> Coq.Term -> IdentSpecialTreatment +replaceDropArgs n term = IdentSpecialTreatment + { atDefSite = DefSkip + , atUseSite = UseReplaceDropArgs n term + } + +-- A version of 'replaceDropArgs' that drops no arguments; i.e., just replaces +-- an identifier with the supplied Coq term +replace :: Coq.Term -> IdentSpecialTreatment +replace = replaceDropArgs 0 + + +-- Use `skip` for identifiers that are already defined in the appropriate module +-- on the Coq side. +skip :: IdentSpecialTreatment +skip = IdentSpecialTreatment + { atDefSite = DefSkip + , atUseSite = UsePreserve + } + +sawDefinitionsModule :: ModuleName +sawDefinitionsModule = mkModuleName ["SAWCoreScaffolding"] + +compMModule :: ModuleName +compMModule = mkModuleName ["CompM"] + +sawVectorDefinitionsModule :: TranslationConfiguration -> ModuleName +sawVectorDefinitionsModule (TranslationConfiguration {..}) = + mkModuleName [vectorModule] + +cryptolPrimitivesModule :: ModuleName +cryptolPrimitivesModule = mkModuleName ["CryptolPrimitivesForSAWCore"] + +sawCoreScaffoldingModule :: ModuleName +sawCoreScaffoldingModule = mkModuleName ["SAWCoreScaffolding"] + +cryptolPreludeSpecialTreatmentMap :: Map.Map String IdentSpecialTreatment +cryptolPreludeSpecialTreatmentMap = Map.fromList $ [] + + ++ + [ ("Num_rec", mapsTo cryptolPrimitivesModule "Num_rect") -- automatically defined + , ("unsafeAssert_same_Num", skip) -- unsafe and unused + ] + +specialTreatmentMap :: TranslationConfiguration -> Map.Map ModuleName (Map.Map String IdentSpecialTreatment) +specialTreatmentMap configuration = Map.fromList $ + over _1 (mkModuleName . (: [])) <$> + [ ("Cryptol", cryptolPreludeSpecialTreatmentMap) + , ("Prelude", sawCorePreludeSpecialTreatmentMap configuration) + ] + +-- NOTE: while I initially did the mapping from SAW core names to the +-- corresponding Coq construct here, it makes the job of translating SAW core +-- axioms into Coq theorems much more annoying, because one needs to manually +-- rename every constant mentioned in the statement to its Coq counterpart. +-- Instead, I am now trying to keep the names the same as much as possible +-- during this translation (it is sometimes impossible, for instance, `at` is a +-- reserved keyword in Coq), so that primitives' and axioms' types can be +-- copy-pasted as is on the Coq side. +sawCorePreludeSpecialTreatmentMap :: TranslationConfiguration -> Map.Map String IdentSpecialTreatment +sawCorePreludeSpecialTreatmentMap configuration = + let vectorsModule = sawVectorDefinitionsModule configuration in + Map.fromList $ [] + + -- Unsafe SAW features + ++ + [ ("error", mapsTo sawDefinitionsModule "error") + , ("fix", skip) + , ("unsafeAssert", replaceDropArgs 3 $ Coq.Ltac "solveUnsafeAssert") + , ("unsafeCoerce", skip) + , ("unsafeCoerce_same", skip) + ] + + -- coercions + ++ + [ ("coerce", mapsTo sawDefinitionsModule "coerce") + , ("coerce__def", skip) + , ("coerce__eq", skip) + , ("rcoerce", skip) + ] + + -- Unit + ++ + [ ("Unit", mapsTo sawDefinitionsModule "Unit") + , ("UnitType", mapsTo sawDefinitionsModule "UnitType") + , ("UnitType__rec", mapsTo sawDefinitionsModule "UnitType__rec") + ] + + -- Records + ++ + [ ("EmptyType", skip) + , ("EmptyType__rec", skip) + , ("RecordType", skip) + , ("RecordType__rec", skip) + ] + + -- Decidable equality, does not make sense in Coq unless turned into a type + -- class + -- Apparently, this is not used much for Cryptol, so we can skip it. + ++ + [ ("eq", skip) -- MapsTo $ mkCoqIdent sawDefinitionsModule "eq") + , ("eq_bitvector", skip) + , ("eq_Bool", skip) -- MapsTo $ mkCoqIdent "CryptolToCoq.SAW" "eq_Bool") + , ("eq_Nat", skip) + , ("eq_refl", skip) -- MapsTo $ mkCoqIdent "CryptolToCoq.SAW" "eq_refl") + , ("eq_VecBool", skip) + , ("eq_VecVec", skip) + , ("ite_eq_cong_1", skip) + , ("ite_eq_cong_2", skip) + ] + + -- Boolean + ++ + [ ("and", mapsTo sawDefinitionsModule "and") + , ("and__eq", mapsTo sawDefinitionsModule "and__eq") + , ("Bool", mapsTo sawDefinitionsModule "Bool") + , ("boolEq", mapsTo sawDefinitionsModule "boolEq") + , ("boolEq__eq", mapsTo sawDefinitionsModule "boolEq__eq") + , ("False", mapsTo sawDefinitionsModule "false") + , ("ite", mapsTo sawDefinitionsModule "ite") + , ("iteDep", mapsTo sawDefinitionsModule "iteDep") + , ("iteDep_True", mapsTo sawDefinitionsModule "iteDep_True") + , ("iteDep_False", mapsTo sawDefinitionsModule "iteDep_False") + , ("ite_bit", skip) -- FIXME: change this + , ("ite_eq_iteDep", mapsTo sawDefinitionsModule "ite_eq_iteDep") + , ("not", mapsTo sawDefinitionsModule "not") + , ("not__eq", mapsTo sawDefinitionsModule "not__eq") + , ("or", mapsTo sawDefinitionsModule "or") + , ("or__eq", mapsTo sawDefinitionsModule "or__eq") + , ("True", mapsTo sawDefinitionsModule "true") + , ("xor", mapsTo sawDefinitionsModule "xor") + , ("xor__eq", mapsTo sawDefinitionsModule "xor__eq") + ] + + -- Pairs + ++ + [ ("PairType", mapsTo sawDefinitionsModule "PairType") + , ("PairValue", mapsTo sawDefinitionsModule "PairValue") + , ("Pair__rec", mapsTo sawDefinitionsModule "Pair__rec") + , ("fst", mapsTo sawDefinitionsModule "fst") + , ("snd", mapsTo sawDefinitionsModule "snd") + ] + + -- Equality + ++ + [ ("Eq", mapsTo sawDefinitionsModule "Eq") + , ("Eq__rec", mapsTo sawDefinitionsModule "Eq__rec") + , ("Refl", mapsTo sawDefinitionsModule "Refl") + , ("EqP", mapsTo sawDefinitionsModule "EqP") + , ("EqP__rec", mapsTo sawDefinitionsModule "EqP__rec") + , ("ReflP", mapsTo sawDefinitionsModule "ReflP") + ] + + -- Strings + ++ + [ ("String", mapsTo sawDefinitionsModule "String") + , ("equalString", mapsTo sawDefinitionsModule "equalString") + , ("appendString", mapsTo sawDefinitionsModule "appendString") + ] + + -- Utility functions + ++ + [ ("id", mapsTo sawDefinitionsModule "id") + ] + + -- Natural numbers + ++ + [ ("divModNat", mapsTo sawDefinitionsModule "divModNat") + , ("Nat", mapsTo sawDefinitionsModule "Nat") + , ("widthNat", mapsTo sawDefinitionsModule "widthNat") + , ("Zero", mapsTo sawCoreScaffoldingModule "Zero") + , ("Succ", mapsTo sawCoreScaffoldingModule "Succ") + ] + + -- Vectors + ++ + [ ("EmptyVec", mapsTo vectorsModule "EmptyVec") + , ("at", rename "sawAt") -- `at` is a reserved keyword in Coq + , ("atWithDefault", mapsTo vectorsModule "atWithDefault") + , ("at_single", skip) -- is boring, could be proved on the Coq side + , ("bvAdd", mapsTo vectorsModule "bvAdd") + , ("bvLg2", mapsTo vectorsModule "bvLg2") + , ("bvMul", mapsTo vectorsModule "bvMul") + , ("bvNat", mapsTo vectorsModule "bvNat") + , ("bvNeg", mapsTo vectorsModule "bvNeg") + , ("bvSDiv", mapsTo vectorsModule "bvSDiv") + , ("bvSRem", mapsTo vectorsModule "bvSRem") + , ("bvSShr", mapsTo vectorsModule "bvSShr") + , ("bvSub", mapsTo vectorsModule "bvSub") + , ("bvToNat", mapsTo vectorsModule "bvToNat") + , ("bvUDiv", mapsTo vectorsModule "bvUDiv") + , ("bvURem", mapsTo vectorsModule "bvURem") + , ("bvsge", mapsTo vectorsModule "bvsge") + , ("bvsgt", mapsTo vectorsModule "bvsgt") + , ("bvsle", mapsTo vectorsModule "bvsle") + , ("bvslt", mapsTo vectorsModule "bvslt") + , ("bvult", mapsTo vectorsModule "bvult") + , ("bvule", mapsTo vectorsModule "bvule") + , ("coerceVec", mapsTo vectorsModule "coerceVec") + , ("eq_Vec", skip) + , ("foldr", mapsTo vectorsModule "foldr") + , ("gen", mapsTo vectorsModule "gen") + , ("rotateL", mapsTo vectorsModule "rotateL") + , ("rotateR", mapsTo vectorsModule "rotateR") + , ("shiftL", mapsTo vectorsModule "shiftL") + , ("shiftR", mapsTo vectorsModule "shiftR") + , ("take0", skip) + -- zip must be realized in-place because it both depends on definitions and is + -- used by other definitions in the same file, so it can neither be pre- nor + -- post-defined. + , ("zip", realize zipSnippet) + -- cannot map directly to Vector.t because arguments are in a different order + , ("Vec", mapsTo vectorsModule "Vec") + ] + + -- Integers + ++ + [ ("Integer", mapsTo sawDefinitionsModule "Integer") + , ("intAdd", mapsTo sawDefinitionsModule "intAdd") + , ("intSub", mapsTo sawDefinitionsModule "intSub") + , ("intMul", mapsTo sawDefinitionsModule "intMul") + , ("intDiv", mapsTo sawDefinitionsModule "intDiv") + , ("intMod", mapsTo sawDefinitionsModule "intMod") + , ("intMin", mapsTo sawDefinitionsModule "intMin") + , ("intMax", mapsTo sawDefinitionsModule "intMax") + , ("intNeg", mapsTo sawDefinitionsModule "intNeg") + , ("intAbs", mapsTo sawDefinitionsModule "intAbs") + , ("intEq", mapsTo sawDefinitionsModule "intEq") + , ("intLe", mapsTo sawDefinitionsModule "intLe") + , ("intLt", mapsTo sawDefinitionsModule "intLt") + , ("intToNat", mapsTo sawDefinitionsModule "intToNat") + , ("natToInt", mapsTo sawDefinitionsModule "natToInt") + , ("intToBv", mapsTo vectorsModule "intToBv") + , ("bvToInt", mapsTo vectorsModule "bvToInt") + , ("sbvToInt", mapsTo vectorsModule "sbvToInt") + ] + + -- Modular integers + ++ + [ ("IntMod", mapsTo sawDefinitionsModule "IntMod") + , ("toIntMod", mapsTo sawDefinitionsModule "toIntMod") + , ("fromIntMod", mapsTo sawDefinitionsModule "fromIntMod") + , ("intModEq", mapsTo sawDefinitionsModule "intModEq") + , ("intModAdd", mapsTo sawDefinitionsModule "intModAdd") + , ("intModSub", mapsTo sawDefinitionsModule "intModSub") + , ("intModMul", mapsTo sawDefinitionsModule "intModMul") + , ("intModNeg", mapsTo sawDefinitionsModule "intModNeg") + ] + + -- Axioms currently skipped + ++ + [ ("drop0", skip) + , ("bvugt", skip) + , ("bvuge", skip) + , ("bvPopcount", skip) + , ("bvCountLeadingZeros", skip) + , ("bvCountTrailingZeros", skip) + , ("bvForall", skip) + , ("bvAddZeroL", skip) + , ("bvAddZeroR", skip) + , ("bvShl", mapsTo vectorsModule "bvShl") + , ("bvShr", mapsTo vectorsModule "bvShr") + , ("bvShiftL_bvShl", skip) + , ("bvShiftR_bvShr", skip) + , ("bvEq_refl", skip) + , ("equalNat_bv", skip) + , ("Float", skip) + , ("mkFloat", skip) + , ("Double", skip) + , ("mkDouble", skip) + , ("bveq_sameL", skip) + , ("bveq_sameR", skip) + , ("bveq_same2", skip) + , ("bvNat_bvToNat", skip) + , ("ite_split_cong", skip) + , ("ite_join_cong", skip) + , ("map_map", skip) + , ("test_fun0", skip) + , ("test_fun1", skip) + , ("test_fun2", skip) + , ("test_fun3", skip) + , ("test_fun4", skip) + , ("test_fun5", skip) + , ("test_fun6", skip) + ] + + -- The computation monad + ++ + [ ("CompM", replace (Coq.Var "CompM")) + , ("returnM", replace (Coq.App (Coq.ExplVar "returnM") + [Coq.Var "CompM", Coq.Var "_"])) + , ("bindM", replace (Coq.App (Coq.ExplVar "bindM") + [Coq.Var "CompM", Coq.Var "_"])) + , ("errorM", replace (Coq.App (Coq.ExplVar "errorM") + [Coq.Var "CompM", Coq.Var "_"])) + , ("catchM", skip) + , ("fixM", replace (Coq.App (Coq.ExplVar "fixM") + [Coq.Var "CompM", Coq.Var "_"])) + , ("LetRecType", mapsTo compMModule "LetRecType") + , ("LRT_Ret", mapsTo compMModule "LRT_Ret") + , ("LRT_Fun", mapsTo compMModule "LRT_Fun") + , ("lrtToType", mapsTo compMModule "lrtToType") + , ("LetRecTypes", mapsTo compMModule "LetRecTypes") + , ("LRT_Cons", mapsTo compMModule "LRT_Cons") + , ("LRT_Nil", mapsTo compMModule "LRT_Nil") + , ("lrtPi", mapsTo compMModule "lrtPi") + , ("lrtTupleType", mapsTo compMModule "lrtTupleType") + , ("multiFixM", mapsTo compMModule "multiFixM") + , ("letRecM", mapsTo compMModule "letRecM") + ] + + -- Dependent pairs + ++ + [ ("Sigma", replace (Coq.ExplVar "sigT")) + , ("exists", replace (Coq.ExplVar "existT")) + , ("Sigma__rec", replace (Coq.ExplVar "sigT_rect")) + , ("Sigma_proj1", replace (Coq.ExplVar "projT1")) + , ("Sigma_proj2", replace (Coq.ExplVar "projT2")) + ] + + -- Lists + ++ + [ ("List", replace (Coq.ExplVar "Datatypes.list")) + , ("Nil", replace (Coq.ExplVar "Datatypes.nil")) + , ("Cons", replace (Coq.ExplVar "Datatypes.cons")) + , ("List__rec", replace (Coq.ExplVar "Datatypes.list_rect")) + ] + + -- Definitions that depend on axioms currently skipped + ++ + [ ("composeM", skip) + , ("letRecFuns", skip) + ] + +constantsRenamingMap :: [(String, String)] -> Map.Map String String +constantsRenamingMap notations = Map.fromList notations + +-- TODO: Now that ExtCns contains a unique identifier, it might make sense +-- to check those here to avoid some captures? +translateConstant :: [(String, String)] -> ExtCns e -> String +translateConstant notations (EC {..}) = + Map.findWithDefault + (Text.unpack (toShortName ecName)) + (Text.unpack (toShortName ecName)) + (constantsRenamingMap notations) -- TODO short name doesn't seem right + +zipSnippet :: String +zipSnippet = [i| +Fixpoint zip (a b : sort 0) (m n : Nat) (xs : Vec m a) (ys : Vec n b) + : Vec (minNat m n) (a * b) := + match + xs in Vector.t _ m' + return Vector.t _ (minNat m' n) + with + | Vector.nil => Vector.nil _ + | Vector.cons x pm xs => + match + ys in Vector.t _ n' + return Vector.t _ (minNat (S pm) n') + with + | Vector.nil => Vector.nil _ + | Vector.cons y pm' ys => Vector.cons _ (x, y) _ (zip _ _ _ _ xs ys) + end + end +. +|] diff --git a/saw-core-coq/src/Verifier/SAW/Translation/Coq/Term.hs b/saw-core-coq/src/Verifier/SAW/Translation/Coq/Term.hs new file mode 100644 index 0000000000..4bbc3828d4 --- /dev/null +++ b/saw-core-coq/src/Verifier/SAW/Translation/Coq/Term.hs @@ -0,0 +1,590 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PatternGuards #-} + +{- | +Module : Verifier.SAW.Translation.Coq +Copyright : Galois, Inc. 2018 +License : BSD3 +Maintainer : atomb@galois.com +Stability : experimental +Portability : portable +-} + +module Verifier.SAW.Translation.Coq.Term where + +import Control.Lens (makeLenses, over, set, to, view) +import qualified Control.Monad.Except as Except +import qualified Control.Monad.Fail as Fail +import Control.Monad.Reader hiding (fail, fix) +import Control.Monad.State hiding (fail, fix, state) +import Data.Char (isDigit) +import qualified Data.IntMap as IntMap +import Data.List (intersperse, sortOn) +import Data.Maybe (fromMaybe) +import qualified Data.Set as Set +import qualified Data.Text as Text +import Prelude hiding (fail) +import Prettyprinter + +import Data.Parameterized.Pair +import Data.Parameterized.NatRepr +import qualified Data.BitVector.Sized as BV +import qualified Data.Vector as Vector (reverse, toList) +import qualified Language.Coq.AST as Coq +import qualified Language.Coq.Pretty as Coq +import Verifier.SAW.Recognizer +import Verifier.SAW.SharedTerm +import Verifier.SAW.Term.Pretty +import Verifier.SAW.Term.Functor +import Verifier.SAW.Translation.Coq.Monad +import Verifier.SAW.Translation.Coq.SpecialTreatment + +{- +import Debug.Trace +traceTerm :: String -> Term -> a -> a +traceTerm ctx t a = trace (ctx ++ ": " ++ showTerm t) a +-} + +data TranslationState = TranslationState + + { _globalDeclarations :: [String] + -- ^ Some Cryptol terms seem to capture the name and body of some functions + -- they use (whether from the Cryptol prelude, or previously defined in the + -- same file). We want to translate those exactly once, so we need to keep + -- track of which ones have already been translated. + + , _localDeclarations :: [Coq.Decl] + -- ^ Because some terms capture their dependencies, translating one term may + -- result in multiple declarations: one for the term itself, but also zero or + -- many for its dependencies. We store all of those in this, so that a caller + -- of the translation may retrieve all the declarations needed to translate + -- the term. The translation function itself will return only the declaration + -- for the term being translated. + + , _localEnvironment :: [Coq.Ident] + -- ^ The list of Coq identifiers for de Bruijn-indexed local + -- variables, innermost (index 0) first. + + , _unavailableIdents :: Set.Set Coq.Ident + -- ^ The set of Coq identifiers that are either reserved or already + -- in use. To avoid shadowing, fresh identifiers should be chosen to + -- be disjoint from this set. + + , _sharedNames :: IntMap.IntMap Coq.Ident + -- ^ Index of identifiers for repeated subterms that have been + -- lifted out into a let expression. + + , _nextSharedName :: Coq.Ident + -- ^ The next available name to be used for a let-bound shared + -- sub-expression. + + , _currentModule :: Maybe ModuleName + } + deriving (Show) + +makeLenses ''TranslationState + +-- | The set of reserved identifiers in Coq, obtained from section +-- "Gallina Specification Language" of the Coq reference manual. +-- +reservedIdents :: Set.Set Coq.Ident +reservedIdents = + Set.fromList $ + concatMap words $ + [ "_ Axiom CoFixpoint Definition Fixpoint Hypothesis IF Parameter Prop" + , "SProp Set Theorem Type Variable as at by cofix discriminated else" + , "end exists exists2 fix for forall fun if in lazymatch let match" + , "multimatch return then using where with" + ] + +-- | Extract the list of names from a list of Coq declarations. Not all +-- declarations have names, e.g. comments and code snippets come without names. +namedDecls :: [Coq.Decl] -> [String] +namedDecls = concatMap filterNamed + where + filterNamed :: Coq.Decl -> [String] + filterNamed (Coq.Axiom n _) = [n] + filterNamed (Coq.Comment _) = [] + filterNamed (Coq.Definition n _ _ _) = [n] + filterNamed (Coq.InductiveDecl (Coq.Inductive n _ _ _ _)) = [n] + filterNamed (Coq.Snippet _) = [] + +-- | Retrieve the names of all local and global declarations from the +-- translation state. +getNamesOfAllDeclarations :: + TermTranslationMonad m => + m [String] +getNamesOfAllDeclarations = view allDeclarations <$> get + where + allDeclarations = + to (\ (TranslationState {..}) -> namedDecls _localDeclarations ++ _globalDeclarations) + +type TermTranslationMonad m = TranslationMonad TranslationState m + +runTermTranslationMonad :: + TranslationConfiguration -> + Maybe ModuleName -> + [String] -> + [Coq.Ident] -> + (forall m. TermTranslationMonad m => m a) -> + Either (TranslationError Term) (a, TranslationState) +runTermTranslationMonad configuration modname globalDecls localEnv = + runTranslationMonad configuration + (TranslationState { _globalDeclarations = globalDecls + , _localDeclarations = [] + , _localEnvironment = localEnv + , _unavailableIdents = Set.union reservedIdents (Set.fromList localEnv) + , _sharedNames = IntMap.empty + , _nextSharedName = "var__0" + , _currentModule = modname + }) + +errorTermM :: TermTranslationMonad m => String -> m Coq.Term +errorTermM str = return $ Coq.App (Coq.Var "error") [Coq.StringLit str] + +translateIdentWithArgs :: TermTranslationMonad m => Ident -> [Term] -> m Coq.Term +translateIdentWithArgs i args = + (view currentModule <$> get) >>= \cur_modname -> + let identToCoq ident = + if Just (identModule ident) == cur_modname then identName ident else + show (translateModuleName (identModule ident)) + ++ "." ++ identName ident in + + (atUseSite <$> findSpecialTreatment i) >>= \case + UsePreserve -> Coq.App (Coq.ExplVar $ identToCoq i) <$> mapM translateTerm args + UseRename targetModule targetName -> + Coq.App (Coq.ExplVar $ identToCoq $ + mkIdent (fromMaybe (translateModuleName $ identModule i) targetModule) + targetName) <$> + mapM translateTerm args + UseReplaceDropArgs n replacement + | length args >= n -> Coq.App replacement <$> mapM translateTerm (drop n args) + UseReplaceDropArgs n _ -> + errorTermM ("Identifier " ++ show i + ++ " not applied to required number of args," + ++ " which is " ++ show n) + +translateIdent :: TermTranslationMonad m => Ident -> m Coq.Term +translateIdent i = translateIdentWithArgs i [] + +translateIdentToIdent :: TermTranslationMonad m => Ident -> m (Maybe Ident) +translateIdentToIdent i = + (atUseSite <$> findSpecialTreatment i) >>= \case + UsePreserve -> return $ Just (mkIdent translatedModuleName (identName i)) + UseRename targetModule targetName -> + return $ Just $ mkIdent (fromMaybe translatedModuleName targetModule) targetName + UseReplaceDropArgs _ _ -> return Nothing + where + translatedModuleName = translateModuleName (identModule i) + +translateSort :: Sort -> Coq.Sort +translateSort s = if s == propSort then Coq.Prop else Coq.Type + +flatTermFToExpr :: + TermTranslationMonad m => + FlatTermF Term -> + m Coq.Term +flatTermFToExpr tf = -- traceFTermF "flatTermFToExpr" tf $ + case tf of + Primitive (EC _ nmi _) -> + case nmi of + ModuleIdentifier i -> translateIdent i + ImportedName{} -> errorTermM "Invalid name for saw-core primitive" + UnitValue -> pure (Coq.Var "tt") + UnitType -> pure (Coq.Var "unit") + PairValue x y -> Coq.App (Coq.Var "pair") <$> traverse translateTerm [x, y] + PairType x y -> Coq.App (Coq.Var "prod") <$> traverse translateTerm [x, y] + PairLeft t -> + Coq.App <$> pure (Coq.Var "SAWCoreScaffolding.fst") <*> traverse translateTerm [t] + PairRight t -> + Coq.App <$> pure (Coq.Var "SAWCoreScaffolding.snd") <*> traverse translateTerm [t] + -- TODO: maybe have more customizable translation of data types + DataTypeApp n is as -> translateIdentWithArgs n (is ++ as) + CtorApp n is as -> translateIdentWithArgs n (is ++ as) + -- TODO: support this next! + RecursorApp d parameters motive eliminators indices termEliminated -> + do maybe_d_trans <- translateIdentToIdent d + rect_var <- case maybe_d_trans of + Just i -> return $ Coq.Var (show i ++ "_rect") + Nothing -> + errorTermM ("Recursor for " ++ show d ++ + " cannot be translated because the datatype " ++ + "is mapped to an arbitrary Coq term") + let args = + parameters ++ [motive] ++ map snd eliminators + ++ indices ++ [termEliminated] + Coq.App rect_var <$> mapM translateTerm args + Sort s -> pure (Coq.Sort (translateSort s)) + NatLit i -> pure (Coq.NatLit (toInteger i)) + ArrayValue (asBoolType -> Just ()) (traverse asBool -> Just bits) + | Pair w bv <- BV.bitsBE (Vector.toList bits) + , Left LeqProof <- decideLeq (knownNat @1) w -> do + return (Coq.App (Coq.Var "intToBv") + [Coq.NatLit (intValue w), Coq.ZLit (BV.asSigned w bv)]) + ArrayValue _ vec -> do + let addElement accum element = do + elementTerm <- translateTerm element + return (Coq.App (Coq.Var "Vector.cons") + [Coq.Var "_", elementTerm, Coq.Var "_", accum] + ) + in + foldM addElement (Coq.App (Coq.Var "Vector.nil") [Coq.Var "_"]) (Vector.reverse vec) + StringLit s -> pure (Coq.Scope (Coq.StringLit (Text.unpack s)) "string") + ExtCns (EC _ _ _) -> errorTermM "External constants not supported" + + -- The translation of a record type {fld1:tp1, ..., fldn:tpn} is + -- RecordTypeCons fld1 tp1 (... (RecordTypeCons fldn tpn RecordTypeNil)...). + -- Note that SAW core equates record types up to reordering, so we sort our + -- record types by field name to canonicalize them. + RecordType fs -> + foldr (\(name, tp) rest_m -> + do rest <- rest_m + tp_trans <- translateTerm tp + return (Coq.App (Coq.Var "RecordTypeCons") + [Coq.StringLit (Text.unpack name), tp_trans, rest])) + (return (Coq.Var "RecordTypeNil")) + (sortOn fst fs) + + -- The translation of a record value {fld1 = x1, ..., fldn = xn} is + -- RecordCons fld1 x1 (... (RecordCons fldn xn RecordNil) ...). Note that + -- SAW core equates record values up to reordering, so we sort our record + -- values by field name to canonicalize them. + RecordValue fs -> + foldr (\(name, trm) rest_m -> + do rest <- rest_m + trm_trans <- translateTerm trm + return (Coq.App (Coq.Var "RecordCons") + [Coq.StringLit (Text.unpack name), trm_trans, rest])) + (return (Coq.Var "RecordNil")) + (sortOn fst fs) + + RecordProj r f -> do + r_trans <- translateTerm r + return (Coq.App (Coq.Var "RecordProj") [r_trans, Coq.StringLit (Text.unpack f)]) + +-- | Recognizes an $App (App "Cryptol.seq" n) x$ and returns ($n$, $x$). +asSeq :: Recognizer Term (Term, Term) +asSeq t = do (f, args) <- asApplyAllRecognizer t + fid <- asGlobalDef f + case (fid, args) of + ("Cryptol.seq", [n, x]) -> return (n,x) + _ -> Fail.fail "not a seq" + +asApplyAllRecognizer :: Recognizer Term (Term, [Term]) +asApplyAllRecognizer t = do _ <- asApp t + return $ asApplyAll t + +-- | Run a translation, but keep changes to the environment local to it, +-- restoring the current environment before returning. +withLocalLocalEnvironment :: TermTranslationMonad m => m a -> m a +withLocalLocalEnvironment action = do + s <- get + result <- action + put s + return result + +mkDefinition :: Coq.Ident -> Coq.Term -> Coq.Decl +mkDefinition name (Coq.Lambda bs t) = Coq.Definition name bs Nothing t +mkDefinition name t = Coq.Definition name [] Nothing t + +-- | Make sure a name is not used in the current environment, adding +-- or incrementing a numeric suffix until we find an unused name. When +-- we get one, add it to the current environment and return it. +freshenAndBindName :: TermTranslationMonad m => LocalName -> m Coq.Ident +freshenAndBindName n = + do n' <- translateLocalIdent n + modify $ over localEnvironment (n' :) + pure n' + +mkLet :: (Coq.Ident, Coq.Term) -> Coq.Term -> Coq.Term +mkLet (name, rhs) body = Coq.Let name [] Nothing rhs body + +translateParams :: + TermTranslationMonad m => + [(LocalName, Term)] -> m [Coq.Binder] +translateParams [] = return [] +translateParams ((n, ty):ps) = do + ty' <- translateTerm ty + n' <- freshenAndBindName n + ps' <- translateParams ps + return (Coq.Binder n' (Just ty') : ps') + +translatePi :: TermTranslationMonad m => [(LocalName, Term)] -> Term -> m Coq.Term +translatePi binders body = withLocalLocalEnvironment $ do + bindersT <- forM binders $ \ (b, bType) -> do + bTypeT <- translateTerm bType + b' <- freshenAndBindName b + let n = if b == "_" then Nothing else Just b' + return (Coq.PiBinder n bTypeT) + bodyT <- translateTermLet body + return $ Coq.Pi bindersT bodyT + +-- | Translate a local name from a saw-core binder into a fresh Coq identifier. +translateLocalIdent :: TermTranslationMonad m => LocalName -> m Coq.Ident +translateLocalIdent x = freshVariant ident0 + where ident0 = Text.unpack x -- TODO: use some string encoding to ensure lexically valid Coq identifiers + +-- | Find an fresh, as-yet-unused variant of the given Coq identifier. +freshVariant :: TermTranslationMonad m => Coq.Ident -> m Coq.Ident +freshVariant x = + do used <- view unavailableIdents <$> get + let ident0 = x + let findVariant i = if Set.member i used then findVariant (nextVariant i) else i + let ident = findVariant ident0 + modify $ over unavailableIdents (Set.insert ident) + return ident + +nextVariant :: Coq.Ident -> Coq.Ident +nextVariant = reverse . go . reverse + where + go :: String -> String + go (c : cs) + | c == '9' = '0' : go cs + | isDigit c = succ c : cs + go cs = '1' : cs + +translateTermLet :: TermTranslationMonad m => Term -> m Coq.Term +translateTermLet t = + withLocalLocalEnvironment $ + do let counts = scTermCount False t + let locals = fmap fst $ IntMap.filter keep counts + names <- traverse (const nextName) locals + modify $ set sharedNames names + defs <- traverse translateTermUnshared locals + body <- translateTerm t + -- NOTE: Larger terms always have later IDs than their subterms, + -- so ordering by VarIndex is a valid dependency order. + let binds = IntMap.elems (IntMap.intersectionWith (,) names defs) + pure (foldr mkLet body binds) + where + keep (t', n) = n > 1 && shouldMemoizeTerm t' + nextName = + do x <- view nextSharedName <$> get + x' <- freshVariant x + modify $ set nextSharedName (nextVariant x') + pure x' + +translateTerm :: TermTranslationMonad m => Term -> m Coq.Term +translateTerm t = + case t of + Unshared {} -> translateTermUnshared t + STApp { stAppIndex = i } -> + do shared <- view sharedNames <$> get + case IntMap.lookup i shared of + Nothing -> translateTermUnshared t + Just x -> pure (Coq.Var x) + +translateTermUnshared :: TermTranslationMonad m => Term -> m Coq.Term +translateTermUnshared t = withLocalLocalEnvironment $ do + -- traceTerm "translateTerm" t $ + -- NOTE: env is in innermost-first order + env <- view localEnvironment <$> get + -- let t' = trace ("translateTerm: " ++ "env = " ++ show env ++ ", t =" ++ showTerm t) t + -- case t' of + case unwrapTermF t of + + FTermF ftf -> flatTermFToExpr ftf + + Pi {} -> translatePi params e + where + (params, e) = asPiList t + + Lambda {} -> do + paramTerms <- translateParams params + e' <- translateTerm e + pure (Coq.Lambda paramTerms e') + where + -- params are in normal, outermost first, order + (params, e) = asLambdaList t + + App {} -> + -- asApplyAll: innermost argument first + let (f, args) = asApplyAll t + in + case f of + (asGlobalDef -> Just i) -> + case i of + "Prelude.natToInt" -> + case args of + [n] -> translateTerm n >>= \case + Coq.NatLit n' -> pure $ Coq.ZLit n' + _ -> translateIdentWithArgs "Prelude.natToInt" [n] + _ -> badTerm + "Prelude.intNeg" -> + case args of + [z] -> translateTerm z >>= \case + Coq.ZLit z' -> pure $ Coq.ZLit (-z') + _ -> translateIdentWithArgs "Prelude.intNeg" [z] + _ -> badTerm + "Prelude.ite" -> + case args of + -- `rest` can be non-empty in examples like: + -- (if b then f else g) arg1 arg2 + _ty : c : tt : ft : rest -> do + ite <- Coq.If <$> translateTerm c <*> translateTerm tt <*> translateTerm ft + case rest of + [] -> return ite + _ -> Coq.App ite <$> mapM translateTerm rest + _ -> badTerm + -- NOTE: the following works for something like CBC, because computing + -- the n-th block only requires n steps of recursion + -- FIXME: (pun not intended) better conditions for when this is safe to do + "Prelude.fix" -> + case args of + [] -> errorTermM "call to Prelude.fix with no argument" + [_] -> errorTermM "call to Prelude.fix with 1 argument" + resultType : lambda : rest -> + case resultType of + -- TODO: check that 'n' is finite + (asSeq -> Just (n, _)) -> + case lambda of + + (asLambda -> Just (x, seqType, body)) | seqType == resultType -> + do + len <- translateTerm n + (x', expr) <- + withLocalLocalEnvironment $ + do x' <- freshenAndBindName x + expr <- translateTerm body + pure (x', expr) + seqTypeT <- translateTerm seqType + defaultValueT <- defaultTermForType resultType + let iter = + Coq.App (Coq.Var "iter") + [ len + , Coq.Lambda [Coq.Binder x' (Just seqTypeT)] expr + , defaultValueT + ] + case rest of + [] -> return iter + _ -> Coq.App iter <$> mapM translateTerm rest + _ -> badTerm + -- NOTE: there is currently one instance of `fix` that will trigger + -- `errorTermM`. It is used in `Cryptol.cry` when translating + -- `iterate`, which generates an infinite stream of nested + -- applications of a given function. + + (asPiList -> (pis, afterPis)) -> + -- NOTE: this will output some code, but it is likely that Coq + -- will reject it for not being structurally recursive. + case lambda of + (asLambdaList -> ((recFn, _) : binders, body)) -> do + let (_binderPis, otherPis) = splitAt (length binders) pis + (recFn', bindersT, typeT, bodyT) <- withLocalLocalEnvironment $ do + -- this is very ugly... + recFn' <- freshenAndBindName recFn + bindersT <- mapM + (\ (b, bType) -> do + bTypeT <- translateTerm bType + b' <- freshenAndBindName b + return $ Coq.Binder b' (Just bTypeT) + ) + binders + typeT <- translatePi otherPis afterPis + bodyT <- translateTerm body + return (recFn', bindersT, typeT, bodyT) + let fix = Coq.Fix recFn' bindersT typeT bodyT + case rest of + [] -> return fix + _ -> errorTermM "THAT" -- Coq.App fix <$> mapM (go env) rest + _ -> errorTermM "call to Prelude.fix without lambda" + + _ -> + translateIdentWithArgs i args + _ -> Coq.App <$> translateTerm f <*> traverse translateTerm args + + LocalVar n + | n < length env -> Coq.Var <$> pure (env !! n) + | otherwise -> Except.throwError $ LocalVarOutOfBounds t + + -- Constants come with a body + Constant n body -> do + configuration <- ask + let renamed = translateConstant (notations configuration) n + alreadyTranslatedDecls <- getNamesOfAllDeclarations + let definitionsToSkip = skipDefinitions configuration + if elem renamed alreadyTranslatedDecls || elem renamed definitionsToSkip + then Coq.Var <$> pure renamed + else do + b <- + -- Translate body in a top-level name scope + withLocalLocalEnvironment $ + do modify $ set localEnvironment [] + modify $ set unavailableIdents reservedIdents + modify $ set sharedNames IntMap.empty + modify $ set nextSharedName "var__0" + translateTermLet body + modify $ over localDeclarations $ (mkDefinition renamed b :) + Coq.Var <$> pure renamed + + where + badTerm = Except.throwError $ BadTerm t + +-- | In order to turn fixpoint computations into iterative computations, we need +-- to be able to create "dummy" values at the type of the computation. For now, +-- we will support arbitrary nesting of vectors of boolean values. +defaultTermForType :: + TermTranslationMonad m => + Term -> m Coq.Term +defaultTermForType typ = do + case typ of + + (asSeq -> Just (n, typ')) -> do + seqConst <- translateIdent (mkIdent (mkModuleName ["Cryptol"]) "seqConst") + nT <- translateTerm n + typ'T <- translateTerm typ' + defaultT <- defaultTermForType typ' + return $ Coq.App seqConst [ nT, typ'T, defaultT ] + + (asBoolType -> Just ()) -> translateIdent (mkIdent preludeName "False") + + _ -> + return $ Coq.App (Coq.Var "error") + [Coq.StringLit ("Could not generate default value of type " ++ showTerm typ)] + + -- _ -> Except.throwError $ CannotCreateDefaultValue typ + +translateTermToDocWith :: + TranslationConfiguration -> + Maybe ModuleName -> + [String] -> + [String] -> + (Coq.Term -> Doc ann) -> + Term -> + Either (TranslationError Term) (Doc ann) +translateTermToDocWith configuration mn globalDecls localEnv f t = do + (term, state) <- + runTermTranslationMonad configuration mn globalDecls localEnv (translateTermLet t) + let decls = view localDeclarations state + return $ + vcat $ + [ (vcat . intersperse hardline . map Coq.ppDecl . reverse) decls + , if null decls then mempty else hardline + , f term + ] + +translateDefDoc :: + TranslationConfiguration -> + Maybe ModuleName -> + [String] -> + Coq.Ident -> Term -> + Either (TranslationError Term) (Doc ann) +translateDefDoc configuration mn globalDecls name = + translateTermToDocWith configuration mn globalDecls [name] + (\ term -> Coq.ppDecl (mkDefinition name term)) diff --git a/saw-core-coq/test/Verifier/SAW/Translation/Coq/Test.hs b/saw-core-coq/test/Verifier/SAW/Translation/Coq/Test.hs new file mode 100644 index 0000000000..e5c439ea2a --- /dev/null +++ b/saw-core-coq/test/Verifier/SAW/Translation/Coq/Test.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ViewPatterns #-} + +{- | +Module : Verifier.SAW.Translation.Coq.Test +Copyright : Galois, Inc. 2019 +License : BSD3 +Maintainer : val@galois.com +Stability : experimental +Portability : portable +-} + +module Verifier.SAW.Translation.Coq.Test where + +import Control.Monad.IO.Class +import Control.Monad.Reader +import qualified Data.Map as Map +import Text.PrettyPrint.ANSI.Leijen hiding ((<$>)) + +-- import qualified Language.Coq.Pretty as Coq +-- import Verifier.SAW.CryptolEnv +import Verifier.SAW.Module +import Verifier.SAW.Prelude (preludeModule) +import Verifier.SAW.SharedTerm +import Verifier.SAW.Typechecker +import qualified Verifier.SAW.UntypedAST as Un +import Verifier.SAW.Translation.Coq + +configuration :: TranslationConfiguration +configuration = TranslationConfiguration + { vectorModule = "SAWCoreVectorsAsCoqVectors" + } + +-- Creating a bunch of terms with no sharing, for testing purposes + +natOf :: Integer -> IO Term +natOf i = do + sc <- mkSharedContext + scNat sc (fromInteger i) + +aVector :: IO Term +aVector = do + sc <- mkSharedContext + typ <- scNatType sc + args <- mapM (natOf) [0, 1, 2] + scVector sc typ args + +aRecord :: IO Term +aRecord = do + sc <- mkSharedContext + nat <- natOf 2 + unit <- scUnitValue sc + scRecord sc $ Map.fromList [("natField", nat), ("unitField", unit)] + +aRecordType :: IO Term +aRecordType = do + sc <- mkSharedContext + natType <- scNatType sc + unitType <- scUnitType sc + scRecordType sc [("natField", natType), ("unitField", unitType)] + +translate :: Monad m => m Term -> m Doc +translate term = do + translateDeclImports configuration "MyDefinition" <$> term >>= \case + Left e -> error $ show e + Right r -> return r + +preludeName :: Un.ModuleName +preludeName = Un.moduleName preludeModule + +checkTermVar :: Un.TermVar -> Ident +checkTermVar tv = mkIdent preludeName (Un.termVarString tv) -- FIXME + +checkTermCtx :: SCIOMonad m => Un.TermCtx -> m [(Ident, Term)] +checkTermCtx ctx = mapM checkUntypedBinder ctx + +checkUntypedBinder :: SCIOMonad m => (Un.TermVar, Un.Term) -> m (Ident, Term) +checkUntypedBinder (ident, term) = + (,) <$> pure (checkTermVar ident) <*> checkUntypedTerm term + +type SCIOMonad m = ( MonadIO m, MonadReader SharedContext m ) + +checkUntypedTerm :: SCIOMonad m => Un.Term -> m Term +checkUntypedTerm term = do + sc <- ask + et <- liftIO $ do + inferCompleteTerm sc (Just preludeName) term + case et of + Left e -> error $ show e + Right t -> return t + +getPreludeModule :: SCIOMonad m => m Module +getPreludeModule = do + sc <- ask + liftIO $ scFindModule sc preludeName + +getPreludeDataType :: SCIOMonad m => String -> m DataType +getPreludeDataType name = do + prelude <- getPreludeModule + case findDataType prelude name of + Nothing -> error $ name ++ " not found" + Just dt -> return dt + +translateSAWCorePrelude :: IO () +translateSAWCorePrelude = do + sc <- mkSharedContext + -- In order to get test data types, we load the Prelude + tcInsertModule sc preludeModule + flip runReaderT sc $ do + + prelude <- getPreludeModule + + liftIO $ do + putStrLn "From Coq.Strings Require Import String." + putStrLn "From CryptolToCoq Require Import SAWCoreScaffolding." + putStrLn "" + + doc <- translateModule configuration prelude + + liftIO $ putStrLn $ show doc + +-- translateCryptolPrelude :: IO () +-- translateCryptolPrelude = do +-- sc <- mkSharedContext +-- cryptolEnv <- initCryptolEnv sc +-- forM_ (Map.assocs $ eTermEnv cryptolEnv) $ \ (a, b) -> do +-- putStrLn $ show a +-- return () + +main :: IO () +main = translateSAWCorePrelude diff --git a/saw-core-sbv/.gitignore b/saw-core-sbv/.gitignore new file mode 100644 index 0000000000..8ee1bf9489 --- /dev/null +++ b/saw-core-sbv/.gitignore @@ -0,0 +1 @@ +.stack-work diff --git a/saw-core-sbv/LICENSE b/saw-core-sbv/LICENSE new file mode 100644 index 0000000000..9e2f031c53 --- /dev/null +++ b/saw-core-sbv/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2012-2016, 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 names of the authors nor the names of other + 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/saw-core-sbv/README.md b/saw-core-sbv/README.md new file mode 100644 index 0000000000..4f024ce9c0 --- /dev/null +++ b/saw-core-sbv/README.md @@ -0,0 +1,2 @@ +This repository contains a backend for the `saw-core` library that uses +the `sbv` library for communication with SMT solvers. diff --git a/saw-core-sbv/Setup.hs b/saw-core-sbv/Setup.hs new file mode 100644 index 0000000000..9a994af677 --- /dev/null +++ b/saw-core-sbv/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/saw-core-sbv/saw-core-sbv.cabal b/saw-core-sbv/saw-core-sbv.cabal new file mode 100644 index 0000000000..f6c96e2e6f --- /dev/null +++ b/saw-core-sbv/saw-core-sbv.cabal @@ -0,0 +1,31 @@ +Name: saw-core-sbv +Version: 0.1 +License: BSD3 +License-file: LICENSE +Author: Galois, Inc. +Maintainer: huffman@galois.com +Copyright: (c) 2012-2016 Galois Inc. +Category: Formal Methods +Build-type: Simple +cabal-version: >= 1.8 +Synopsis: SAWCore backend for SBV +Description: + A backend for symbolically evaluating terms in the SAWCore + intermediate language using the SBV library to generate SMT-Lib. + +library + build-depends: + base == 4.*, + containers, + lens, + mtl, + saw-core, + sbv >= 8.0 && < 8.8, + text, + transformers, + vector + hs-source-dirs: src + exposed-modules: + Verifier.SAW.Simulator.SBV + Verifier.SAW.Simulator.SBV.SWord + GHC-options: -Wall -Werror -Wcompat diff --git a/saw-core-sbv/src/Verifier/SAW/Simulator/SBV.hs b/saw-core-sbv/src/Verifier/SAW/Simulator/SBV.hs new file mode 100644 index 0000000000..d400089d04 --- /dev/null +++ b/saw-core-sbv/src/Verifier/SAW/Simulator/SBV.hs @@ -0,0 +1,883 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE EmptyDataDecls #-} + +{- | +Module : Verifier.SAW.Simulator.SBV +Copyright : Galois, Inc. 2012-2015 +License : BSD3 +Maintainer : huffman@galois.com +Stability : experimental +Portability : non-portable (language extensions) +-} +module Verifier.SAW.Simulator.SBV + ( sbvSATQuery + , SValue + , Labeler(..) + , sbvCodeGen_definition + , sbvCodeGen + , toWord + , toBool + , getLabels + , module Verifier.SAW.Simulator.SBV.SWord + ) where + +import Data.SBV.Dynamic + +import Verifier.SAW.Simulator.SBV.SWord + +import Control.Lens ((<&>)) + +import Data.Bits +import Data.IORef +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Set (Set) +import qualified Data.Set as Set +import qualified Data.Text as Text +import Data.Vector (Vector) +import qualified Data.Vector as V + +import Data.Traversable as T +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif +import Control.Monad.IO.Class +import Control.Monad.State as ST +import Numeric.Natural (Natural) + +import qualified Verifier.SAW.Prim as Prim +import qualified Verifier.SAW.Recognizer as R +import qualified Verifier.SAW.Simulator as Sim +import qualified Verifier.SAW.Simulator.Prims as Prims +import Verifier.SAW.SATQuery +import Verifier.SAW.SharedTerm +import Verifier.SAW.Simulator.Value +import Verifier.SAW.TypedAST (FieldName, identName, toShortName) +import Verifier.SAW.FiniteValue + (FirstOrderType(..), FirstOrderValue(..) + , fovVec, firstOrderTypeOf, asFirstOrderType + ) + +data SBV + +type instance EvalM SBV = IO +type instance VBool SBV = SBool +type instance VWord SBV = SWord +type instance VInt SBV = SInteger +type instance Extra SBV = SbvExtra + +type SValue = Value SBV +--type SThunk = Thunk SBV + +data SbvExtra = + SStream (Natural -> IO SValue) (IORef (Map Natural SValue)) + +instance Show SbvExtra where + show (SStream _ _) = "" + +pure1 :: Applicative f => (a -> b) -> a -> f b +pure1 f x = pure (f x) + +pure2 :: Applicative f => (a -> b -> c) -> a -> b -> f c +pure2 f x y = pure (f x y) + +pure3 :: Applicative f => (a -> b -> c -> d) -> a -> b -> c -> f d +pure3 f x y z = pure (f x y z) + +prims :: Prims.BasePrims SBV +prims = + Prims.BasePrims + { Prims.bpAsBool = svAsBool + , Prims.bpUnpack = svUnpack + , Prims.bpPack = pure1 symFromBits + , Prims.bpBvAt = pure2 svAt + , Prims.bpBvLit = pure2 literalSWord + , Prims.bpBvSize = intSizeOf + , Prims.bpBvJoin = pure2 svJoin + , Prims.bpBvSlice = pure3 svSlice + -- Conditionals + , Prims.bpMuxBool = pure3 svIte + , Prims.bpMuxWord = pure3 svIte + , Prims.bpMuxInt = pure3 svIte + , Prims.bpMuxExtra = muxSbvExtra + -- Booleans + , Prims.bpTrue = svTrue + , Prims.bpFalse = svFalse + , Prims.bpNot = pure1 svNot + , Prims.bpAnd = pure2 svAnd + , Prims.bpOr = pure2 svOr + , Prims.bpXor = pure2 svXOr + , Prims.bpBoolEq = pure2 svEqual + -- Bitvector logical + , Prims.bpBvNot = pure1 svNot + , Prims.bpBvAnd = pure2 svAnd + , Prims.bpBvOr = pure2 svOr + , Prims.bpBvXor = pure2 svXOr + -- Bitvector arithmetic + , Prims.bpBvNeg = pure1 svUNeg + , Prims.bpBvAdd = pure2 svPlus + , Prims.bpBvSub = pure2 svMinus + , Prims.bpBvMul = pure2 svTimes + , Prims.bpBvUDiv = pure2 svQuot + , Prims.bpBvURem = pure2 svRem + , Prims.bpBvSDiv = \x y -> pure (svUnsign (svQuot (svSign x) (svSign y))) + , Prims.bpBvSRem = \x y -> pure (svUnsign (svRem (svSign x) (svSign y))) + , Prims.bpBvLg2 = pure1 sLg2 + -- Bitvector comparisons + , Prims.bpBvEq = pure2 svEqual + , Prims.bpBvsle = \x y -> pure (svLessEq (svSign x) (svSign y)) + , Prims.bpBvslt = \x y -> pure (svLessThan (svSign x) (svSign y)) + , Prims.bpBvule = pure2 svLessEq + , Prims.bpBvult = pure2 svLessThan + , Prims.bpBvsge = \x y -> pure (svGreaterEq (svSign x) (svSign y)) + , Prims.bpBvsgt = \x y -> pure (svGreaterThan (svSign x) (svSign y)) + , Prims.bpBvuge = pure2 svGreaterEq + , Prims.bpBvugt = pure2 svGreaterThan + -- Bitvector shift/rotate + , Prims.bpBvRolInt = pure2 svRol' + , Prims.bpBvRorInt = pure2 svRor' + , Prims.bpBvShlInt = pure3 svShl' + , Prims.bpBvShrInt = pure3 svShr' + , Prims.bpBvRol = pure2 svRotateLeft + , Prims.bpBvRor = pure2 svRotateRight + , Prims.bpBvShl = pure3 svShiftL + , Prims.bpBvShr = pure3 svShiftR + -- Bitvector misc + , Prims.bpBvPopcount = pure1 svPopcount + , Prims.bpBvCountLeadingZeros = pure1 svCountLeadingZeros + , Prims.bpBvCountTrailingZeros = pure1 svCountTrailingZeros + , Prims.bpBvForall = unsupportedSBVPrimitive "bvForall" + -- Integer operations + , Prims.bpIntAdd = pure2 svPlus + , Prims.bpIntSub = pure2 svMinus + , Prims.bpIntMul = pure2 svTimes + , Prims.bpIntDiv = pure2 svQuot + , Prims.bpIntMod = pure2 svRem + , Prims.bpIntNeg = pure1 svUNeg + , Prims.bpIntAbs = pure1 svAbs + , Prims.bpIntEq = pure2 svEqual + , Prims.bpIntLe = pure2 svLessEq + , Prims.bpIntLt = pure2 svLessThan + , Prims.bpIntMin = unsupportedSBVPrimitive "bpIntMin" + , Prims.bpIntMax = unsupportedSBVPrimitive "bpIntMax" + -- Array operations + , Prims.bpArrayConstant = unsupportedSBVPrimitive "bpArrayConstant" + , Prims.bpArrayLookup = unsupportedSBVPrimitive "bpArrayLookup" + , Prims.bpArrayUpdate = unsupportedSBVPrimitive "bpArrayUpdate" + , Prims.bpArrayEq = unsupportedSBVPrimitive "bpArrayEq" + } + +unsupportedSBVPrimitive :: String -> a +unsupportedSBVPrimitive = Prim.unsupportedPrimitive "SBV" + +constMap :: Map Ident SValue +constMap = + Map.union (Prims.constMap prims) $ + Map.fromList + [ + -- Shifts + ("Prelude.bvShl" , bvShLOp) + , ("Prelude.bvShr" , bvShROp) + , ("Prelude.bvSShr", bvSShROp) + -- Integers + , ("Prelude.intToNat", intToNatOp) + , ("Prelude.natToInt", natToIntOp) + , ("Prelude.intToBv" , intToBvOp) + , ("Prelude.bvToInt" , bvToIntOp) + , ("Prelude.sbvToInt", sbvToIntOp) + -- Integers mod n + , ("Prelude.toIntMod" , toIntModOp) + , ("Prelude.fromIntMod", fromIntModOp) + , ("Prelude.intModEq" , intModEqOp) + , ("Prelude.intModAdd" , intModBinOp svPlus) + , ("Prelude.intModSub" , intModBinOp svMinus) + , ("Prelude.intModMul" , intModBinOp svTimes) + , ("Prelude.intModNeg" , intModUnOp svUNeg) + -- Streams + , ("Prelude.MkStream", mkStreamOp) + , ("Prelude.streamGet", streamGetOp) + -- Misc + , ("Prelude.expByNat", Prims.expByNatOp prims) + ] + +------------------------------------------------------------ +-- Coercion functions +-- + +bitVector :: Int -> Integer -> SWord +bitVector w i = literalSWord w i + +symFromBits :: Vector SBool -> SWord +symFromBits v = V.foldl svJoin (bitVector 0 0) (V.map svToWord1 v) + +toMaybeBool :: SValue -> Maybe SBool +toMaybeBool (VBool b) = Just b +toMaybeBool _ = Nothing + +toBool :: SValue -> SBool +toBool (VBool b) = b +toBool sv = error $ unwords ["toBool failed:", show sv] + +toWord :: SValue -> IO SWord +toWord (VWord w) = return w +toWord (VVector vv) = symFromBits <$> traverse (fmap toBool . force) vv +toWord x = fail $ unwords ["Verifier.SAW.Simulator.SBV.toWord", show x] + +toMaybeWord :: SValue -> IO (Maybe SWord) +toMaybeWord (VWord w) = return (Just w) +toMaybeWord (VVector vv) = ((symFromBits <$>) . T.sequence) <$> traverse (fmap toMaybeBool . force) vv +toMaybeWord _ = return Nothing + +-- | Flatten an SValue to a sequence of components, each of which is +-- either a symbolic word or a symbolic boolean. If the SValue +-- contains any values built from data constructors, then return them +-- encoded as a String. +flattenSValue :: String -> SValue -> IO ([SVal], String) +flattenSValue nm v = do + mw <- toMaybeWord v + case mw of + Just w -> return ([w], "") + Nothing -> + case v of + VUnit -> return ([], "") + VPair x y -> do (xs, sx) <- flattenSValue nm =<< force x + (ys, sy) <- flattenSValue nm =<< force y + return (xs ++ ys, sx ++ sy) + VRecordValue elems -> do (xss, sxs) <- + unzip <$> + mapM (flattenSValue nm <=< force . snd) elems + return (concat xss, concat sxs) + VVector (V.toList -> ts) -> do (xss, ss) <- unzip <$> traverse (force >=> flattenSValue nm) ts + return (concat xss, concat ss) + VBool sb -> return ([sb], "") + VInt si -> return ([si], "") + VIntMod 0 si -> return ([si], "") + VIntMod n si -> return ([svRem si (svInteger KUnbounded (toInteger n))], "") + VWord sw -> return (if intSizeOf sw > 0 then [sw] else [], "") + VCtorApp i (V.toList->ts) -> do (xss, ss) <- unzip <$> traverse (force >=> flattenSValue nm) ts + return (concat xss, "_" ++ identName i ++ concat ss) + VNat n -> return ([], "_" ++ show n) + TValue (suffixTValue -> Just s) + -> return ([], s) + VFun _ -> fail $ "Cannot create uninterpreted higher-order function " ++ show nm + _ -> fail $ "Cannot create uninterpreted function " ++ show nm ++ " with argument " ++ show v + +vWord :: SWord -> SValue +vWord lv = VWord lv + +vBool :: SBool -> SValue +vBool l = VBool l + +vInteger :: SInteger -> SValue +vInteger x = VInt x + +------------------------------------------------------------ +-- Function constructors + +wordFun :: (SWord -> IO SValue) -> SValue +wordFun f = strictFun (\x -> toWord x >>= f) + +------------------------------------------------------------ +-- Indexing operations + +-- | Lifts a strict mux operation to a lazy mux +lazyMux :: (SBool -> a -> a -> IO a) -> (SBool -> IO a -> IO a -> IO a) +lazyMux muxFn c tm fm = + case svAsBool c of + Just True -> tm + Just False -> fm + Nothing -> do + t <- tm + f <- fm + muxFn c t f + +-- selectV merger maxValue valueFn index returns valueFn v when index has value v +-- if index is greater than maxValue, it returns valueFn maxValue. Use the ite op from merger. +selectV :: (SBool -> b -> b -> b) -> Natural -> (Natural -> b) -> SWord -> b +selectV merger maxValue valueFn vx = + case svAsInteger vx of + Just i + | i >= 0 -> valueFn (fromInteger i) + | otherwise -> Prims.panic "selectV" ["expected nonnegative integer", show i] + Nothing -> impl (intSizeOf vx) 0 + where + impl _ x | x > maxValue || x < 0 = valueFn maxValue + impl 0 y = valueFn y + impl i y = merger (svTestBit vx j) (impl j (y `setBit` j)) (impl j y) where j = i - 1 + +-- Big-endian version of svTestBit +svAt :: SWord -> Int -> SBool +svAt x i = svTestBit x (intSizeOf x - 1 - i) + +svUnpack :: SWord -> IO (Vector SBool) +svUnpack x = return (V.generate (intSizeOf x) (svAt x)) + +asWordList :: [SValue] -> Maybe [SWord] +asWordList = go id + where + go f [] = Just (f []) + go f (VWord x : xs) = go (f . (x:)) xs + go _ _ = Nothing + +svSlice :: Int -> Int -> SWord -> SWord +svSlice i j x = svExtract (w - i - 1) (w - i - j) x + where w = intSizeOf x + +---------------------------------------- +-- Shift operations + +-- | op : (n : Nat) -> Vec n Bool -> Nat -> Vec n Bool +bvShiftOp :: (SWord -> SWord -> SWord) -> (SWord -> Int -> SWord) -> SValue +bvShiftOp bvOp natOp = + constFun $ + wordFun $ \x -> return $ + strictFun $ \y -> + case y of + VNat i | j < toInteger (maxBound :: Int) -> return (vWord (natOp x (fromInteger j))) + where j = toInteger i `min` toInteger (intSizeOf x) + VToNat v -> fmap (vWord . bvOp x) (toWord v) + _ -> error $ unwords ["Verifier.SAW.Simulator.SBV.bvShiftOp", show y] + +-- bvShl : (w : Nat) -> Vec w Bool -> Nat -> Vec w Bool; +bvShLOp :: SValue +bvShLOp = bvShiftOp svShiftLeft svShl + +-- bvShR : (w : Nat) -> Vec w Bool -> Nat -> Vec w Bool; +bvShROp :: SValue +bvShROp = bvShiftOp svShiftRight svShr + +-- bvSShR : (w : Nat) -> Vec w Bool -> Nat -> Vec w Bool; +bvSShROp :: SValue +bvSShROp = bvShiftOp bvOp natOp + where + bvOp w x = svUnsign (svShiftRight (svSign w) x) + natOp w i = svUnsign (svShr (svSign w) i) + +----------------------------------------- +-- Integer/bitvector conversions + +-- primitive intToNat : Integer -> Nat; +-- intToNat x == max 0 x +intToNatOp :: SValue +intToNatOp = + Prims.intFun "intToNat" $ \i -> + case svAsInteger i of + Just i' + | 0 <= i' -> pure (VNat (fromInteger i')) + | otherwise -> pure (VNat 0) + Nothing -> + let z = svInteger KUnbounded 0 + i' = svIte (svLessThan i z) z i + in pure (VToNat (VInt i')) + +-- primitive natToInt :: Nat -> Integer; +natToIntOp :: SValue +natToIntOp = + Prims.natFun' "natToInt" $ \n -> return $ + VInt (literalSInteger (toInteger n)) + +-- primitive bvToInt : (n : Nat) -> Vec n Bool -> Integer; +bvToIntOp :: SValue +bvToIntOp = constFun $ wordFun $ \v -> + case svAsInteger v of + Just i -> return $ VInt (literalSInteger i) + Nothing -> return $ VInt (svFromIntegral KUnbounded v) + +-- primitive sbvToInt : (n : Nat) -> Vec n Bool -> Integer; +sbvToIntOp :: SValue +sbvToIntOp = constFun $ wordFun $ \v -> + case svAsInteger (svSign v) of + Just i -> return $ VInt (literalSInteger i) + Nothing -> return $ VInt (svFromIntegral KUnbounded (svSign v)) + +-- primitive intToBv : (n : Nat) -> Integer -> Vec n Bool; +intToBvOp :: SValue +intToBvOp = + Prims.natFun' "intToBv n" $ \n -> return $ + Prims.intFun "intToBv x" $ \x -> + case svAsInteger x of + Just i -> return $ VWord $ literalSWord (fromIntegral n) i + Nothing -> return $ VWord $ svFromIntegral (KBounded False (fromIntegral n)) x + +------------------------------------------------------------ +-- Rotations and shifts + +svRol' :: SWord -> Integer -> SWord +svRol' x i = svRol x (fromInteger (i `mod` toInteger (intSizeOf x))) + +svRor' :: SWord -> Integer -> SWord +svRor' x i = svRor x (fromInteger (i `mod` toInteger (intSizeOf x))) + +svShl' :: SBool -> SWord -> Integer -> SWord +svShl' b x i = svIte b (svNot (svShl (svNot x) j)) (svShl x j) + where j = fromInteger (i `min` toInteger (intSizeOf x)) + +svShr' :: SBool -> SWord -> Integer -> SWord +svShr' b x i = svIte b (svNot (svShr (svNot x) j)) (svShr x j) + where j = fromInteger (i `min` toInteger (intSizeOf x)) + +svShiftL :: SBool -> SWord -> SWord -> SWord +svShiftL b x i = svIte b (svNot (svShiftLeft (svNot x) i)) (svShiftLeft x i) + +svShiftR :: SBool -> SWord -> SWord -> SWord +svShiftR b x i = svIte b (svNot (svShiftRight (svNot x) i)) (svShiftRight x i) + +------------------------------------------------------------ +-- Integers mod n + +toIntModOp :: SValue +toIntModOp = + Prims.natFun' "toIntMod" $ \n -> pure $ + Prims.intFun "toIntMod" $ \x -> pure $ + VIntMod n x + +fromIntModOp :: SValue +fromIntModOp = + Prims.natFun $ \n -> return $ + Prims.intModFun "fromIntModOp" $ \x -> return $ + VInt (svRem x (literalSInteger (toInteger n))) + +intModEqOp :: SValue +intModEqOp = + Prims.natFun $ \n -> return $ + Prims.intModFun "intModEqOp" $ \x -> return $ + Prims.intModFun "intModEqOp" $ \y -> return $ + let modulus = literalSInteger (toInteger n) + in VBool (svEqual (svRem (svMinus x y) modulus) (literalSInteger 0)) + +intModBinOp :: (SInteger -> SInteger -> SInteger) -> SValue +intModBinOp f = + Prims.natFun $ \n -> return $ + Prims.intModFun "intModBinOp x" $ \x -> return $ + Prims.intModFun "intModBinOp y" $ \y -> return $ + VIntMod n (normalizeIntMod n (f x y)) + +intModUnOp :: (SInteger -> SInteger) -> SValue +intModUnOp f = + Prims.natFun $ \n -> return $ + Prims.intModFun "intModUnOp" $ \x -> return $ + VIntMod n (normalizeIntMod n (f x)) + +normalizeIntMod :: Natural -> SInteger -> SInteger +normalizeIntMod n x = + case svAsInteger x of + Nothing -> x + Just i -> literalSInteger (i `mod` toInteger n) + +------------------------------------------------------------ +-- Stream operations + +-- MkStream :: (a :: sort 0) -> (Nat -> a) -> Stream a; +mkStreamOp :: SValue +mkStreamOp = + constFun $ + strictFun $ \f -> do + r <- newIORef Map.empty + return $ VExtra (SStream (\n -> apply f (ready (VNat n))) r) + +-- streamGet :: (a :: sort 0) -> Stream a -> Nat -> a; +streamGetOp :: SValue +streamGetOp = + constFun $ + strictFun $ \xs -> return $ + strictFun $ \case + VNat n -> lookupSStream xs n + VToNat w -> + do ilv <- toWord w + selectV (lazyMux muxBVal) ((2 ^ intSizeOf ilv) - 1) (lookupSStream xs) ilv + v -> Prims.panic "SBV.streamGetOp" ["Expected Nat value", show v] + + +lookupSStream :: SValue -> Natural -> IO SValue +lookupSStream (VExtra s) n = lookupSbvExtra s n +lookupSStream _ _ = fail "expected Stream" + +lookupSbvExtra :: SbvExtra -> Natural -> IO SValue +lookupSbvExtra (SStream f r) n = + do m <- readIORef r + case Map.lookup n m of + Just v -> return v + Nothing -> do v <- f n + writeIORef r (Map.insert n v m) + return v + +------------------------------------------------------------ +-- Misc operations + +svPopcount :: SWord -> SWord +svPopcount xs = if w == 0 then zero else foldr1 svPlus [ svIte b one zero | b <- bits ] + where + bits = svBlastLE xs + w = length bits + one = literalSWord w 1 + zero = literalSWord w 0 + +svCountLeadingZeros :: SWord -> SWord +svCountLeadingZeros xs = go 0 bits + where + bits = svBlastBE xs + w = length bits + go !i [] = literalSWord w i + go !i (b:bs) = svIte b (literalSWord w i) (go (i+1) bs) + +svCountTrailingZeros :: SWord -> SWord +svCountTrailingZeros xs = go 0 bits + where + bits = svBlastLE xs + w = length bits + go !i [] = literalSWord w i + go !i (b:bs) = svIte b (literalSWord w i) (go (i+1) bs) + +-- | Ceiling (log_2 x) +sLg2 :: SWord -> SWord +sLg2 x = go 0 + where + lit n = literalSWord (intSizeOf x) n + go i | i < intSizeOf x = svIte (svLessEq x (lit (2^i))) (lit (toInteger i)) (go (i + 1)) + | otherwise = lit (toInteger i) + +------------------------------------------------------------ +-- Ite ops + +muxBVal :: SBool -> SValue -> SValue -> IO SValue +muxBVal = Prims.muxValue prims + +muxSbvExtra :: SBool -> SbvExtra -> SbvExtra -> IO SbvExtra +muxSbvExtra c x y = + do let f i = do xi <- lookupSbvExtra x i + yi <- lookupSbvExtra y i + muxBVal c xi yi + r <- newIORef Map.empty + return (SStream f r) + +------------------------------------------------------------ +-- External interface + +-- | Abstract constants with names in the list 'unints' are kept as +-- uninterpreted constants; all others are unfolded. +sbvSolveBasic :: SharedContext -> Map Ident SValue -> Set VarIndex -> Term -> IO SValue +sbvSolveBasic sc addlPrims unintSet t = do + m <- scGetModuleMap sc + + let extcns (EC ix nm ty) = parseUninterpreted [] (Text.unpack (toShortName nm) ++ "#" ++ show ix) ty + let uninterpreted ec + | Set.member (ecVarIndex ec) unintSet = Just (extcns ec) + | otherwise = Nothing + cfg <- Sim.evalGlobal m (Map.union constMap addlPrims) extcns uninterpreted + Sim.evalSharedTerm cfg t + +parseUninterpreted :: [SVal] -> String -> TValue SBV -> IO SValue +parseUninterpreted cws nm ty = + case ty of + (VPiType _ f) + -> return $ + strictFun $ \x -> do + (cws', suffix) <- flattenSValue nm x + t2 <- f (ready x) + parseUninterpreted (cws ++ cws') (nm ++ suffix) t2 + + VBoolType + -> return $ vBool $ mkUninterpreted KBool cws nm + + VIntType + -> return $ vInteger $ mkUninterpreted KUnbounded cws nm + + VIntModType n + -> return $ VIntMod n $ mkUninterpreted KUnbounded cws nm + + (VVecType n VBoolType) + -> return $ vWord $ mkUninterpreted (KBounded False (fromIntegral n)) cws nm + + (VVecType n ety) + -> do xs <- sequence $ + [ parseUninterpreted cws (nm ++ "@" ++ show i) ety + | i <- [0 .. n-1] ] + return (VVector (V.fromList (map ready xs))) + + VUnitType + -> return VUnit + + (VPairType ty1 ty2) + -> do x1 <- parseUninterpreted cws (nm ++ ".L") ty1 + x2 <- parseUninterpreted cws (nm ++ ".R") ty2 + return (VPair (ready x1) (ready x2)) + + (VRecordType elem_tps) + -> (VRecordValue <$> + mapM (\(f,tp) -> + (f,) <$> ready <$> + parseUninterpreted cws (nm ++ "." ++ Text.unpack f) tp) elem_tps) + + _ -> fail $ "could not create uninterpreted type for " ++ show ty + +mkUninterpreted :: Kind -> [SVal] -> String -> SVal +mkUninterpreted k args nm = svUninterpreted k nm' Nothing args + where nm' = "|" ++ nm ++ "|" -- enclose name to allow primes and other non-alphanum chars + +sbvSATQuery :: SharedContext -> Map Ident SValue -> SATQuery -> IO ([Labeler], [ExtCns Term], Symbolic SBool) +sbvSATQuery sc addlPrims query = + do true <- liftIO (scBool sc True) + t <- liftIO (foldM (scAnd sc) true (satAsserts query)) + let qvars = Map.toList (satVariables query) + let unintSet = satUninterp query + + (labels, vars) <- + flip evalStateT 0 $ unzip <$> + mapM (newVars . snd) qvars + + m <- liftIO (scGetModuleMap sc) + + return (labels, map fst qvars, + do vars' <- sequence vars + let varMap = Map.fromList (zip (map (ecVarIndex . fst) qvars) vars') + + let mkUninterp (EC ix nm ty) = + parseUninterpreted [] (Text.unpack (toShortName nm) ++ "#" ++ show ix) ty + let extcns ec + | Just v <- Map.lookup (ecVarIndex ec) varMap = pure v + | otherwise = mkUninterp ec + let uninterpreted ec + | Set.member (ecVarIndex ec) unintSet = Just (mkUninterp ec) + | otherwise = Nothing + + cfg <- liftIO (Sim.evalGlobal m (Map.union constMap addlPrims) extcns uninterpreted) + bval <- liftIO (Sim.evalSharedTerm cfg t) + + case bval of + VBool b -> return b + _ -> fail $ "sbvSATQuery: non-boolean result type. " ++ show bval + ) + +data Labeler + = BoolLabel String + | IntegerLabel String + | WordLabel String + | VecLabel (Vector Labeler) + | TupleLabel (Vector Labeler) + | RecLabel (Map FieldName Labeler) + deriving (Show) + +nextId :: StateT Int IO String +nextId = ST.get >>= (\s-> modify (+1) >> return ("x" ++ show s)) + +unzipMap :: Map k (a, b) -> (Map k a, Map k b) +unzipMap m = (fmap fst m, fmap snd m) + +newVars :: FirstOrderType -> StateT Int IO (Labeler, Symbolic SValue) +newVars FOTBit = nextId <&> \s-> (BoolLabel s, vBool <$> existsSBool s) +newVars FOTInt = nextId <&> \s-> (IntegerLabel s, vInteger <$> existsSInteger s) +newVars (FOTIntMod n) = nextId <&> \s-> (IntegerLabel s, VIntMod n <$> existsSInteger s) +newVars (FOTVec n FOTBit) = + if n == 0 + then nextId <&> \s-> (WordLabel s, return (vWord (literalSWord 0 0))) + else nextId <&> \s-> (WordLabel s, vWord <$> existsSWord s (fromIntegral n)) +newVars (FOTVec n tp) = do + (labels, vals) <- V.unzip <$> V.replicateM (fromIntegral n) (newVars tp) + return (VecLabel labels, VVector <$> traverse (fmap ready) vals) +newVars (FOTArray{}) = fail "FOTArray unimplemented for backend" +newVars (FOTTuple ts) = do + (labels, vals) <- V.unzip <$> traverse newVars (V.fromList ts) + return (TupleLabel labels, vTuple <$> traverse (fmap ready) (V.toList vals)) +newVars (FOTRec tm) = do + (labels, vals) <- unzipMap <$> (traverse newVars tm :: StateT Int IO (Map FieldName (Labeler, Symbolic SValue))) + return (RecLabel labels, vRecord <$> traverse (fmap ready) (vals :: (Map FieldName (Symbolic SValue)))) + + +getLabels :: + [Labeler] -> + Map String CV -> + [ExtCns Term] -> Maybe [(ExtCns Term,FirstOrderValue)] + +getLabels ls d args + | length args == length xs = Just (zip args xs) + | otherwise = error $ unwords + [ "SBV SAT results do not match expected arguments " + , show (map (toShortName . ecName) args), show xs] + + where + xs = fmap getLabel ls + + getLabel (BoolLabel s) = FOVBit (cvToBool (d Map.! s)) + getLabel (IntegerLabel s) = FOVInt (cvToInteger (d Map.! s)) + + getLabel (WordLabel s) = FOVWord (cvKind cv) (cvToInteger cv) + where cv = d Map.! s + + getLabel (VecLabel ns) + | V.null ns = error "getLabel of empty vector" + | otherwise = fovVec t vs + where vs = map getLabel (V.toList ns) + t = firstOrderTypeOf (head vs) + + getLabel (TupleLabel ns) = FOVTuple $ map getLabel (V.toList ns) + getLabel (RecLabel ns) = FOVRec $ fmap getLabel ns + + cvKind cv = + case kindOf cv of + KBounded _ k -> fromIntegral k + _ -> error "cvKind" + + cvToInteger cv = + case cvVal cv of + CInteger i -> i + _ -> error "cvToInteger" + + +------------------------------------------------------------ +-- Code Generation + +newCodeGenVars :: (Natural -> Bool) -> FirstOrderType -> StateT Int IO (SBVCodeGen SValue) +newCodeGenVars _checkSz FOTBit = nextId <&> \s -> (vBool <$> svCgInput KBool s) +newCodeGenVars _checkSz FOTInt = nextId <&> \s -> (vInteger <$> svCgInput KUnbounded s) +newCodeGenVars _checkSz (FOTIntMod _) = nextId <&> \s -> (vInteger <$> svCgInput KUnbounded s) +newCodeGenVars checkSz (FOTVec n FOTBit) + | n == 0 = nextId <&> \_ -> return (vWord (literalSWord 0 0)) + | checkSz n = nextId <&> \s -> vWord <$> cgInputSWord s (fromIntegral n) + | otherwise = nextId <&> \s -> fail $ "Invalid codegen bit width for input variable \'" ++ s ++ "\': " ++ show n +newCodeGenVars checkSz (FOTVec n (FOTVec m FOTBit)) + | m == 0 = nextId <&> \_ -> return (VVector $ V.fromList $ replicate (fromIntegral n) (ready $ vWord (literalSWord 0 0))) + | checkSz m = do + let k = KBounded False (fromIntegral m) + vals <- nextId <&> \s -> svCgInputArr k (fromIntegral n) s + return (VVector . V.fromList . fmap (ready . vWord) <$> vals) + | otherwise = nextId <&> \s -> fail $ "Invalid codegen bit width for input variable array \'" ++ s ++ "\': " ++ show n +newCodeGenVars checkSz (FOTVec n tp) = do + vals <- V.replicateM (fromIntegral n) (newCodeGenVars checkSz tp) + return (VVector <$> traverse (fmap ready) vals) +newCodeGenVars _ (FOTArray{}) = fail "FOTArray unimplemented for backend" +newCodeGenVars checkSz (FOTTuple ts) = do + vals <- traverse (newCodeGenVars checkSz) ts + return (vTuple <$> traverse (fmap ready) vals) +newCodeGenVars checkSz (FOTRec tm) = do + vals <- traverse (newCodeGenVars checkSz) tm + return (vRecord <$> traverse (fmap ready) vals) + +cgInputSWord :: String -> Int -> SBVCodeGen SWord +cgInputSWord s n = svCgInput (KBounded False n) s + +argTypes :: SharedContext -> Term -> IO ([Term], Term) +argTypes sc t = do + t' <- scWhnf sc t + case t' of + (R.asPi -> Just (_, t1, t2)) -> do + (ts,res) <- argTypes sc t2 + return (t1:ts, res) + _ -> return ([], t') + +sbvCodeGen_definition + :: SharedContext + -> Map Ident SValue + -> Set VarIndex + -> Term + -> (Natural -> Bool) -- ^ Allowed word sizes + -> IO (SBVCodeGen (), [FirstOrderType], FirstOrderType) +sbvCodeGen_definition sc addlPrims unintSet t checkSz = do + ty <- scTypeOf sc t + (argTs,resTy) <- argTypes sc ty + shapes <- traverse (asFirstOrderType sc) argTs + resultShape <- asFirstOrderType sc resTy + bval <- sbvSolveBasic sc addlPrims unintSet t + vars <- evalStateT (traverse (newCodeGenVars checkSz) shapes) 0 + let codegen = do + args <- traverse (fmap ready) vars + bval' <- liftIO (applyAll bval args) + sbvSetResult checkSz resultShape bval' + return (codegen, shapes, resultShape) + + +sbvSetResult :: (Natural -> Bool) + -> FirstOrderType + -> SValue + -> SBVCodeGen () +sbvSetResult _checkSz FOTBit (VBool b) = do + svCgReturn b +sbvSetResult checkSz (FOTVec n FOTBit) v + | n == 0 = return () + | checkSz n = do + w <- liftIO $ toWord v + svCgReturn w + | otherwise = + fail $ "Invalid word size in result: " ++ show n +sbvSetResult checkSz ft v = do + void $ sbvSetOutput checkSz ft v 0 + + +sbvSetOutput :: (Natural -> Bool) + -> FirstOrderType + -> SValue + -> Int + -> SBVCodeGen Int +sbvSetOutput _checkSz FOTBit (VBool b) i = do + svCgOutput ("out_"++show i) b + return $! i+1 +sbvSetOutput checkSz (FOTVec n FOTBit) v i + | n == 0 = return i + | checkSz n = do + w <- liftIO $ toWord v + svCgOutput ("out_"++show i) w + return $! i+1 + | otherwise = + fail $ "Invalid word size in output " ++ show i ++ ": " ++ show n + +sbvSetOutput checkSz (FOTVec n t) (VVector xv) i = do + xs <- liftIO $ traverse force $ V.toList xv + unless (toInteger n == toInteger (length xs)) $ + fail "sbvCodeGen: vector length mismatch when setting output values" + case asWordList xs of + Just ws -> do svCgOutputArr ("out_"++show i) ws + return $! i+1 + Nothing -> foldM (\i' x -> sbvSetOutput checkSz t x i') i xs +sbvSetOutput _checkSz (FOTTuple []) VUnit i = + return i +sbvSetOutput checkSz (FOTTuple [t]) v i = sbvSetOutput checkSz t v i +sbvSetOutput checkSz (FOTTuple (t:ts)) (VPair l r) i = do + l' <- liftIO $ force l + r' <- liftIO $ force r + sbvSetOutput checkSz t l' i >>= sbvSetOutput checkSz (FOTTuple ts) r' + +sbvSetOutput _checkSz (FOTRec fs) VUnit i | Map.null fs = do + return i + +sbvSetOutput _checkSz (FOTRec fs) (VRecordValue []) i | Map.null fs = return i + +sbvSetOutput checkSz (FOTRec fs) (VRecordValue ((fn,x):rest)) i = do + x' <- liftIO $ force x + case Map.lookup fn fs of + Just t -> do + let fs' = Map.delete fn fs + sbvSetOutput checkSz t x' i >>= + sbvSetOutput checkSz (FOTRec fs') (VRecordValue rest) + Nothing -> fail "sbvCodeGen: type mismatch when setting record output value" + +sbvSetOutput _checkSz _ft _v _i = do + fail "sbvCode gen: type mismatch when setting output values" + + +sbvCodeGen :: SharedContext + -> Map Ident SValue + -> Set VarIndex + -> Maybe FilePath + -> String + -> Term + -> IO () +sbvCodeGen sc addlPrims unintSet path fname t = do + -- The SBV C code generator expects only these word sizes + let checkSz n = n `elem` [8,16,32,64] + + (codegen,_,_) <- sbvCodeGen_definition sc addlPrims unintSet t checkSz + compileToC path fname codegen diff --git a/saw-core-sbv/src/Verifier/SAW/Simulator/SBV/SWord.hs b/saw-core-sbv/src/Verifier/SAW/Simulator/SBV/SWord.hs new file mode 100644 index 0000000000..ff76d32bcb --- /dev/null +++ b/saw-core-sbv/src/Verifier/SAW/Simulator/SBV/SWord.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +{- | +Module : Verifier.SAW.Simulator.SBV.SWord +Copyright : Galois, Inc. 2012-2015 +License : BSD3 +Maintainer : huffman@galois.com +Stability : experimental +Portability : non-portable (language extensions) +-} +module Verifier.SAW.Simulator.SBV.SWord + ( SBool, SWord, SInteger + , literalSWord, literalSInteger + , fromBitsLE + , forallSWord, existsSWord, forallSWord_, existsSWord_ + , forallSBool, existsSBool, forallSBool_, existsSBool_ + , forallSInteger, existsSInteger, forallSInteger_, existsSInteger_ + ) where + +import Control.Monad.Reader +import Data.List (foldl') + +import Data.SBV ( symbolicEnv ) +import Data.SBV.Dynamic + +type SBool = SVal +type SWord = SVal +type SInteger = SVal + +fromBitsLE :: [SBool] -> SWord +fromBitsLE bs = foldl' f (literalSWord 0 0) bs + where f w b = svJoin (svToWord1 b) w + +literalSWord :: Int -> Integer -> SWord +literalSWord w i = svInteger (KBounded False w) i + +literalSInteger :: Integer -> SWord +literalSInteger i = svInteger KUnbounded i + +forallSWord :: String -> Int -> Symbolic SWord +forallSWord nm w = symbolicEnv >>= liftIO . svMkSymVar (Just ALL) (KBounded False w) (Just nm) + +forallSWord_ :: Int -> Symbolic SWord +forallSWord_ w = symbolicEnv >>= liftIO . svMkSymVar (Just ALL) (KBounded False w) Nothing + +existsSWord :: String -> Int -> Symbolic SWord +existsSWord nm w = symbolicEnv >>= liftIO . svMkSymVar (Just EX) (KBounded False w) (Just nm) + +existsSWord_ :: Int -> Symbolic SWord +existsSWord_ w = symbolicEnv >>= liftIO . svMkSymVar (Just EX) (KBounded False w) Nothing + +forallSBool :: String -> Symbolic SBool +forallSBool nm = symbolicEnv >>= liftIO . svMkSymVar (Just ALL) KBool (Just nm) + +existsSBool :: String -> Symbolic SBool +existsSBool nm = symbolicEnv >>= liftIO . svMkSymVar (Just EX) KBool (Just nm) + +forallSBool_ :: Symbolic SBool +forallSBool_ = symbolicEnv >>= liftIO . svMkSymVar (Just ALL) KBool Nothing + +existsSBool_ :: Symbolic SBool +existsSBool_ = symbolicEnv >>= liftIO . svMkSymVar (Just EX) KBool Nothing + +forallSInteger :: String -> Symbolic SInteger +forallSInteger nm = symbolicEnv >>= liftIO . svMkSymVar (Just ALL) KUnbounded (Just nm) + +existsSInteger :: String -> Symbolic SInteger +existsSInteger nm = symbolicEnv >>= liftIO . svMkSymVar (Just EX) KUnbounded (Just nm) + +forallSInteger_ :: Symbolic SInteger +forallSInteger_ = symbolicEnv >>= liftIO . svMkSymVar (Just ALL) KUnbounded Nothing + +existsSInteger_ :: Symbolic SInteger +existsSInteger_ = symbolicEnv >>= liftIO . svMkSymVar (Just EX) KUnbounded Nothing diff --git a/saw-core-what4/.gitignore b/saw-core-what4/.gitignore new file mode 100644 index 0000000000..8f0f594227 --- /dev/null +++ b/saw-core-what4/.gitignore @@ -0,0 +1,3 @@ +.stack-work/ +dist/ +dist-newstyle/ diff --git a/saw-core-what4/Changelog.md b/saw-core-what4/Changelog.md new file mode 100644 index 0000000000..020ecadf40 --- /dev/null +++ b/saw-core-what4/Changelog.md @@ -0,0 +1,9 @@ +# Changelog for the `saw-core-what4` package + +## 0.2 -- *2019 Nov 06* + + * Bumped upper version bound for parameterized-utils + +## 0.1 -- *2018 Jun 06* + + * Initial version diff --git a/saw-core-what4/LICENSE b/saw-core-what4/LICENSE new file mode 100644 index 0000000000..9e2f031c53 --- /dev/null +++ b/saw-core-what4/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2012-2016, 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 names of the authors nor the names of other + 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/saw-core-what4/README.md b/saw-core-what4/README.md new file mode 100644 index 0000000000..5f49d96494 --- /dev/null +++ b/saw-core-what4/README.md @@ -0,0 +1,2 @@ +This repository contains a backend for the `saw-core` library that uses +the `what4` library for communication with SMT solvers. diff --git a/saw-core-what4/Setup.hs b/saw-core-what4/Setup.hs new file mode 100644 index 0000000000..9a994af677 --- /dev/null +++ b/saw-core-what4/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/saw-core-what4/saw-core-what4.cabal b/saw-core-what4/saw-core-what4.cabal new file mode 100644 index 0000000000..b7504e73ba --- /dev/null +++ b/saw-core-what4/saw-core-what4.cabal @@ -0,0 +1,39 @@ +Name: saw-core-what4 +Version: 0.2 +License: BSD3 +License-file: LICENSE +Author: Galois, Inc. +Maintainer: sweirich@galois.com +Copyright: (c) 2018 Galois Inc. +Category: Formal Methods +Build-type: Simple +cabal-version: >= 1.8 +Synopsis: SAWCore backend for What4 +Description: + A backend for symbolically evaluating terms in the SAWCore + intermediate language using the What4 library to generate SMT-Lib. + +library + build-depends: + base == 4.*, + bv-sized >= 1.0.0, + containers, + lens, + mtl, + saw-core, + what4, + panic, + text, + transformers, + vector, + parameterized-utils >= 1.0.8 && < 2.2, + reflection + hs-source-dirs: src + exposed-modules: + Verifier.SAW.Simulator.What4 + Verifier.SAW.Simulator.What4.FirstOrder + Verifier.SAW.Simulator.What4.PosNat + Verifier.SAW.Simulator.What4.Panic + Verifier.SAW.Simulator.What4.ReturnTrip + + GHC-options: -Wall -Werror diff --git a/saw-core-what4/src/Verifier/SAW/Simulator/What4.hs b/saw-core-what4/src/Verifier/SAW/Simulator/What4.hs new file mode 100644 index 0000000000..05d1495748 --- /dev/null +++ b/saw-core-what4/src/Verifier/SAW/Simulator/What4.hs @@ -0,0 +1,1390 @@ +------------------------------------------------------------------------ +-- | +-- Module : Verifier.SAW.Simulator.What4 +-- Copyright : Galois, Inc. 2012-2015 +-- License : BSD3 +-- Maintainer : sweirich@galois.com +-- Stability : experimental +-- Portability : non-portable (language extensions) +-- +-- A symbolic simulator for saw-core terms using What4. +-- (This module is derived from Verifier.SAW.Simulator.SBV) +------------------------------------------------------------------------ + +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds#-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE TypeApplications #-} + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE AllowAmbiguousTypes #-} + +-- WithKnownNat +{-# OPTIONS_GHC -Wno-warnings-deprecations #-} + + +module Verifier.SAW.Simulator.What4 + ( w4Solve + , w4SolveBasic + , SymFnCache + , TypedExpr(..) + , SValue + , Labeler(..) + , w4Eval + , w4EvalAny + , w4EvalBasic + , getLabelValues + + , w4SimulatorEval + , NeutralTermException(..) + + , valueToSymExpr + , symExprToValue + ) where + + + +import qualified Control.Arrow as A + +import Data.Bits +import Data.IORef +import Data.List (genericTake) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Set (Set) +import qualified Data.Set as Set +import qualified Data.Text as Text +import Data.Vector (Vector) +import qualified Data.Vector as V + +import Data.Traversable as T +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif +import qualified Control.Exception as X +import Control.Monad.State as ST +import Numeric.Natural (Natural) + +-- saw-core +import qualified Verifier.SAW.Recognizer as R +import qualified Verifier.SAW.Simulator as Sim +import qualified Verifier.SAW.Simulator.Prims as Prims +import Verifier.SAW.SATQuery +import Verifier.SAW.SharedTerm +import Verifier.SAW.Simulator.Value +import Verifier.SAW.FiniteValue (FirstOrderType(..), FirstOrderValue(..)) +import Verifier.SAW.TypedAST (FieldName, ModuleMap, identName, toShortName) + +-- what4 +import qualified What4.Expr.Builder as B +import What4.Expr.GroundEval +import What4.Interface(SymExpr,Pred,SymInteger, IsExpr, + IsExprBuilder,IsSymExprBuilder) +import qualified What4.Interface as W +import What4.BaseTypes +import qualified What4.SWord as SW +import What4.SWord (SWord(..)) + +-- parameterized-utils +import qualified Data.Parameterized.Context as Ctx +import Data.Parameterized.Map (MapF) +import qualified Data.Parameterized.Map as MapF +import Data.Parameterized.Context (Assignment) +import Data.Parameterized.Some + +-- saw-core-what4 +import Verifier.SAW.Simulator.What4.PosNat +import Verifier.SAW.Simulator.What4.FirstOrder +import Verifier.SAW.Simulator.What4.Panic +import Verifier.SAW.Simulator.What4.ReturnTrip + +--------------------------------------------------------------------- +-- empty datatype to index (open) type families +-- for this backend +data What4 (sym :: *) + +-- | A What4 symbolic array where the domain and co-domain types do not appear +-- in the type +data SArray sym where + SArray :: + W.IsExpr (W.SymExpr sym) => + W.SymArray sym (Ctx.EmptyCtx Ctx.::> itp) etp -> + SArray sym + +-- type abbreviations for uniform naming +type SBool sym = Pred sym +type SInt sym = SymInteger sym + +type instance EvalM (What4 sym) = IO +type instance VBool (What4 sym) = SBool sym +type instance VWord (What4 sym) = SWord sym +type instance VInt (What4 sym) = SInt sym +type instance VArray (What4 sym) = SArray sym +type instance Extra (What4 sym) = What4Extra sym + +type SValue sym = Value (What4 sym) + +-- Constraint +type Sym sym = IsSymExprBuilder sym + +--------------------------------------------------------------------- + +data What4Extra sym = + SStream (Natural -> IO (SValue sym)) (IORef (Map Natural (SValue sym))) + +instance Show (What4Extra sym) where + show (SStream _ _) = "" + +--------------------------------------------------------------------- +-- +-- Basic primitive table for What4 data +-- + +prims :: forall sym. + Sym sym => sym -> Prims.BasePrims (What4 sym) +prims sym = + Prims.BasePrims + { Prims.bpAsBool = W.asConstantPred + -- Bitvectors + , Prims.bpUnpack = SW.bvUnpackBE sym + , Prims.bpPack = SW.bvPackBE sym + , Prims.bpBvAt = \w i -> SW.bvAtBE sym w (toInteger i) + , Prims.bpBvLit = \l x -> SW.bvLit sym (toInteger l) x + , Prims.bpBvSize = swBvWidth + , Prims.bpBvJoin = SW.bvJoin sym + , Prims.bpBvSlice = \ a b -> SW.bvSliceBE sym (toInteger a) (toInteger b) + -- Conditionals + , Prims.bpMuxBool = W.itePred sym + , Prims.bpMuxWord = SW.bvIte sym + , Prims.bpMuxInt = W.intIte sym + , Prims.bpMuxExtra = muxWhat4Extra sym + -- Booleans + , Prims.bpTrue = W.truePred sym + , Prims.bpFalse = W.falsePred sym + , Prims.bpNot = W.notPred sym + , Prims.bpAnd = W.andPred sym + , Prims.bpOr = W.orPred sym + , Prims.bpXor = W.xorPred sym + , Prims.bpBoolEq = W.isEq sym + -- Bitvector logical + , Prims.bpBvNot = SW.bvNot sym + , Prims.bpBvAnd = SW.bvAnd sym + , Prims.bpBvOr = SW.bvOr sym + , Prims.bpBvXor = SW.bvXor sym + -- Bitvector arithmetic + , Prims.bpBvNeg = SW.bvNeg sym + , Prims.bpBvAdd = SW.bvAdd sym + , Prims.bpBvSub = SW.bvSub sym + , Prims.bpBvMul = SW.bvMul sym + , Prims.bpBvUDiv = SW.bvUDiv sym + , Prims.bpBvURem = SW.bvURem sym + , Prims.bpBvSDiv = SW.bvSDiv sym + , Prims.bpBvSRem = SW.bvSRem sym + , Prims.bpBvLg2 = SW.bvLg2 sym + -- Bitvector comparisons + , Prims.bpBvEq = SW.bvEq sym + , Prims.bpBvsle = SW.bvsle sym + , Prims.bpBvslt = SW.bvslt sym + , Prims.bpBvule = SW.bvule sym + , Prims.bpBvult = SW.bvult sym + , Prims.bpBvsge = SW.bvsge sym + , Prims.bpBvsgt = SW.bvsgt sym + , Prims.bpBvuge = SW.bvuge sym + , Prims.bpBvugt = SW.bvugt sym + -- Bitvector shift/rotate + , Prims.bpBvRolInt = liftRotate sym (SW.bvRol sym) + , Prims.bpBvRorInt = liftRotate sym (SW.bvRor sym) + , Prims.bpBvShlInt = \z -> liftShift sym (bvShl sym z) + , Prims.bpBvShrInt = \z -> liftShift sym (bvShr sym z) + , Prims.bpBvRol = SW.bvRol sym + , Prims.bpBvRor = SW.bvRor sym + , Prims.bpBvShl = bvShl sym + , Prims.bpBvShr = bvShr sym + -- Bitvector misc + , Prims.bpBvPopcount = SW.bvPopcount sym + , Prims.bpBvCountLeadingZeros = SW.bvCountLeadingZeros sym + , Prims.bpBvCountTrailingZeros = SW.bvCountTrailingZeros sym + , Prims.bpBvForall = bvForall sym + -- Integer operations + , Prims.bpIntAbs = W.intAbs sym + , Prims.bpIntAdd = W.intAdd sym + , Prims.bpIntSub = W.intSub sym + , Prims.bpIntMul = W.intMul sym + , Prims.bpIntDiv = W.intDiv sym + , Prims.bpIntMod = W.intMod sym + , Prims.bpIntNeg = W.intNeg sym + , Prims.bpIntEq = W.intEq sym + , Prims.bpIntLe = W.intLe sym + , Prims.bpIntLt = W.intLt sym + , Prims.bpIntMin = intMin sym + , Prims.bpIntMax = intMax sym + -- Array operations + , Prims.bpArrayConstant = arrayConstant sym + , Prims.bpArrayLookup = arrayLookup sym + , Prims.bpArrayUpdate = arrayUpdate sym + , Prims.bpArrayEq = arrayEq sym + } + + +constMap :: forall sym. Sym sym => sym -> Map Ident (SValue sym) +constMap sym = + Map.union (Prims.constMap (prims sym)) $ + Map.fromList + [ + -- Shifts + ("Prelude.bvShl" , bvShLOp sym) + , ("Prelude.bvShr" , bvShROp sym) + , ("Prelude.bvSShr", bvSShROp sym) + -- Integers + , ("Prelude.intToNat", intToNatOp sym) + , ("Prelude.natToInt", natToIntOp sym) + , ("Prelude.intToBv" , intToBvOp sym) + , ("Prelude.bvToInt" , bvToIntOp sym) + , ("Prelude.sbvToInt", sbvToIntOp sym) + -- Integers mod n + , ("Prelude.toIntMod" , toIntModOp) + , ("Prelude.fromIntMod", fromIntModOp sym) + , ("Prelude.intModEq" , intModEqOp sym) + , ("Prelude.intModAdd" , intModBinOp sym W.intAdd) + , ("Prelude.intModSub" , intModBinOp sym W.intSub) + , ("Prelude.intModMul" , intModBinOp sym W.intMul) + , ("Prelude.intModNeg" , intModUnOp sym W.intNeg) + -- Streams + , ("Prelude.MkStream", mkStreamOp) + , ("Prelude.streamGet", streamGetOp sym) + -- Misc + , ("Prelude.expByNat", Prims.expByNatOp (prims sym)) + ] + +----------------------------------------------------------------------- +-- Implementation of constMap primitives + +swBvWidth :: SWord sym -> Int +swBvWidth x + | w <= toInteger (maxBound :: Int) = fromInteger w + | otherwise = panic "swBvWidth" ["bitvector too long", show w] + where w = SW.bvWidth x + +toBool :: SValue sym -> IO (SBool sym) +toBool (VBool b) = return b +toBool x = fail $ unwords ["Verifier.SAW.Simulator.What4.toBool", show x] + +toWord :: forall sym. + Sym sym => sym -> SValue sym -> IO (SWord sym) +toWord _ (VWord w) = return w +toWord sym (VVector vv) = do + -- vec :: Vector (SBool sym)) + vec1 <- T.traverse force vv + vec2 <- T.traverse toBool vec1 + SW.bvPackBE sym vec2 +toWord _ x = fail $ unwords ["Verifier.SAW.Simulator.What4.toWord", show x] + +wordFun :: + Sym sym => sym -> (SWord sym -> IO (SValue sym)) -> SValue sym +wordFun sym f = strictFun (\x -> f =<< toWord sym x) + +valueToSymExpr :: SValue sym -> Maybe (Some (W.SymExpr sym)) +valueToSymExpr = \case + VBool b -> Just $ Some b + VInt i -> Just $ Some i + VWord (DBV w) -> Just $ Some w + VArray (SArray a) -> Just $ Some a + _ -> Nothing + +symExprToValue :: + IsExpr (SymExpr sym) => + W.BaseTypeRepr tp -> + W.SymExpr sym tp -> + Maybe (SValue sym) +symExprToValue tp expr = case tp of + BaseBoolRepr -> Just $ VBool expr + BaseIntegerRepr -> Just $ VInt expr + (BaseBVRepr w) -> Just $ withKnownNat w $ VWord $ DBV expr + (BaseArrayRepr (Ctx.Empty Ctx.:> _) _) -> Just $ VArray $ SArray expr + _ -> Nothing + +-- +-- Integer bit/vector conversions +-- + +-- primitive intToNat : Integer -> Nat; +-- intToNat x == max 0 x +intToNatOp :: forall sym. Sym sym => sym -> SValue sym +intToNatOp sym = + Prims.intFun "intToNat" $ \i -> + case W.asInteger i of + Just i' + | 0 <= i' -> pure (VNat (fromInteger i')) + | otherwise -> pure (VNat 0) + Nothing -> + do z <- W.intLit sym 0 + pneg <- W.intLt sym i z + i' <- W.intIte sym pneg z i + pure (VToNat (VInt i')) + +-- primitive natToInt :: Nat -> Integer; +natToIntOp :: forall sym. Sym sym => sym -> SValue sym +natToIntOp sym = + Prims.natFun' "natToInt" $ \n -> + VInt <$> W.intLit sym (toInteger n) + +-- interpret bitvector as unsigned integer +-- primitive bvToInt : (n : Nat) -> Vec n Bool -> Integer; +bvToIntOp :: forall sym. Sym sym => sym -> SValue sym +bvToIntOp sym = constFun $ wordFun sym $ \v -> + VInt <$> SW.bvToInteger sym v + +-- interpret bitvector as signed integer +-- primitive sbvToInt : (n : Nat) -> Vec n Bool -> Integer; +sbvToIntOp :: forall sym. Sym sym => sym -> SValue sym +sbvToIntOp sym = constFun $ wordFun sym $ \v -> + VInt <$> SW.sbvToInteger sym v + +-- primitive intToBv : (n : Nat) -> Integer -> Vec n Bool; +intToBvOp :: forall sym. Sym sym => sym -> SValue sym +intToBvOp sym = + Prims.natFun' "intToBv n" $ \n -> return $ + Prims.intFun "intToBv x" $ \(x :: SymInteger sym) -> + VWord <$> SW.integerToBV sym x n + + +-- +-- Shifts +-- + +-- | Shift left, shifting in copies of the given bit +bvShl :: IsExprBuilder sym => sym -> Pred sym -> SWord sym -> SWord sym -> IO (SWord sym) +bvShl sym z w i = + W.iteM SW.bvIte sym z + (do w' <- SW.bvNot sym w + SW.bvNot sym =<< SW.bvShl sym w' i) + (SW.bvShl sym w i) + +-- | Shift right, shifting in copies of the given bit +bvShr :: IsExprBuilder sym => sym -> Pred sym -> SWord sym -> SWord sym -> IO (SWord sym) +bvShr sym z w i = + W.iteM SW.bvIte sym z + (do w' <- SW.bvNot sym w + SW.bvNot sym =<< SW.bvLshr sym w' i) + (SW.bvLshr sym w i) + +liftShift :: IsExprBuilder sym => + sym -> + (SWord sym -> SWord sym -> IO (SWord sym)) -> + SWord sym -> Integer -> IO (SWord sym) +liftShift sym f w i = + f w =<< SW.bvLit sym (SW.bvWidth w) (i `min` SW.bvWidth w) + +liftRotate :: IsExprBuilder sym => + sym -> + (SWord sym -> SWord sym -> IO (SWord sym)) -> + SWord sym -> Integer -> IO (SWord sym) +liftRotate sym f w i = + f w =<< SW.bvLit sym (SW.bvWidth w) (i `mod` SW.bvWidth w) + + +-- | op : (n : Nat) -> Vec n Bool -> Nat -> Vec n Bool +bvShiftOp :: Sym sym => sym -> + (SWord sym -> SWord sym -> IO (SWord sym)) -> + (SWord sym -> Integer -> IO (SWord sym)) -> SValue sym +bvShiftOp sym bvOp natOp = + constFun $ -- additional argument? the size? + wordFun sym $ \x -> -- word to shift + return $ + strictFun $ \y -> -- amount to shift as a nat + case y of + VNat i -> VWord <$> natOp x j + where j = toInteger i `min` SW.bvWidth x + VToNat v -> VWord <$> (bvOp x =<< toWord sym v) + _ -> error $ unwords ["Verifier.SAW.Simulator.What4.bvShiftOp", show y] + +-- bvShl : (w : Nat) -> Vec w Bool -> Nat -> Vec w Bool; +bvShLOp :: forall sym. Sym sym => sym -> SValue sym +bvShLOp sym = bvShiftOp sym (SW.bvShl sym) + (liftShift sym (SW.bvShl sym)) + +-- bvShR : (w : Nat) -> Vec w Bool -> Nat -> Vec w Bool; +bvShROp :: forall sym. Sym sym => sym -> SValue sym +bvShROp sym = bvShiftOp sym (SW.bvLshr sym) + (liftShift sym (SW.bvLshr sym)) + +-- bvSShR : (w : Nat) -> Vec w Bool -> Nat -> Vec w Bool; +bvSShROp :: forall sym. Sym sym => sym -> SValue sym +bvSShROp sym = bvShiftOp sym (SW.bvAshr sym) + (liftShift sym (SW.bvAshr sym)) + +bvForall :: W.IsSymExprBuilder sym => + sym -> Natural -> (SWord sym -> IO (Pred sym)) -> IO (Pred sym) +bvForall sym n f = + do let indexSymbol = W.safeSymbol "i" + case mkNatRepr n of + Some w + | Just LeqProof <- testLeq (knownNat @1) w -> + withKnownNat w $ do + i <- W.freshBoundVar sym indexSymbol $ W.BaseBVRepr w + body <- f . DBV $ W.varExpr sym i + W.forallPred sym i body + | otherwise -> f ZBV + +-- +-- missing integer operations +-- + +intMin :: (IsExprBuilder sym) => sym -> SInt sym -> SInt sym -> IO (SInt sym) +intMin sym i1 i2 = do + p <- W.intLt sym i1 i2 + W.intIte sym p i1 i2 + +intMax :: (IsExprBuilder sym) => sym -> SInt sym -> SInt sym -> IO (SInt sym) +intMax sym i1 i2 = do + p <- W.intLt sym i1 i2 + W.intIte sym p i2 i1 + +------------------------------------------------------------ +-- Integers mod n + +toIntModOp :: SValue sym +toIntModOp = + Prims.natFun' "toIntMod" $ \n -> pure $ + Prims.intFun "toIntMod" $ \x -> pure $ + VIntMod n x + +fromIntModOp :: IsExprBuilder sym => sym -> SValue sym +fromIntModOp sym = + Prims.natFun $ \n -> return $ + Prims.intModFun "fromIntModOp" $ \x -> + VInt <$> (W.intMod sym x =<< W.intLit sym (toInteger n)) + +intModEqOp :: IsExprBuilder sym => sym -> SValue sym +intModEqOp sym = + Prims.natFun $ \n -> return $ + Prims.intModFun "intModEqOp" $ \x -> return $ + Prims.intModFun "intModEqOp" $ \y -> + do modulus <- W.intLit sym (toInteger n) + d <- W.intSub sym x y + r <- W.intMod sym d modulus + z <- W.intLit sym 0 + VBool <$> W.intEq sym r z + +intModBinOp :: + IsExprBuilder sym => sym -> + (sym -> SInt sym -> SInt sym -> IO (SInt sym)) -> SValue sym +intModBinOp sym f = + Prims.natFun $ \n -> return $ + Prims.intModFun "intModBinOp x" $ \x -> return $ + Prims.intModFun "intModBinOp y" $ \y -> + VIntMod n <$> (normalizeIntMod sym n =<< f sym x y) + +intModUnOp :: + IsExprBuilder sym => sym -> + (sym -> SInt sym -> IO (SInt sym)) -> SValue sym +intModUnOp sym f = + Prims.natFun $ \n -> return $ + Prims.intModFun "intModUnOp" $ \x -> + VIntMod n <$> (normalizeIntMod sym n =<< f sym x) + +normalizeIntMod :: IsExprBuilder sym => sym -> Natural -> SInt sym -> IO (SInt sym) +normalizeIntMod sym n x = + case W.asInteger x of + Nothing -> return x + Just i -> W.intLit sym (i `mod` toInteger n) + +------------------------------------------------------------ +-- Stream operations + +-- MkStream :: (a :: sort 0) -> (Nat -> a) -> Stream a; +mkStreamOp :: SValue sym +mkStreamOp = + constFun $ + strictFun $ \f -> do + r <- newIORef Map.empty + return $ VExtra (SStream (\n -> apply f (ready (VNat n))) r) + +-- streamGet :: (a :: sort 0) -> Stream a -> Nat -> a; +streamGetOp :: forall sym. Sym sym => sym -> SValue sym +streamGetOp sym = + constFun $ + strictFun $ \xs -> return $ + strictFun $ \case + VNat n -> lookupSStream xs n + VToNat w -> + do ilv <- toWord sym w + selectV sym (lazyMux @sym (muxBVal sym)) ((2 ^ SW.bvWidth ilv) - 1) (lookupSStream xs) ilv + v -> Prims.panic "streamGetOp" ["Expected Nat value", show v] + +lookupSStream :: SValue sym -> Natural -> IO (SValue sym) +lookupSStream (VExtra (SStream f r)) n = do + m <- readIORef r + case Map.lookup n m of + Just v -> return v + Nothing -> do v <- f n + writeIORef r (Map.insert n v m) + return v +lookupSStream _ _ = fail "expected Stream" + + +muxBVal :: forall sym. Sym sym => + sym -> SBool sym -> SValue sym -> SValue sym -> IO (SValue sym) +muxBVal sym = Prims.muxValue (prims sym) + +muxWhat4Extra :: forall sym. Sym sym => + sym -> SBool sym -> What4Extra sym -> What4Extra sym -> IO (What4Extra sym) +muxWhat4Extra sym c x y = + do let f i = do xi <- lookupSStream (VExtra x) i + yi <- lookupSStream (VExtra y) i + muxBVal sym c xi yi + r <- newIORef Map.empty + return (SStream f r) + + +-- | Lifts a strict mux operation to a lazy mux +lazyMux :: (IsExpr (SymExpr sym)) => + (SBool sym -> a -> a -> IO a) -> (SBool sym -> IO a -> IO a -> IO a) +lazyMux muxFn c tm fm = + case W.asConstantPred c of + Just True -> tm + Just False -> fm + Nothing -> do + t <- tm + f <- fm + muxFn c t f + +-- selectV merger maxValue valueFn index returns valueFn v when index has value v +-- if index is greater than maxValue, it returns valueFn maxValue. Use the ite op from merger. +selectV :: forall sym b. + Sym sym => + sym -> + (SBool sym -> IO b -> IO b -> IO b) -> Natural -> (Natural -> IO b) -> SWord sym -> IO b +selectV sym merger maxValue valueFn vx = + case SW.bvAsUnsignedInteger vx of + Just i -> valueFn (fromInteger i :: Natural) + Nothing -> impl (swBvWidth vx) 0 + where + impl :: Int -> Natural -> IO b + impl _ x | x > maxValue || x < 0 = valueFn maxValue + impl 0 y = valueFn y + impl i y = do + p <- SW.bvAtBE sym vx (toInteger j) + merger p (impl j (y `setBit` j)) (impl j y) where j = i - 1 + +instance Show (SArray sym) where + show (SArray arr) = show $ W.printSymExpr arr + +arrayConstant :: + W.IsSymExprBuilder sym => + sym -> + TValue (What4 sym) -> + SValue sym -> + IO (SArray sym) +arrayConstant sym ity elm + | Just (Some idx_repr) <- valueAsBaseType ity + , Just (Some elm_expr) <- valueToSymExpr elm = + SArray <$> W.constantArray sym (Ctx.Empty Ctx.:> idx_repr) elm_expr + | otherwise = + panic "Verifier.SAW.Simulator.What4.Panic.arrayConstant" ["argument type mismatch"] + +arrayLookup :: + W.IsSymExprBuilder sym => + sym -> + SArray sym -> + SValue sym -> + IO (SValue sym) +arrayLookup sym arr idx + | SArray arr_expr <- arr + , Just (Some idx_expr) <- valueToSymExpr idx + , W.BaseArrayRepr (Ctx.Empty Ctx.:> idx_repr) elm_repr <- W.exprType arr_expr + , Just Refl <- testEquality idx_repr (W.exprType idx_expr) = do + elm_expr <- W.arrayLookup sym arr_expr (Ctx.Empty Ctx.:> idx_expr) + maybe + (panic "Verifier.SAW.Simulator.What4.Panic.arrayLookup" ["argument type mismatch"]) + return + (symExprToValue elm_repr elm_expr) + | otherwise = + panic "Verifier.SAW.Simulator.What4.Panic.arrayLookup" ["argument type mismatch"] + +arrayUpdate :: + W.IsSymExprBuilder sym => + sym -> + SArray sym -> + SValue sym -> + SValue sym -> + IO (SArray sym) +arrayUpdate sym arr idx elm + | SArray arr_expr <- arr + , Just (Some idx_expr) <- valueToSymExpr idx + , Just (Some elm_expr) <- valueToSymExpr elm + , W.BaseArrayRepr (Ctx.Empty Ctx.:> idx_repr) elm_repr <- W.exprType arr_expr + , Just Refl <- testEquality idx_repr (W.exprType idx_expr) + , Just Refl <- testEquality elm_repr (W.exprType elm_expr) = + SArray <$> W.arrayUpdate sym arr_expr (Ctx.Empty Ctx.:> idx_expr) elm_expr + | otherwise = + panic "Verifier.SAW.Simulator.What4.Panic.arrayUpdate" ["argument type mismatch"] + +arrayEq :: + W.IsSymExprBuilder sym => + sym -> + SArray sym -> + SArray sym -> + IO (W.Pred sym) +arrayEq sym lhs_arr rhs_arr + | SArray lhs_arr_expr <- lhs_arr + , SArray rhs_arr_expr <- rhs_arr + , W.BaseArrayRepr (Ctx.Empty Ctx.:> lhs_idx_repr) lhs_elm_repr <- W.exprType lhs_arr_expr + , W.BaseArrayRepr (Ctx.Empty Ctx.:> rhs_idx_repr) rhs_elm_repr <- W.exprType rhs_arr_expr + , Just Refl <- testEquality lhs_idx_repr rhs_idx_repr + , Just Refl <- testEquality lhs_elm_repr rhs_elm_repr = + W.arrayEq sym lhs_arr_expr rhs_arr_expr + | otherwise = + panic "Verifier.SAW.Simulator.What4.Panic.arrayEq" ["argument type mismatch"] + +---------------------------------------------------------------------- +-- | A basic symbolic simulator/evaluator: interprets a saw-core Term as +-- a symbolic value + +w4SolveBasic :: + forall sym. IsSymExprBuilder sym => + sym -> + SharedContext -> + Map Ident (SValue sym) {- ^ additional primitives -} -> + Map VarIndex (SValue sym) {- ^ bindings for ExtCns values -} -> + IORef (SymFnCache sym) {- ^ cache for uninterpreted function symbols -} -> + Set VarIndex {- ^ 'unints' Constants in this list are kept uninterpreted -} -> + Term {- ^ term to simulate -} -> + IO (SValue sym) +w4SolveBasic sym sc addlPrims ecMap ref unintSet t = + do m <- scGetModuleMap sc + let extcns (EC ix nm ty) + | Just v <- Map.lookup ix ecMap = return v + | otherwise = parseUninterpreted sym ref (mkUnintApp (Text.unpack (toShortName nm) ++ "_" ++ show ix)) ty + let uninterpreted ec + | Set.member (ecVarIndex ec) unintSet = Just (extcns ec) + | otherwise = Nothing + cfg <- Sim.evalGlobal m (constMap sym `Map.union` addlPrims) extcns uninterpreted + Sim.evalSharedTerm cfg t + + +---------------------------------------------------------------------- +-- Uninterpreted function cache + +data SymFnWrapper sym :: Ctx.Ctx BaseType -> * where + SymFnWrapper :: !(W.SymFn sym args ret) -> SymFnWrapper sym (args Ctx.::> ret) + +type SymFnCache sym = Map W.SolverSymbol (MapF (Assignment BaseTypeRepr) (SymFnWrapper sym)) + +lookupSymFn :: + W.SolverSymbol -> Assignment BaseTypeRepr args -> BaseTypeRepr ty -> + SymFnCache sym -> Maybe (W.SymFn sym args ty) +lookupSymFn s args ty cache = + do m <- Map.lookup s cache + SymFnWrapper fn <- MapF.lookup (Ctx.extend args ty) m + return fn + +insertSymFn :: + W.SolverSymbol -> Assignment BaseTypeRepr args -> BaseTypeRepr ty -> + W.SymFn sym args ty -> SymFnCache sym -> SymFnCache sym +insertSymFn s args ty fn = Map.alter upd s + where + upd Nothing = Just (MapF.singleton (Ctx.extend args ty) (SymFnWrapper fn)) + upd (Just m) = Just (MapF.insert (Ctx.extend args ty) (SymFnWrapper fn) m) + +mkSymFn :: + forall sym args ret. (IsSymExprBuilder sym) => + sym -> IORef (SymFnCache sym) -> + String -> Assignment BaseTypeRepr args -> BaseTypeRepr ret -> + IO (W.SymFn sym args ret) +mkSymFn sym ref nm args ret = + do let s = W.safeSymbol nm + cache <- readIORef ref + case lookupSymFn s args ret cache of + Just fn -> return fn + Nothing -> + do fn <- W.freshTotalUninterpFn sym s args ret + writeIORef ref (insertSymFn s args ret fn cache) + return fn + +---------------------------------------------------------------------- +-- Given a constant nm of (saw-core) type ty, construct an uninterpreted +-- constant with that type. +-- Importantly: The types of these uninterpreted values are *not* +-- limited to What4 BaseTypes or FirstOrderTypes. + +parseUninterpreted :: + forall sym. + (IsSymExprBuilder sym) => + sym -> IORef (SymFnCache sym) -> + UnintApp (SymExpr sym) -> + TValue (What4 sym) -> IO (SValue sym) +parseUninterpreted sym ref app ty = + case ty of + VPiType _ f + -> return $ + strictFun $ \x -> do + app' <- applyUnintApp sym app x + t2 <- f (ready x) + parseUninterpreted sym ref app' t2 + + VBoolType + -> VBool <$> mkUninterpreted sym ref app BaseBoolRepr + + VIntType + -> VInt <$> mkUninterpreted sym ref app BaseIntegerRepr + + VIntModType n + -> VIntMod n <$> mkUninterpreted sym ref app BaseIntegerRepr + + -- 0 width bitvector is a constant + VVecType 0 VBoolType + -> return $ VWord ZBV + + VVecType n VBoolType + | Just (Some (PosNat w)) <- somePosNat n + -> (VWord . DBV) <$> mkUninterpreted sym ref app (BaseBVRepr w) + + VVecType n ety + -> do xs <- sequence $ + [ parseUninterpreted sym ref (suffixUnintApp ("_a" ++ show i) app) ety + | i <- [0 .. n-1] ] + return (VVector (V.fromList (map ready xs))) + + VArrayType ity ety + | Just (Some idx_repr) <- valueAsBaseType ity + , Just (Some elm_repr) <- valueAsBaseType ety + -> (VArray . SArray) <$> + mkUninterpreted sym ref app (BaseArrayRepr (Ctx.Empty Ctx.:> idx_repr) elm_repr) + + VUnitType + -> return VUnit + + VPairType ty1 ty2 + -> do x1 <- parseUninterpreted sym ref (suffixUnintApp "_L" app) ty1 + x2 <- parseUninterpreted sym ref (suffixUnintApp "_R" app) ty2 + return (VPair (ready x1) (ready x2)) + + VRecordType elem_tps + -> (VRecordValue <$> + mapM (\(f,tp) -> + (f,) <$> ready <$> + parseUninterpreted sym ref (suffixUnintApp ("_" ++ Text.unpack f) app) tp) elem_tps) + + _ -> fail $ "could not create uninterpreted symbol of type " ++ show ty + + +mkUninterpreted :: + forall sym t. (IsSymExprBuilder sym) => + sym -> IORef (SymFnCache sym) -> + UnintApp (SymExpr sym) -> + BaseTypeRepr t -> + IO (SymExpr sym t) +mkUninterpreted sym ref (UnintApp nm args tys) ret = + do fn <- mkSymFn sym ref nm tys ret + W.applySymFn sym fn args + +-- | A value of type @UnintApp f@ represents an uninterpreted function +-- with the given 'String' name, applied to a list of argument values +-- paired with a representation of their types. The context of +-- argument types is existentially quantified. +data UnintApp f = + forall args. UnintApp String (Assignment f args) (Assignment BaseTypeRepr args) + +-- | Extract the string from an 'UnintApp'. +stringOfUnintApp :: UnintApp f -> String +stringOfUnintApp (UnintApp s _ _) = s + +-- | Make an 'UnintApp' with the given name and no arguments. +mkUnintApp :: String -> UnintApp f +mkUnintApp nm = UnintApp nm Ctx.empty Ctx.empty + +-- | Add a suffix to the function name of an 'UnintApp'. +suffixUnintApp :: String -> UnintApp f -> UnintApp f +suffixUnintApp s (UnintApp nm args tys) = UnintApp (nm ++ s) args tys + +-- | Extend an 'UnintApp' with an additional argument. +extendUnintApp :: UnintApp f -> f ty -> BaseTypeRepr ty -> UnintApp f +extendUnintApp (UnintApp nm xs tys) x ty = + UnintApp nm (Ctx.extend xs x) (Ctx.extend tys ty) + +-- | Flatten an 'SValue' to a sequence of components, each of which is +-- a symbolic value of a base type (e.g. word or boolean), and add +-- them to the list of arguments of the given 'UnintApp'. If the +-- 'SValue' contains any values built from data constructors, then +-- encode them as suffixes on the function name of the 'UnintApp'. +applyUnintApp :: + forall sym. + (W.IsExprBuilder sym) => + sym -> + UnintApp (SymExpr sym) -> + SValue sym -> + IO (UnintApp (SymExpr sym)) +applyUnintApp sym app0 v = + case v of + VUnit -> return app0 + VPair x y -> do app1 <- applyUnintApp sym app0 =<< force x + app2 <- applyUnintApp sym app1 =<< force y + return app2 + VRecordValue elems -> foldM (applyUnintApp sym) app0 =<< traverse (force . snd) elems + VVector xv -> foldM (applyUnintApp sym) app0 =<< traverse force xv + VBool sb -> return (extendUnintApp app0 sb BaseBoolRepr) + VInt si -> return (extendUnintApp app0 si BaseIntegerRepr) + VIntMod 0 si -> return (extendUnintApp app0 si BaseIntegerRepr) + VIntMod n si -> do n' <- W.intLit sym (toInteger n) + si' <- W.intMod sym si n' + return (extendUnintApp app0 si' BaseIntegerRepr) + VWord (DBV sw) -> return (extendUnintApp app0 sw (W.exprType sw)) + VArray (SArray sa) -> return (extendUnintApp app0 sa (W.exprType sa)) + VWord ZBV -> return app0 + VCtorApp i xv -> foldM (applyUnintApp sym) app' =<< traverse force xv + where app' = suffixUnintApp ("_" ++ identName i) app0 + VNat n -> return (suffixUnintApp ("_" ++ show n) app0) + TValue (suffixTValue -> Just s) + -> return (suffixUnintApp s app0) + VFun _ -> + fail $ + "Cannot create uninterpreted higher-order function " ++ + show (stringOfUnintApp app0) + _ -> + fail $ + "Cannot create uninterpreted function " ++ + show (stringOfUnintApp app0) ++ + " with argument " ++ show v + + +------------------------------------------------------------ + +w4Solve :: forall sym. + IsSymExprBuilder sym => + sym -> + SharedContext -> + SATQuery -> + IO ([ExtCns Term], [FirstOrderType], [Labeler sym], SBool sym) +w4Solve sym sc satq = + do t <- satQueryAsTerm sc satq + let varList = Map.toList (satVariables satq) + let argNames = map fst varList + let argTys = map snd varList + vars <- evalStateT (traverse (traverse (newVarFOT sym)) varList) 0 + let lbls = map (fst . snd) vars + let varMap = Map.fromList [ (ecVarIndex ec, v) | (ec, (_,v)) <- vars ] + ref <- newIORef Map.empty + bval <- w4SolveBasic sym sc mempty varMap ref (satUninterp satq) t + case bval of + VBool v -> return (argNames, argTys, lbls, v) + _ -> fail $ "w4Solve: non-boolean result type. " ++ show bval + +-- +-- Pull out argument types until bottoming out at a non-Pi type +-- +argTypes :: IsSymExprBuilder sym => TValue (What4 sym) -> IO [TValue (What4 sym)] +argTypes v = + case v of + VPiType v1 f -> + do x <- delay (fail "argTypes: unsupported dependent SAW-Core type") + v2 <- f x + vs <- argTypes v2 + return (v1 : vs) + _ -> return [] + +-- +-- Convert a saw-core type expression to a FirstOrder type expression +-- +vAsFirstOrderType :: forall sym. IsSymExprBuilder sym => TValue (What4 sym) -> Maybe FirstOrderType +vAsFirstOrderType v = + case v of + VBoolType + -> return FOTBit + VIntType + -> return FOTInt + VIntModType n + -> return (FOTIntMod n) + VVecType n v2 + -> FOTVec n <$> vAsFirstOrderType v2 + VArrayType iv ev + -> FOTArray <$> vAsFirstOrderType iv <*> vAsFirstOrderType ev + VUnitType + -> return (FOTTuple []) + VPairType v1 v2 + -> do t1 <- vAsFirstOrderType v1 + t2 <- vAsFirstOrderType v2 + case t2 of + FOTTuple ts -> return (FOTTuple (t1 : ts)) + _ -> return (FOTTuple [t1, t2]) + VRecordType tps + -> (FOTRec <$> Map.fromList <$> + mapM (\(f,tp) -> (f,) <$> vAsFirstOrderType tp) tps) + _ -> Nothing + +valueAsBaseType :: IsSymExprBuilder sym => TValue (What4 sym) -> Maybe (Some W.BaseTypeRepr) +valueAsBaseType v = fotToBaseType =<< vAsFirstOrderType v + +------------------------------------------------------------------------------ + +-- | Generate a new symbolic value (a variable) from a given first-order-type + + +data TypedExpr sym where + TypedExpr :: BaseTypeRepr ty -> SymExpr sym ty -> TypedExpr sym + + +-- | Create a fresh constant with the given name and type. +mkConstant :: + forall sym ty. + (IsSymExprBuilder sym) => + sym -> String -> BaseTypeRepr ty -> IO (SymExpr sym ty) +mkConstant sym name ty = W.freshConstant sym (W.safeSymbol name) ty + +-- | Generate a new variable from a given BaseType + +freshVar :: forall sym ty. IsSymExprBuilder sym => + sym -> BaseTypeRepr ty -> String -> IO (TypedExpr sym) +freshVar sym ty str = + do c <- mkConstant sym str ty + return (TypedExpr ty c) + +nextId :: StateT Int IO String +nextId = ST.get >>= (\s-> modify (+1) >> return ("x" ++ show s)) + + +newVarsForType :: forall sym. IsSymExprBuilder sym => + sym -> + IORef (SymFnCache sym) -> + TValue (What4 sym) -> String -> StateT Int IO (Maybe (Labeler sym), SValue sym) +newVarsForType sym ref v nm = + case vAsFirstOrderType v of + Just fot -> do + do (te,sv) <- newVarFOT sym fot + return (Just te, sv) + + Nothing -> + do sv <- lift $ parseUninterpreted sym ref (mkUnintApp nm) v + return (Nothing, sv) + +myfun ::(Map FieldName (Labeler sym, SValue sym)) -> (Map FieldName (Labeler sym), Map FieldName (SValue sym)) +myfun = fmap fst A.&&& fmap snd + +data Labeler sym + = BaseLabel (TypedExpr sym) + | ZeroWidthBVLabel + | IntModLabel Natural (SymInteger sym) + | VecLabel (Vector (Labeler sym)) + | TupleLabel (Vector (Labeler sym)) + | RecLabel (Map FieldName (Labeler sym)) + + +newVarFOT :: forall sym. IsSymExprBuilder sym => + sym -> FirstOrderType -> StateT Int IO (Labeler sym, SValue sym) + +newVarFOT sym (FOTTuple ts) = do + (labels,vals) <- V.unzip <$> traverse (newVarFOT sym) (V.fromList ts) + args <- traverse (return . ready) (V.toList vals) + return (TupleLabel labels, vTuple args) + +newVarFOT _sym (FOTVec 0 FOTBit) + = return (ZeroWidthBVLabel, VWord ZBV) + +newVarFOT sym (FOTVec n tp) + | tp /= FOTBit + = do (labels,vals) <- V.unzip <$> V.replicateM (fromIntegral n) (newVarFOT sym tp) + args <- traverse @Vector @(StateT Int IO) (return . ready) vals + return (VecLabel labels, VVector args) + +newVarFOT sym (FOTRec tm) + = do (labels, vals) <- myfun <$> traverse (newVarFOT sym) tm + args <- traverse (return . ready) (vals :: (Map FieldName (SValue sym))) + return (RecLabel labels, vRecord args) + +newVarFOT sym (FOTIntMod n) + = do nm <- nextId + let r = BaseIntegerRepr + si <- lift $ mkConstant sym nm r + return (IntModLabel n si, VIntMod n si) + +newVarFOT sym fot + | Just (Some r) <- fotToBaseType fot + = do nm <- nextId + te <- lift $ freshVar sym r nm + sv <- lift $ typedToSValue te + return (BaseLabel te, sv) + | otherwise + = fail ("Cannot create What4 variable of type: " ++ show fot) + + +typedToSValue :: (IsExpr (SymExpr sym)) => TypedExpr sym -> IO (SValue sym) +typedToSValue (TypedExpr ty expr) = + maybe (fail ("Cannot handle " ++ show ty)) return $ symExprToValue ty expr + +getLabelValues :: + forall sym t. + (SymExpr sym ~ B.Expr t) => + GroundEvalFn t -> Labeler sym -> IO FirstOrderValue +getLabelValues f = + \case + TupleLabel labels -> + FOVTuple <$> traverse (getLabelValues f) (V.toList labels) + VecLabel labels -> + FOVVec vty <$> traverse (getLabelValues f) (V.toList labels) + where vty = error "TODO: compute vector type, or just store it" + RecLabel labels -> + FOVRec <$> traverse (getLabelValues f) labels + IntModLabel n x -> + FOVIntMod n <$> groundEval f x + ZeroWidthBVLabel -> pure $ FOVWord 0 0 + BaseLabel (TypedExpr ty bv) -> + do gv <- groundEval f bv + case (groundToFOV ty gv) of + Left err -> fail err + Right fov -> pure fov + +---------------------------------------------------------------------- +-- Evaluation through crucible-saw backend + + +-- | Simplify a saw-core term by evaluating it through the saw backend +-- of what4. +w4EvalAny :: + forall n st fs. + B.ExprBuilder n st fs -> + SAWCoreState n -> + SharedContext -> + Map Ident (SValue (B.ExprBuilder n st fs)) -> Set VarIndex -> Term -> + IO ([String], ([Maybe (Labeler (B.ExprBuilder n st fs))], SValue (B.ExprBuilder n st fs))) +w4EvalAny sym st sc ps unintSet t = + do modmap <- scGetModuleMap sc + ref <- newIORef Map.empty + let eval = w4EvalBasic sym st sc modmap ps ref unintSet + ty <- eval =<< scTypeOf sc t + + -- get the names of the arguments to the function + let lamNames = map (Text.unpack . fst) (fst (R.asLambdaList t)) + let varNames = [ "var" ++ show (i :: Integer) | i <- [0 ..] ] + let argNames = zipWith (++) varNames (map ("_" ++) lamNames ++ repeat "") + + -- and their types + argTs <- argTypes (toTValue ty) + + -- construct symbolic expressions for the variables + vars' <- + flip evalStateT 0 $ + sequence (zipWith (newVarsForType sym ref) argTs argNames) + + -- symbolically evaluate + bval <- eval t + + -- apply and existentially quantify + let (bvs, vars) = unzip vars' + let vars'' = fmap ready vars + bval' <- applyAll bval vars'' + + return (argNames, (bvs, bval')) + +w4Eval :: + forall n st fs. + B.ExprBuilder n st fs -> + SAWCoreState n -> + SharedContext -> + Map Ident (SValue (B.ExprBuilder n st fs)) -> Set VarIndex -> Term -> + IO ([String], ([Maybe (Labeler (B.ExprBuilder n st fs))], SBool (B.ExprBuilder n st fs))) +w4Eval sym st sc ps uintSet t = + do (argNames, (bvs, bval)) <- w4EvalAny sym st sc ps uintSet t + case bval of + VBool b -> return (argNames, (bvs, b)) + _ -> fail $ "w4Eval: non-boolean result type. " ++ show bval + +-- | Simplify a saw-core term by evaluating it through the saw backend +-- of what4. +w4EvalBasic :: + forall n st fs. + B.ExprBuilder n st fs -> + SAWCoreState n -> + SharedContext -> + ModuleMap -> + Map Ident (SValue (B.ExprBuilder n st fs)) {- ^ additional primitives -} -> + IORef (SymFnCache (B.ExprBuilder n st fs)) {- ^ cache for uninterpreted function symbols -} -> + Set VarIndex {- ^ 'unints' Constants in this list are kept uninterpreted -} -> + Term {- ^ term to simulate -} -> + IO (SValue (B.ExprBuilder n st fs)) +w4EvalBasic sym st sc m addlPrims ref unintSet t = + do let extcns tf (EC ix nm ty) = + do trm <- ArgTermConst <$> scTermF sc tf + parseUninterpretedSAW sym st sc ref trm + (mkUnintApp (Text.unpack (toShortName nm) ++ "_" ++ show ix)) ty + let uninterpreted tf ec + | Set.member (ecVarIndex ec) unintSet = Just (extcns tf ec) + | otherwise = Nothing + cfg <- Sim.evalGlobal' m (constMap sym `Map.union` addlPrims) extcns uninterpreted + Sim.evalSharedTerm cfg t + + +-- | Evaluate a saw-core term to a What4 value for the purposes of +-- using it as an input for symbolic simulation. This will evaluate +-- primitives, but will cancel evaluation and return the associated +-- 'NameInfo' if it encounters a constant value with an 'ExtCns' +-- that is not accepted by the filter. +w4SimulatorEval :: + forall n st fs. + B.ExprBuilder n st fs -> + SAWCoreState n -> + SharedContext -> + ModuleMap -> + Map Ident (SValue (B.ExprBuilder n st fs)) {- ^ additional primitives -} -> + IORef (SymFnCache (B.ExprBuilder n st fs)) {- ^ cache for uninterpreted function symbols -} -> + (ExtCns (TValue (What4 (B.ExprBuilder n st fs))) -> Bool) + {- ^ Filter for constant values. True means unfold, false means halt evaluation. -} -> + Term {- ^ term to simulate -} -> + IO (Either NameInfo (SValue (B.ExprBuilder n st fs))) +w4SimulatorEval sym st sc m addlPrims ref constantFilter t = + do let extcns tf (EC ix nm ty) = + do trm <- ArgTermConst <$> scTermF sc tf + parseUninterpretedSAW sym st sc ref trm (mkUnintApp (Text.unpack (toShortName nm) ++ "_" ++ show ix)) ty + let uninterpreted _tf ec = + if constantFilter ec then Nothing else Just (X.throwIO (NeutralTermEx (ecName ec))) + res <- X.try $ do + cfg <- Sim.evalGlobal' m (constMap sym `Map.union` addlPrims) extcns uninterpreted + Sim.evalSharedTerm cfg t + case res of + Left (NeutralTermEx nmi) -> pure (Left nmi) + Right x -> pure (Right x) + +data NeutralTermException = NeutralTermEx NameInfo deriving Show +instance X.Exception NeutralTermException + +-- | Given a constant nm of (saw-core) type ty, construct an +-- uninterpreted constant with that type. The 'Term' argument should +-- be an open term, which should have the designated return type when +-- the local variables have the corresponding types from the +-- 'Assignment'. +parseUninterpretedSAW :: + forall n st fs. + B.ExprBuilder n st fs -> + SAWCoreState n -> + SharedContext -> + IORef (SymFnCache (B.ExprBuilder n st fs)) -> + ArgTerm {- ^ representation of function applied to arguments -} -> + UnintApp (SymExpr (B.ExprBuilder n st fs)) -> + TValue (What4 (B.ExprBuilder n st fs)) {- ^ return type -} -> + IO (SValue (B.ExprBuilder n st fs)) +parseUninterpretedSAW sym st sc ref trm app ty = + case ty of + VPiType t1 f + -> return $ + strictFun $ \x -> do + app' <- applyUnintApp sym app x + arg <- mkArgTerm sc t1 x + let trm' = ArgTermApply trm arg + t2 <- f (ready x) + parseUninterpretedSAW sym st sc ref trm' app' t2 + + VBoolType + -> VBool <$> mkUninterpretedSAW sym st ref trm app BaseBoolRepr + + VIntType + -> VInt <$> mkUninterpretedSAW sym st ref trm app BaseIntegerRepr + + -- 0 width bitvector is a constant + VVecType 0 VBoolType + -> return $ VWord ZBV + + VVecType n VBoolType + | Just (Some (PosNat w)) <- somePosNat n + -> (VWord . DBV) <$> mkUninterpretedSAW sym st ref trm app (BaseBVRepr w) + + VVecType n ety | n >= 0 + -> do ety' <- termOfTValue sc ety + let mkElem i = + do let trm' = ArgTermAt n ety' trm i + let app' = suffixUnintApp ("_a" ++ show i) app + parseUninterpretedSAW sym st sc ref trm' app' ety + xs <- traverse mkElem (genericTake n [0 ..]) + return (VVector (V.fromList (map ready xs))) + + VArrayType ity ety + | Just (Some idx_repr) <- valueAsBaseType ity + , Just (Some elm_repr) <- valueAsBaseType ety + -> (VArray . SArray) <$> + mkUninterpretedSAW sym st ref trm app (BaseArrayRepr (Ctx.Empty Ctx.:> idx_repr) elm_repr) + + VUnitType + -> return VUnit + + VPairType ty1 ty2 + -> do let trm1 = ArgTermPairLeft trm + let trm2 = ArgTermPairRight trm + x1 <- parseUninterpretedSAW sym st sc ref trm1 (suffixUnintApp "_L" app) ty1 + x2 <- parseUninterpretedSAW sym st sc ref trm2 (suffixUnintApp "_R" app) ty2 + return (VPair (ready x1) (ready x2)) + + _ -> fail $ "could not create uninterpreted symbol of type " ++ show ty + +mkUninterpretedSAW :: + forall n st fs t. + B.ExprBuilder n st fs -> + SAWCoreState n -> + IORef (SymFnCache (B.ExprBuilder n st fs)) -> + ArgTerm -> + UnintApp (SymExpr (B.ExprBuilder n st fs)) -> + BaseTypeRepr t -> + IO (SymExpr (B.ExprBuilder n st fs) t) +mkUninterpretedSAW sym st ref trm (UnintApp nm args tys) ret = + do fn <- mkSymFn sym ref nm tys ret + sawRegisterSymFunInterp st fn (reconstructArgTerm trm) + W.applySymFn sym fn args + +-- | An 'ArgTerm' is a description of how to reassemble a saw-core +-- term from a list of the atomic components it is composed of. +data ArgTerm + = ArgTermVar + | ArgTermBVZero -- ^ scBvNat 0 0 + | ArgTermVector Term [ArgTerm] -- ^ element type, elements + | ArgTermUnit + | ArgTermPair ArgTerm ArgTerm + | ArgTermRecord [(FieldName, ArgTerm)] + | ArgTermConst Term + | ArgTermApply ArgTerm ArgTerm + | ArgTermAt Natural Term ArgTerm Natural + -- ^ length, element type, list, index + | ArgTermPairLeft ArgTerm + | ArgTermPairRight ArgTerm + +-- | Reassemble a saw-core term from an 'ArgTerm' and a list of parts. +-- The length of the list should be equal to the number of +-- 'ArgTermVar' constructors in the 'ArgTerm'. +reconstructArgTerm :: ArgTerm -> SharedContext -> [Term] -> IO Term +reconstructArgTerm atrm sc ts = + do (t, unused) <- parse atrm ts + unless (null unused) $ fail "reconstructArgTerm: too many function arguments" + return t + where + parse :: ArgTerm -> [Term] -> IO (Term, [Term]) + parse at ts0 = + case at of + ArgTermVar -> + case ts0 of + x : ts1 -> return (x, ts1) + [] -> fail "reconstructArgTerm: too few function arguments" + ArgTermBVZero -> + do z <- scNat sc 0 + x <- scBvNat sc z z + return (x, ts0) + ArgTermVector ty ats -> + do (xs, ts1) <- parseList ats ts0 + x <- scVector sc ty xs + return (x, ts1) + ArgTermUnit -> + do x <- scUnitValue sc + return (x, ts0) + ArgTermPair at1 at2 -> + do (x1, ts1) <- parse at1 ts0 + (x2, ts2) <- parse at2 ts1 + x <- scPairValue sc x1 x2 + return (x, ts2) + ArgTermRecord flds -> + do let (tags, ats) = unzip flds + (xs, ts1) <- parseList ats ts0 + x <- scRecord sc (Map.fromList (zip tags xs)) + return (x, ts1) + ArgTermConst x -> + do return (x, ts0) + ArgTermApply at1 at2 -> + do (x1, ts1) <- parse at1 ts0 + (x2, ts2) <- parse at2 ts1 + x <- scApply sc x1 x2 + return (x, ts2) + ArgTermAt n ty at1 i -> + do n' <- scNat sc n + (x1, ts1) <- parse at1 ts0 + i' <- scNat sc i + x <- scAt sc n' ty x1 i' + return (x, ts1) + ArgTermPairLeft at1 -> + do (x1, ts1) <- parse at1 ts0 + x <- scPairLeft sc x1 + return (x, ts1) + ArgTermPairRight at1 -> + do (x1, ts1) <- parse at1 ts0 + x <- scPairRight sc x1 + return (x, ts1) + + parseList :: [ArgTerm] -> [Term] -> IO ([Term], [Term]) + parseList [] ts0 = return ([], ts0) + parseList (at : ats) ts0 = + do (x, ts1) <- parse at ts0 + (xs, ts2) <- parseList ats ts1 + return (x : xs, ts2) + +-- | Given a type and value encoded as 'SValue's, construct an +-- 'ArgTerm' that builds a term of that type from local variables with +-- base types. The number of 'ArgTermVar' constructors should match +-- the number of arguments appended by 'applyUnintApp'. +mkArgTerm :: SharedContext -> TValue (What4 sym) -> SValue sym -> IO ArgTerm +mkArgTerm sc ty val = + case (ty, val) of + (VBoolType, VBool _) -> return ArgTermVar + (VIntType, VInt _) -> return ArgTermVar + (_, VWord ZBV) -> return ArgTermBVZero -- 0-width bitvector is a constant + (_, VWord (DBV _)) -> return ArgTermVar + (VUnitType, VUnit) -> return ArgTermUnit + + (VVecType _ ety, VVector vv) -> + do vs <- traverse force (V.toList vv) + xs <- traverse (mkArgTerm sc ety) vs + ety' <- termOfTValue sc ety + return (ArgTermVector ety' xs) + + (VPairType ty1 ty2, VPair v1 v2) -> + do x1 <- mkArgTerm sc ty1 =<< force v1 + x2 <- mkArgTerm sc ty2 =<< force v2 + return (ArgTermPair x1 x2) + + (VRecordType tys, VRecordValue flds) | map fst tys == map fst flds -> + do let tags = map fst tys + vs <- traverse (force . snd) flds + xs <- sequence [ mkArgTerm sc t v | (t, v) <- zip (map snd tys) vs ] + return (ArgTermRecord (zip tags xs)) + + (_, VCtorApp i vv) -> + do xs <- traverse (termOfSValue sc <=< force) (V.toList vv) + x <- scCtorApp sc i xs + return (ArgTermConst x) + + _ -> fail $ "could not create uninterpreted function argument of type " ++ show ty + +termOfTValue :: SharedContext -> TValue (What4 sym) -> IO Term +termOfTValue sc val = + case val of + VBoolType -> scBoolType sc + VIntType -> scIntegerType sc + VUnitType -> scUnitType sc + VVecType n a -> + do n' <- scNat sc n + a' <- termOfTValue sc a + scVecType sc n' a' + VPairType a b + -> do a' <- termOfTValue sc a + b' <- termOfTValue sc b + scPairType sc a' b' + VRecordType flds + -> do flds' <- traverse (traverse (termOfTValue sc)) flds + scRecordType sc flds' + _ -> fail $ "termOfTValue: " ++ show val + +termOfSValue :: SharedContext -> SValue sym -> IO Term +termOfSValue sc val = + case val of + VUnit -> scUnitValue sc + VNat n + -> scNat sc n + TValue tv -> termOfTValue sc tv + _ -> fail $ "termOfSValue: " ++ show val diff --git a/saw-core-what4/src/Verifier/SAW/Simulator/What4/FirstOrder.hs b/saw-core-what4/src/Verifier/SAW/Simulator/What4/FirstOrder.hs new file mode 100644 index 0000000000..bd010bba89 --- /dev/null +++ b/saw-core-what4/src/Verifier/SAW/Simulator/What4/FirstOrder.hs @@ -0,0 +1,129 @@ +------------------------------------------------------------------------ +-- | +-- Module : Verifier.SAW.Simulator.What4.FirstOrder +-- Copyright : Galois, Inc. 2012-2015 +-- License : BSD3 +-- Maintainer : sweirich@galois.com +-- Stability : experimental +-- Portability : non-portable (language extensions) +-- +-- Connect What4's 'BaseType' with saw-core's 'FirstOrderType' +-- (both types and values of Base/FirstOrder type) +-- TODO NOTE: support for tuples, arrays and records is not complete +-- but is also unused in Verifier.SAW.Simulator.What4 +------------------------------------------------------------------------ +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE ViewPatterns #-} + +module Verifier.SAW.Simulator.What4.FirstOrder + ( + fotToBaseType, + typeReprToFOT, + groundToFOV + ) where + +import qualified Data.BitVector.Sized as BV +import Data.Parameterized.TraversableFC (FoldableFC(..)) +import Data.Parameterized.Some(Some(..)) +import Data.Parameterized.Context hiding (replicate) + +import Verifier.SAW.Simulator.What4.PosNat + +import Verifier.SAW.FiniteValue (FirstOrderType(..),FirstOrderValue(..)) + +import What4.BaseTypes +import What4.Expr.GroundEval + +--------------------------------------------------------------------- + +-- | Convert a type expression from SAW-core to What4 +fotToBaseType :: FirstOrderType -> Maybe (Some BaseTypeRepr) +fotToBaseType FOTBit + = Just (Some BaseBoolRepr) +fotToBaseType FOTInt + = Just (Some BaseIntegerRepr) +fotToBaseType (FOTIntMod _n) + = Just (Some BaseIntegerRepr) +fotToBaseType (FOTVec nat FOTBit) + | Just (Some (PosNat nr)) <- somePosNat nat + = Just (Some (BaseBVRepr nr)) + | otherwise = Nothing + +fotToBaseType (FOTVec nat fot) + | Just (Some assn) <- listToAssn (replicate (fromIntegral nat) fot) + = Just (Some (BaseStructRepr assn)) +fotToBaseType (FOTArray fot1 fot2) + | Just (Some ty1) <- fotToBaseType fot1 + , Just (Some ty2) <- fotToBaseType fot2 + = Just (Some (BaseArrayRepr (Empty :> ty1) ty2)) +fotToBaseType (FOTTuple fots) + | Just (Some assn) <- listToAssn fots + = Just (Some (BaseStructRepr assn)) + +-- TODO: convert to What4 records ?! +fotToBaseType _ = Nothing + +listToAssn :: [FirstOrderType] -> Maybe (Some (Assignment BaseTypeRepr)) +listToAssn [] = Just (Some empty) +listToAssn (fot:rest) = + case (fotToBaseType fot, listToAssn rest) of + (Just (Some bt), Just (Some assn)) -> Just (Some (extend assn bt)) + _ -> Nothing + +--------------------------------------------------------------------- +-- | Convert a type expression from What4 to SAW-core + +typeReprToFOT :: BaseTypeRepr ty -> Either String FirstOrderType +typeReprToFOT BaseBoolRepr = pure FOTBit +typeReprToFOT BaseIntegerRepr = pure FOTInt +typeReprToFOT (BaseBVRepr w) = pure $ FOTVec (natValue w) FOTBit +typeReprToFOT BaseRealRepr = Left "No FO Real" +typeReprToFOT BaseComplexRepr = Left "No FO Complex" +typeReprToFOT (BaseStringRepr _) = Left "No FO String" +typeReprToFOT (BaseArrayRepr (Empty :> ty) b) + | Right fot1 <- typeReprToFOT ty + , Right fot2 <- typeReprToFOT b + = pure $ FOTArray fot1 fot2 +typeReprToFOT ty@(BaseArrayRepr _ctx _b) = Left $ "Unsupported FO Array: " ++ show ty +typeReprToFOT (BaseFloatRepr _) = Left "No FO Floating point" +typeReprToFOT (BaseStructRepr ctx) = FOTTuple <$> assnToList ctx + +assnToList :: Assignment BaseTypeRepr ctx -> Either String [FirstOrderType] +assnToList = foldrFC g (Right []) where + g :: BaseTypeRepr x -> Either String [FirstOrderType] -> Either String [FirstOrderType] + g ty l = (:) <$> typeReprToFOT ty <*> l + + +--------------------------------------------------------------------- +-- | Convert between What4 GroundValues and saw-core FirstOrderValues + +groundToFOV :: BaseTypeRepr ty -> GroundValue ty -> Either String FirstOrderValue +groundToFOV BaseBoolRepr b = pure $ FOVBit b +groundToFOV BaseIntegerRepr i = pure $ FOVInt i +groundToFOV (BaseBVRepr w) bv = pure $ FOVWord (natValue w) (BV.asUnsigned bv) +groundToFOV BaseRealRepr _ = Left "Real is not FOV" +groundToFOV BaseComplexRepr _ = Left "Complex is not FOV" +groundToFOV (BaseStringRepr _) _ = Left "String is not FOV" +groundToFOV (BaseFloatRepr _) _ = Left "Floating point is not FOV" +groundToFOV (BaseArrayRepr (Empty :> ty) b) _ + | Right fot1 <- typeReprToFOT ty + , Right fot2 <- typeReprToFOT b + = pure $ FOVArray fot1 fot2 +groundToFOV (BaseArrayRepr _idx _b) _ = Left "Unsupported FOV Array" +groundToFOV (BaseStructRepr ctx) tup = FOVTuple <$> tupleToList ctx tup + + +tupleToList :: Assignment BaseTypeRepr ctx -> + Assignment GroundValueWrapper ctx -> Either String [FirstOrderValue] +tupleToList (viewAssign -> AssignEmpty) (viewAssign -> AssignEmpty) = Right [] +tupleToList (viewAssign -> AssignExtend rs r) (viewAssign -> AssignExtend gvs gv) = + (:) <$> groundToFOV r (unGVW gv) <*> tupleToList rs gvs +#if !MIN_VERSION_GLASGOW_HASKELL(8,10,0,0) +tupleToList _ _ = error "GADTs should rule this out." +#endif diff --git a/saw-core-what4/src/Verifier/SAW/Simulator/What4/Panic.hs b/saw-core-what4/src/Verifier/SAW/Simulator/What4/Panic.hs new file mode 100644 index 0000000000..635f1f500c --- /dev/null +++ b/saw-core-what4/src/Verifier/SAW/Simulator/What4/Panic.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TemplateHaskell #-} + +module Verifier.SAW.Simulator.What4.Panic + ( panic + ) where + +import Panic hiding (panic) +import qualified Panic + +data SAWCoreWhat4 = SAWCoreWhat4 + +panic :: HasCallStack => String -> [String] -> a +panic = Panic.panic SAWCoreWhat4 + +instance PanicComponent SAWCoreWhat4 where + panicComponentName _ = "SAWCoreWhat4" + panicComponentIssues _ = "https://github.com/GaloisInc/saw-core-what4/issues" + + {-# Noinline panicComponentRevision #-} + panicComponentRevision = $useGitRevision + diff --git a/saw-core-what4/src/Verifier/SAW/Simulator/What4/PosNat.hs b/saw-core-what4/src/Verifier/SAW/Simulator/What4/PosNat.hs new file mode 100644 index 0000000000..a8f842f5dd --- /dev/null +++ b/saw-core-what4/src/Verifier/SAW/Simulator/What4/PosNat.hs @@ -0,0 +1,95 @@ +------------------------------------------------------------------------ +-- | +-- Module : Verifier.SAW.Simulator.What4.PosNat +-- Copyright : Galois, Inc. 2018 +-- License : BSD3 +-- Maintainer : sweirich@galois.com +-- Stability : experimental +-- Portability : non-portable (language extensions) +-- +-- A runtime representation of positive nats +------------------------------------------------------------------------ + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DoAndIfThenElse #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeApplications #-} + +-- This module makes use of 'KnownNat' constraints in its interface as +-- opposed to arguments of type 'NatRepr' or 'PosNatRepr' +-- (cf. 'addPosNat'). As a result, we need two + +-- to allow implicitly provided nats +{-# LANGUAGE AllowAmbiguousTypes #-} + +-- to allow 'WithKnownNat' +{-# OPTIONS_GHC -Wno-warnings-deprecations #-} + +module Verifier.SAW.Simulator.What4.PosNat where +-- TODO: find the right place for this code + +import GHC.TypeNats +import Data.Parameterized.NatRepr +import Data.Parameterized.Some(Some(..)) + + +-- We include the KnownNat constraint here so that we can avoid using +-- withKnownNat outside this module. The downside is that we have two +-- different runtime representations of these positive nats --- the +-- one stored in the KnownNat, and the one stored in the NatRepr. + +-- | Runtime representation of a non-zero natural number +data PosNat (n :: Nat) where + PosNat :: (1 <= n, KnownNat n) => NatRepr n -> PosNat n + +-- | Check whether an integer is a positive nat +somePosNat :: Integral a => a -> Maybe (Some PosNat) +somePosNat n + | Just (Some nr) <- someNat n, + Just LeqProof <- testLeq (knownNat @1) nr + = withKnownNat nr $ Just (Some (PosNat nr)) + | otherwise + = Nothing + +-- The above definition should be added to +-- 'Data.Parameterized.NatRepr' so that the redundant check for +-- positivity can be removed. Annoyingly, we cannot do 'testLeq' +-- without already knowing that w >= 0) + + +-- | Add two numbers together and return a proof that their +-- result is positive. +addPosNat :: forall w1 w2. + (1 <= w1, 1 <= w2, KnownNat w1, KnownNat w2) => PosNat (w1 + w2) +addPosNat = + let w1 = knownNat @w1 + w2 = knownNat @w2 + sm = addNat w1 w2 in + case leqAddPos w1 w2 of + LeqProof -> withKnownNat sm $ PosNat sm + +-- I would hope that the 'leqAddPos' call can be compiled away... + + +--- Not needed but included for completeness + +-- | Compare for equality, returning witness if true +instance TestEquality PosNat where + testEquality (PosNat n1) (PosNat n2) = + case testEquality n1 n2 of + Just Refl -> Just Refl + Nothing -> Nothing diff --git a/saw-core-what4/src/Verifier/SAW/Simulator/What4/ReturnTrip.hs b/saw-core-what4/src/Verifier/SAW/Simulator/What4/ReturnTrip.hs new file mode 100644 index 0000000000..ad739a9881 --- /dev/null +++ b/saw-core-what4/src/Verifier/SAW/Simulator/What4/ReturnTrip.hs @@ -0,0 +1,929 @@ +----------------------------------------------------------------------- +-- | +-- Module : Verifier.SAW.Simulator.What4.ReturnTrip +-- Description : Translation from What4 back to SawCore +-- Copyright : (c) Galois, Inc 2014-2021 +-- License : BSD3 +-- Maintainer : Rob Dockins +-- Stability : provisional +------------------------------------------------------------------------ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ViewPatterns #-} + +module Verifier.SAW.Simulator.What4.ReturnTrip + ( newSAWCoreState + , SAWCoreState(..) + , SAWExpr(..) + , baseSCType + , bindSAWTerm + , toSC + , sawCreateVar + , sawRegisterSymFunInterp + , getInputs + ) where + +import Control.Lens +import Control.Monad +import qualified Data.BitVector.Sized as BV +import Data.IORef +import Data.List (elemIndex) +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Map ( Map ) +import qualified Data.Map as Map +import qualified Data.Parameterized.Context as Ctx +import Data.Parameterized.Nonce +import Data.Parameterized.Some +import Data.Parameterized.TraversableFC +import Data.Ratio +import Data.Sequence (Seq) +import qualified Data.Sequence as Seq +import Data.Word(Word64) +import qualified Data.Text as Text + +import What4.BaseTypes +import What4.Interface +import qualified What4.Expr.ArrayUpdateMap as AUM +import qualified What4.Expr.Builder as B +import qualified What4.Expr.BoolMap as BM +import qualified What4.Expr.WeightedSum as WSum +import qualified What4.SemiRing as B +import What4.Symbol + +import qualified Verifier.SAW.SharedTerm as SC +import qualified Verifier.SAW.TypedAST as SC +import Verifier.SAW.Utils (panic) + +data SAWCoreState n + = SAWCoreState + { saw_ctx :: SC.SharedContext -- ^ the main SAWCore datastructure for building shared terms + , saw_inputs :: IORef (Seq (SC.ExtCns SC.Term )) + -- ^ a record of all the symbolic input variables created so far, + -- in the order they were created + + , saw_symMap :: IORef (Map Word64 (SC.SharedContext -> [SC.Term] -> IO SC.Term)) + -- ^ What to do with uninterpreted functions. + -- The key is the "indexValue" of the "symFunId" for the function + + , saw_elt_cache :: B.IdxCache n SAWExpr + -- ^ cache mapping a What4 variable nonce to its corresponding SAWCore term. + + , saw_elt_cache_r :: IORef (IntMap (Some (B.Expr n))) + -- ^ reverse cache mapping a SAWCore TermIndex to its corresponding What4 variable. + -- 'saw_elt_cache' and 'saw_elt_cache_r' implement a bidirectional map between + -- SAWCore terms and What4 variables. + + } + +newSAWCoreState :: + SC.SharedContext -> + IO (SAWCoreState n) +newSAWCoreState sc = + do inpr <- newIORef Seq.empty + ch <- B.newIdxCache + ch_r <- newIORef IntMap.empty + mr <- newIORef Map.empty + return SAWCoreState + { saw_ctx = sc + , saw_inputs = inpr + , saw_symMap = mr + , saw_elt_cache = ch + , saw_elt_cache_r = ch_r + } + +data SAWExpr (bt :: BaseType) where + SAWExpr :: !SC.Term -> SAWExpr bt + + -- This is a term that represents an integer, but has an + -- implicit integer-to-real conversion. + IntToRealSAWExpr :: !(SAWExpr BaseIntegerType) -> SAWExpr BaseRealType + +getInputs :: SAWCoreState n -> IO (Seq (SC.ExtCns SC.Term)) +getInputs st = readIORef (saw_inputs st) + +baseSCType :: + sym -> + SC.SharedContext -> + BaseTypeRepr tp -> + IO SC.Term +baseSCType sym sc bt = + case bt of + BaseBoolRepr -> SC.scBoolType sc + BaseBVRepr w -> SC.scBitvector sc $ fromIntegral (natValue w) + BaseIntegerRepr -> SC.scIntegerType sc + BaseArrayRepr indexTypes range + | Ctx.Empty Ctx.:> idx_type <- indexTypes -> + do sc_idx_type <- baseSCType sym sc idx_type + sc_elm_type <- baseSCType sym sc range + SC.scArrayType sc sc_idx_type sc_elm_type + | otherwise -> + unsupported sym "SAW backend does not support multidimensional Arrays: baseSCType" + BaseFloatRepr _ -> + unsupported sym "SAW backend does not support IEEE-754 floating point values: baseSCType" + BaseStringRepr _ -> + unsupported sym "SAW backend does not support string values: baseSCType" + BaseComplexRepr -> + unsupported sym "SAW backend does not support complex values: baseSCType" + BaseRealRepr -> + unsupported sym "SAW backend does not support real values: baseSCType" + BaseStructRepr ts -> + SC.scTupleType sc =<< baseSCTypes ts + where + baseSCTypes :: Ctx.Assignment BaseTypeRepr args -> IO [SC.Term] + baseSCTypes Ctx.Empty = return [] + baseSCTypes (xs Ctx.:> x) = + do ts <- baseSCTypes xs + t <- baseSCType sym sc x + return (ts ++ [t]) + +-- | Create a new symbolic variable. +sawCreateVar :: SAWCoreState n + -> String -- ^ the name of the variable + -> SC.Term + -> IO SC.Term +sawCreateVar st nm tp = do + let sc = saw_ctx st + ec <- SC.scFreshEC sc nm tp + t <- SC.scFlatTermF sc (SC.ExtCns ec) + modifyIORef (saw_inputs st) (\xs -> xs Seq.|> ec) + return t + +bindSAWTerm :: + B.ExprBuilder n st fs -> + SAWCoreState n -> + BaseTypeRepr bt -> + SC.Term -> + IO (B.Expr n bt) +bindSAWTerm sym st bt t = do + ch_r <- readIORef $ saw_elt_cache_r st + let midx = + case t of + SC.STApp { SC.stAppIndex = idx } -> Just idx + SC.Unshared _ -> Nothing + case midx >>= flip IntMap.lookup ch_r of + Just (Some var) -> do + Just Refl <- return $ testEquality bt (B.exprType var) + return var + Nothing -> do + sbVar@(B.BoundVarExpr bv) <- freshConstant sym emptySymbol bt + B.insertIdxValue (saw_elt_cache st) (B.bvarId bv) (SAWExpr t) + case midx of + Just i -> modifyIORef' (saw_elt_cache_r st) $ IntMap.insert i (Some sbVar) + Nothing -> pure () + return sbVar + +-- | Register an interpretation for a symbolic function. This is not +-- used during simulation, but rather, when we translate Crucible +-- values back into SAW. The interpretation function takes a list of +-- arguments in regular (left-to-right) order. +sawRegisterSymFunInterp :: + SAWCoreState n -> + B.ExprSymFn n args ret -> + (SC.SharedContext -> [SC.Term] -> IO SC.Term) -> + IO () +sawRegisterSymFunInterp st f i = + modifyIORef (saw_symMap st) (Map.insert (indexValue (B.symFnId f)) i) + +toSC :: B.ExprBuilder n st fs -> SAWCoreState n -> B.Expr n tp -> IO SC.Term +toSC sym st elt = evaluateExpr sym st (saw_ctx st) (saw_elt_cache st) elt + + +-- | Create a Real SAWELT value from a Rational. +-- +-- This fails on non-integer expressions. +scRealLit :: + sym -> + SC.SharedContext -> + Rational -> + IO (SAWExpr BaseRealType) +scRealLit sym sc r + | denominator r /= 1 = + unsupported sym "SAW backend does not support real values" + | otherwise = + IntToRealSAWExpr <$> scIntLit sc (numerator r) + +-- | Create a SAWCore term with type 'Integer' from a Haskell Integer. +scIntLit :: SC.SharedContext -> Integer -> IO (SAWExpr BaseIntegerType) +scIntLit sc i + | i >= 0 = + SAWExpr <$> (SC.scNatToInt sc =<< SC.scNat sc (fromInteger i)) + | otherwise = + SAWExpr <$> (SC.scIntNeg sc =<< SC.scNatToInt sc =<< SC.scNat sc (fromInteger (negate i))) + +scBvLit :: SC.SharedContext -> NatRepr w -> BV.BV w -> IO (SAWExpr (BaseBVType w)) +scBvLit sc w bv = SAWExpr <$> SC.scBvConst sc (natValue w) (BV.asUnsigned bv) + + +scRealCmpop :: + (SC.SharedContext -> SAWExpr BaseIntegerType -> SAWExpr BaseIntegerType -> IO (SAWExpr BaseBoolType)) -> + sym -> + SC.SharedContext -> + SAWExpr BaseRealType -> + SAWExpr BaseRealType -> + IO (SAWExpr BaseBoolType) +scRealCmpop intOp _ sc (IntToRealSAWExpr x) (IntToRealSAWExpr y) = + intOp sc x y +scRealCmpop _ sym _ _ _ = + unsupported sym "SAW backend does not support real values" + +scRealBinop :: + (SC.SharedContext -> SAWExpr BaseIntegerType -> SAWExpr BaseIntegerType -> IO (SAWExpr BaseIntegerType)) -> + sym -> + SC.SharedContext -> + SAWExpr BaseRealType -> + SAWExpr BaseRealType -> + IO (SAWExpr BaseRealType) +scRealBinop intOp _ sc (IntToRealSAWExpr x) (IntToRealSAWExpr y) = + IntToRealSAWExpr <$> intOp sc x y +scRealBinop _ sym _ _ _ = + unsupported sym "SAW backend does not support real values" + + +scIntBinop :: + (SC.SharedContext -> SC.Term -> SC.Term -> IO SC.Term) {- ^ operation on integers -} -> + SC.SharedContext -> + SAWExpr BaseIntegerType -> + SAWExpr BaseIntegerType -> + IO (SAWExpr BaseIntegerType) +scIntBinop intOp sc (SAWExpr x) (SAWExpr y) = + SAWExpr <$> intOp sc x y + +scIntCmpop :: + (SC.SharedContext -> SC.Term -> SC.Term -> IO SC.Term) {- ^ operation on integers -} -> + SC.SharedContext -> + SAWExpr BaseIntegerType -> + SAWExpr BaseIntegerType -> + IO (SAWExpr BaseBoolType) +scIntCmpop intOp sc (SAWExpr x) (SAWExpr y) = + SAWExpr <$> intOp sc x y + +scAddReal :: + sym -> + SC.SharedContext -> + SAWExpr BaseRealType -> + SAWExpr BaseRealType -> + IO (SAWExpr BaseRealType) +scAddReal = scRealBinop scAddInt + +scAddInt :: SC.SharedContext + -> SAWExpr BaseIntegerType + -> SAWExpr BaseIntegerType + -> IO (SAWExpr BaseIntegerType) +scAddInt = scIntBinop SC.scIntAdd + + +scMulReal :: + sym -> + SC.SharedContext -> + SAWExpr BaseRealType -> + SAWExpr BaseRealType -> + IO (SAWExpr BaseRealType) +scMulReal = scRealBinop scMulInt + +scMulInt :: SC.SharedContext + -> SAWExpr BaseIntegerType + -> SAWExpr BaseIntegerType + -> IO (SAWExpr BaseIntegerType) +scMulInt = scIntBinop SC.scIntMul + +scIteReal :: + sym -> + SC.SharedContext -> + SC.Term -> + SAWExpr BaseRealType -> + SAWExpr BaseRealType -> + IO (SAWExpr BaseRealType) +scIteReal sym sc p = scRealBinop (\sc' -> scIteInt sc' p) sym sc + +scIteInt :: SC.SharedContext + -> SC.Term + -> SAWExpr BaseIntegerType + -> SAWExpr BaseIntegerType + -> IO (SAWExpr BaseIntegerType) +scIteInt sc p = scIntBinop + (\sc' x y -> SC.scIntegerType sc >>= \tp -> SC.scIte sc' tp p x y) + sc + +scIte :: + sym -> + SC.SharedContext -> + BaseTypeRepr tp -> + SAWExpr BaseBoolType -> + SAWExpr tp -> + SAWExpr tp -> + IO (SAWExpr tp) +scIte sym sc tp (SAWExpr p) x y = + case tp of + BaseRealRepr -> scIteReal sym sc p x y + BaseIntegerRepr -> scIteInt sc p x y + _ -> + do tp' <- baseSCType sym sc tp + x' <- termOfSAWExpr sym sc x + y' <- termOfSAWExpr sym sc y + SAWExpr <$> SC.scIte sc tp' p x' y' + + +scRealEq :: + sym -> + SC.SharedContext -> + SAWExpr BaseRealType -> + SAWExpr BaseRealType -> + IO (SAWExpr BaseBoolType) +scRealEq = scRealCmpop scIntEq + +scIntEq :: SC.SharedContext + -> SAWExpr BaseIntegerType + -> SAWExpr BaseIntegerType + -> IO (SAWExpr BaseBoolType) +scIntEq = scIntCmpop SC.scIntEq + +scBoolEq :: + SC.SharedContext -> + SAWExpr BaseBoolType -> + SAWExpr BaseBoolType -> + IO (SAWExpr BaseBoolType) +scBoolEq sc (SAWExpr x) (SAWExpr y) = SAWExpr <$> SC.scBoolEq sc x y + +scEq :: + sym -> + SC.SharedContext -> + BaseTypeRepr tp -> + SAWExpr tp -> + SAWExpr tp -> + IO (SAWExpr BaseBoolType) +scEq sym sc tp x y = + case tp of + BaseBoolRepr -> scBoolEq sc x y + BaseRealRepr -> scRealEq sym sc x y + BaseIntegerRepr -> scIntEq sc x y + BaseBVRepr w -> + do let SAWExpr x' = x + let SAWExpr y' = y + w' <- SC.scNat sc $ fromIntegral (natValue w) + SAWExpr <$> SC.scBvEq sc w' x' y' + _ -> unsupported sym ("SAW backend: equality comparison on unsupported type:" ++ show tp) + + +scRealLe, scRealLt :: + sym -> + SC.SharedContext -> + SAWExpr BaseRealType -> + SAWExpr BaseRealType -> + IO (SAWExpr BaseBoolType) +scRealLe = scRealCmpop scIntLe +scRealLt = scRealCmpop scIntLt + +scIntLe, scIntLt :: + SC.SharedContext -> + SAWExpr BaseIntegerType -> + SAWExpr BaseIntegerType -> + IO (SAWExpr BaseBoolType) +scIntLe = scIntCmpop SC.scIntLe +scIntLt = scIntCmpop SC.scIntLt + +scBvAdd :: + SC.SharedContext -> + NatRepr w -> + SAWExpr (BaseBVType w) -> + SAWExpr (BaseBVType w) -> + IO (SAWExpr (BaseBVType w)) +scBvAdd sc w (SAWExpr x) (SAWExpr y) = + do n <- SC.scNat sc (natValue w) + SAWExpr <$> SC.scBvAdd sc n x y + +scBvNot :: + SC.SharedContext -> + NatRepr w -> + SAWExpr (BaseBVType w) -> + IO (SAWExpr (BaseBVType w)) +scBvNot sc w (SAWExpr x) = + do n <- SC.scNat sc (natValue w) + SAWExpr <$> SC.scBvNot sc n x + +scBvMul :: + SC.SharedContext -> + NatRepr w -> + SAWExpr (BaseBVType w) -> + SAWExpr (BaseBVType w) -> + IO (SAWExpr (BaseBVType w)) +scBvMul sc w (SAWExpr x) (SAWExpr y) = + do n <- SC.scNat sc (natValue w) + SAWExpr <$> SC.scBvMul sc n x y + +scBvAnd :: + SC.SharedContext -> + NatRepr w -> + SAWExpr (BaseBVType w) -> + SAWExpr (BaseBVType w) -> + IO (SAWExpr (BaseBVType w)) +scBvAnd sc w (SAWExpr x) (SAWExpr y) = + do n <- SC.scNat sc (natValue w) + SAWExpr <$> SC.scBvAnd sc n x y + +scBvXor :: + SC.SharedContext -> + NatRepr w -> + SAWExpr (BaseBVType w) -> + SAWExpr (BaseBVType w) -> + IO (SAWExpr (BaseBVType w)) +scBvXor sc w (SAWExpr x) (SAWExpr y) = + do n <- SC.scNat sc (natValue w) + SAWExpr <$> SC.scBvXor sc n x y + +termOfSAWExpr :: + sym -> + SC.SharedContext -> + SAWExpr tp -> IO SC.Term +termOfSAWExpr sym _sc expr = + case expr of + SAWExpr t -> return t + IntToRealSAWExpr _ + -> unsupported sym "SAW backend does not support real values" + +applyExprSymFn :: + forall n st fs args ret. + B.ExprBuilder n st fs -> + SAWCoreState n -> + SC.SharedContext -> + B.ExprSymFn n args ret -> + Ctx.Assignment SAWExpr args -> + IO (SAWExpr ret) +applyExprSymFn sym st sc fn args = + do mp <- readIORef (saw_symMap st) + mk <- + case Map.lookup (indexValue (B.symFnId fn)) mp of + Nothing -> panic "SAWCore.applyExprSymFn" + [ "Unknown symbolic function." + , "*** Name: " ++ show fn + ] + Just mk -> return mk + ts <- evaluateAsgn args + SAWExpr <$> mk sc (reverse ts) + where + evaluateAsgn :: Ctx.Assignment SAWExpr args' -> IO [SC.Term] + evaluateAsgn Ctx.Empty = return [] + evaluateAsgn (xs Ctx.:> x) = + do vs <- evaluateAsgn xs + v <- termOfSAWExpr sym sc x + return (v : vs) + +{- | Declare that we don't support something or other. +This aborts the current path of execution, and adds a proof +obligation to ensure that we won't get there. +These proof obligations are all tagged with "Unsupported", so that +users of the library can choose if they will try to discharge them, +fail in some other way, or just ignore them. -} +unsupported :: {- OnlineSolver solver => -} sym -> String -> IO a +unsupported _sym x = fail ("Unsupported " <> x) -- TODO, something better here.... + + +evaluateExpr :: forall n st tp fs. + B.ExprBuilder n st fs-> + SAWCoreState n -> + SC.SharedContext -> + B.IdxCache n SAWExpr -> + B.Expr n tp -> + IO SC.Term +evaluateExpr sym st sc cache = f [] + where + -- Evaluate the element, and expect the result to have the same type. + f :: [Maybe SolverSymbol] -> B.Expr n tp' -> IO SC.Term + f env elt = termOfSAWExpr sym sc =<< eval env elt + + eval :: [Maybe SolverSymbol] -> B.Expr n tp' -> IO (SAWExpr tp') + eval env elt = B.idxCacheEval cache elt (go env elt) + + realFail :: IO a + realFail = unsupported sym "SAW backend does not support real values" + + cplxFail :: IO a + cplxFail = unsupported sym "SAW backend does not support complex values" + + floatFail :: IO a + floatFail = unsupported sym "SAW backend does not support floating-point values" + + stringFail :: IO a + stringFail = unsupported sym "SAW backend does not support string values" + + unimplemented :: String -> IO a + unimplemented x = unsupported sym $ "SAW backend: not implemented: " ++ x + + go :: [Maybe SolverSymbol] -> B.Expr n tp' -> IO (SAWExpr tp') + + go _ (B.BoolExpr b _) = SAWExpr <$> SC.scBool sc b + + go _ (B.SemiRingLiteral sr x _) = + case sr of + B.SemiRingBVRepr _ w -> scBvLit sc w x + B.SemiRingIntegerRepr -> scIntLit sc x + B.SemiRingRealRepr -> scRealLit sym sc x + + go _ (B.StringExpr{}) = + unsupported sym "SAW backend does not support string values" + + go _ (B.FloatExpr{}) = + unsupported sym "SAW backend does not support floating-point values" + + go env (B.BoundVarExpr bv) = + case B.bvarKind bv of + B.UninterpVarKind -> do + tp <- baseSCType sym sc (B.bvarType bv) + SAWExpr <$> sawCreateVar st nm tp + where nm = Text.unpack $ solverSymbolAsText $ B.bvarName bv + B.LatchVarKind -> + unsupported sym "SAW backend does not support latch variables" + B.QuantifierVarKind -> do + case elemIndex (Just $ B.bvarName bv) env of + Nothing -> unsupported sym $ "unbound quantifier variable " <> nm + Just idx -> SAWExpr <$> SC.scLocalVar sc idx + where nm = Text.unpack $ solverSymbolAsText $ B.bvarName bv + + go env (B.NonceAppExpr p) = + case B.nonceExprApp p of + B.Annotation _tpr _n x -> + eval env x + + B.Forall bvar body -> + case B.bvarType bvar of + BaseBVRepr wrepr -> do + w <- SC.scNat sc $ natValue wrepr + ty <- SC.scVecType sc w =<< SC.scBoolType sc + SAWExpr <$> + (SC.scBvForall sc w + =<< SC.scLambda sc nm ty =<< f (Just (B.bvarName bvar):env) body) + where nm = solverSymbolAsText $ B.bvarName bvar + _ -> unsupported sym "SAW backend only supports universal quantifiers over bitvectors" + B.Exists{} -> + unsupported sym "SAW backend does not support existential quantifiers" + B.ArrayFromFn{} -> unimplemented "ArrayFromFn" + B.MapOverArrays{} -> unimplemented "MapOverArrays" + B.ArrayTrueOnEntries{} -> unimplemented "ArrayTrueOnEntries" + B.FnApp fn asgn -> + do args <- traverseFC (eval env) asgn + applyExprSymFn sym st sc fn args + + go env a0@(B.AppExpr a) = + let nyi = unsupported sym $ + "Expression form not yet implemented in SAWCore backend:\n" + ++ show a0 + in + case B.appExprApp a of + B.BaseIte bt _ c xe ye -> join (scIte sym sc bt <$> eval env c <*> eval env xe <*> eval env ye) + B.BaseEq bt xe ye -> join (scEq sym sc bt <$> eval env xe <*> eval env ye) + + B.SemiRingLe sr xe ye -> + case sr of + B.OrderedSemiRingRealRepr -> join (scRealLe sym sc <$> eval env xe <*> eval env ye) + B.OrderedSemiRingIntegerRepr -> join (scIntLe sc <$> eval env xe <*> eval env ye) + + B.NotPred x -> + goNeg env x + + B.ConjPred xs -> + case BM.viewBoolMap xs of + BM.BoolMapUnit -> SAWExpr <$> SC.scBool sc True + BM.BoolMapDualUnit -> SAWExpr <$> SC.scBool sc False + BM.BoolMapTerms (t:|ts) -> + let pol (x,BM.Positive) = f env x + pol (x,BM.Negative) = termOfSAWExpr sym sc =<< goNeg env x + in SAWExpr <$> join (foldM (SC.scAnd sc) <$> pol t <*> mapM pol ts) + + B.SemiRingProd pd -> + case WSum.prodRepr pd of + B.SemiRingRealRepr -> + do pd' <- WSum.prodEvalM (scMulReal sym sc) (eval env) pd + maybe (scRealLit sym sc 1) return pd' + B.SemiRingIntegerRepr -> + do pd' <- WSum.prodEvalM (scMulInt sc) (eval env) pd + maybe (scIntLit sc 1) return pd' + B.SemiRingBVRepr B.BVArithRepr w -> + do n <- SC.scNat sc (natValue w) + pd' <- WSum.prodEvalM (SC.scBvMul sc n) (f env) pd + maybe (scBvLit sc w (BV.one w)) (return . SAWExpr) pd' + B.SemiRingBVRepr B.BVBitsRepr w -> + do n <- SC.scNat sc (natValue w) + pd' <- WSum.prodEvalM (SC.scBvAnd sc n) (f env) pd + maybe (scBvLit sc w (BV.maxUnsigned w)) (return . SAWExpr) pd' + + B.SemiRingSum ss -> + case WSum.sumRepr ss of + B.SemiRingRealRepr -> WSum.evalM add smul (scRealLit sym sc) ss + where add x y = scAddReal sym sc x y + smul 1 e = eval env e + smul sm e = join $ scMulReal sym sc <$> scRealLit sym sc sm <*> eval env e + B.SemiRingIntegerRepr -> WSum.evalM add smul (scIntLit sc) ss + where add x y = scAddInt sc x y + smul 1 e = eval env e + smul sm e = join $ scMulInt sc <$> scIntLit sc sm <*> eval env e + B.SemiRingBVRepr B.BVArithRepr w -> WSum.evalM add smul (scBvLit sc w) ss + where add x y = scBvAdd sc w x y + smul (BV.BV 1) e = eval env e + smul sm e = join (scBvMul sc w <$> scBvLit sc w sm <*> eval env e) + B.SemiRingBVRepr B.BVBitsRepr w + | ss^.WSum.sumOffset == one -> scBvNot sc w =<< bitwise_eval (ss & WSum.sumOffset .~ BV.zero w) + | otherwise -> bitwise_eval ss + + where one = BV.maxUnsigned w + bitwise_eval = WSum.evalM add smul (scBvLit sc w) + add x y = scBvXor sc w x y + smul sm e + | sm == one = eval env e + | otherwise = join (scBvAnd sc w <$> scBvLit sc w sm <*> eval env e) + + B.RealIsInteger{} -> unsupported sym "SAW backend does not support real values" + + B.BVOrBits w bs -> + do n <- SC.scNat sc (natValue w) + bs' <- traverse (f env) (B.bvOrToList bs) + case bs' of + [] -> scBvLit sc w (BV.zero w) + x:xs -> SAWExpr <$> foldM (SC.scBvOr sc n) x xs + + B.BVFill w p -> + do bit <- SC.scBoolType sc + n <- SC.scNat sc (natValue w) + x <- f env p + SAWExpr <$> SC.scGlobalApply sc (SC.mkIdent SC.preludeName "replicate") [n, bit, x] + + B.BVTestBit i bv -> fmap SAWExpr $ do + w <- SC.scNat sc (natValue (bvWidth bv)) + bit <- SC.scBoolType sc + -- NB, SAWCore's `scAt` is big endian + let j = natValue (bvWidth bv) - i - 1 + join (SC.scAt sc w bit <$> f env bv <*> SC.scNat sc j) + + B.BVSlt x y -> fmap SAWExpr $ do + w <- SC.scNat sc (natValue (bvWidth x)) + join (SC.scBvSLt sc w <$> f env x <*> f env y) + B.BVUlt x y -> fmap SAWExpr $ do + w <- SC.scNat sc (natValue (bvWidth x)) + join (SC.scBvULt sc w <$> f env x <*> f env y) + + B.BVUnaryTerm{} -> unsupported sym "SAW backend does not support the unary bitvector representation" + + B.BVUdiv _ x y -> fmap SAWExpr $ do + n <- SC.scNat sc (natValue (bvWidth x)) + join (SC.scBvUDiv sc n <$> f env x <*> f env y) + B.BVUrem _ x y -> fmap SAWExpr $ do + n <- SC.scNat sc (natValue (bvWidth x)) + join (SC.scBvURem sc n <$> f env x <*> f env y) + B.BVSdiv _ x y -> fmap SAWExpr $ do + -- NB: bvSDiv applies 'Succ' to its width argument, so we + -- need to subtract 1 to make the types match. + n <- SC.scNat sc (natValue (bvWidth x) - 1) + join (SC.scBvSDiv sc n <$> f env x <*> f env y) + B.BVSrem _ x y -> fmap SAWExpr $ do + -- NB: bvSDiv applies 'Succ' to its width argument, so we + -- need to subtract 1 to make the types match. + n <- SC.scNat sc (natValue (bvWidth x) - 1) + join (SC.scBvSRem sc n <$> f env x <*> f env y) + B.BVShl _ x y -> fmap SAWExpr $ do + let w = natValue (bvWidth x) + n <- SC.scNat sc w + join (SC.scBvShl sc n <$> f env x <*> (SC.scBvToNat sc w =<< f env y)) + B.BVLshr _ x y -> fmap SAWExpr $ do + let w = natValue (bvWidth x) + n <- SC.scNat sc w + join (SC.scBvShr sc n <$> f env x <*> (SC.scBvToNat sc w =<< f env y)) + B.BVAshr _ x y -> fmap SAWExpr $ do + let w = natValue (bvWidth x) + -- NB: bvSShr applies a `Succ` to its width argument, so we subtract + -- 1 here to make things match up. + n <- SC.scNat sc (w - 1) + join (SC.scBvSShr sc n <$> f env x <*> (SC.scBvToNat sc w =<< f env y)) + B.BVRol w x y -> fmap SAWExpr $ do + n <- SC.scNat sc (natValue w) + bit <- SC.scBoolType sc + x' <- f env x + y' <- SC.scBvToNat sc (natValue w) =<< f env y + SC.scGlobalApply sc (SC.mkIdent SC.preludeName "rotateL") [n,bit,x',y'] + B.BVRor w x y -> fmap SAWExpr $ do + n <- SC.scNat sc (natValue w) + bit <- SC.scBoolType sc + x' <- f env x + y' <- SC.scBvToNat sc (natValue w) =<< f env y + SC.scGlobalApply sc (SC.mkIdent SC.preludeName "rotateR") [n,bit,x',y'] + B.BVConcat _ x y -> fmap SAWExpr $ do + n <- SC.scNat sc (natValue (bvWidth x)) + m <- SC.scNat sc (natValue (bvWidth y)) + t <- SC.scBoolType sc + join (SC.scAppend sc t n m <$> f env x <*> f env y) + B.BVSelect start num x -> fmap SAWExpr $ do + i <- SC.scNat sc (natValue (bvWidth x) - natValue num - natValue start) + n <- SC.scNat sc (natValue num) + o <- SC.scNat sc (natValue start) + t <- SC.scBoolType sc + x' <- f env x + SC.scSlice sc t i n o x' + B.BVZext w' x -> fmap SAWExpr $ do + let w = bvWidth x + n <- SC.scNat sc (natValue w) + m <- SC.scNat sc (natValue w' - natValue w) + x' <- f env x + SC.scBvUExt sc m n x' + B.BVSext w' x -> fmap SAWExpr $ do + let w = bvWidth x + -- NB: width - 1 to make SAWCore types work out + n <- SC.scNat sc (natValue w - 1) + m <- SC.scNat sc (natValue w' - natValue w) + x' <- f env x + SC.scBvSExt sc m n x' + B.BVPopcount w x -> + do n <- SC.scNat sc (natValue w) + x' <- f env x + SAWExpr <$> SC.scBvPopcount sc n x' + B.BVCountLeadingZeros w x -> + do n <- SC.scNat sc (natValue w) + x' <- f env x + SAWExpr <$> SC.scBvCountLeadingZeros sc n x' + B.BVCountTrailingZeros w x -> + do n <- SC.scNat sc (natValue w) + x' <- f env x + SAWExpr <$> SC.scBvCountTrailingZeros sc n x' + + -- Note: SAWCore supports only unidimensional arrays. As a result, What4 multidimensional + -- arrays cannot be translated to SAWCore. + B.ArrayMap indexTypes range updates arr + | Ctx.Empty Ctx.:> idx_type <- indexTypes -> + do sc_idx_type <- baseSCType sym sc idx_type + sc_elm_type <- baseSCType sym sc range + sc_arr <- f env arr + SAWExpr <$> foldM + (\sc_acc_arr (Ctx.Empty Ctx.:> idx_lit, elm) -> + do sc_idx <- f env =<< indexLit sym idx_lit + sc_elm <- f env elm + SC.scArrayUpdate sc sc_idx_type sc_elm_type sc_acc_arr sc_idx sc_elm) + sc_arr + (AUM.toList updates) + | otherwise -> unimplemented "multidimensional ArrayMap" + + B.ConstantArray indexTypes range v + | Ctx.Empty Ctx.:> idx_type <- indexTypes -> + do sc_idx_type <- baseSCType sym sc idx_type + sc_elm_type <- baseSCType sym sc range + sc_elm <- f env v + SAWExpr <$> SC.scArrayConstant sc sc_idx_type sc_elm_type sc_elm + | otherwise -> unimplemented "multidimensional ConstantArray" + + B.SelectArray range arr indexTerms + | Ctx.Empty Ctx.:> idx <- indexTerms + , idx_type <- exprType idx -> + do sc_idx_type <- baseSCType sym sc idx_type + sc_elm_type <- baseSCType sym sc range + sc_arr <- f env arr + sc_idx <- f env idx + SAWExpr <$> SC.scArrayLookup sc sc_idx_type sc_elm_type sc_arr sc_idx + | otherwise -> unimplemented "multidimensional SelectArray" + + B.UpdateArray range indexTypes arr indexTerms v + | Ctx.Empty Ctx.:> idx_type <- indexTypes + , Ctx.Empty Ctx.:> idx <- indexTerms -> + do sc_idx_type <- baseSCType sym sc idx_type + sc_elm_type <- baseSCType sym sc range + sc_arr <- f env arr + sc_idx <- f env idx + sc_elm <- f env v + SAWExpr <$> SC.scArrayUpdate sc sc_idx_type sc_elm_type sc_arr sc_idx sc_elm + | otherwise -> unimplemented "multidimensional UpdateArray" + + B.IntDiv x y -> + do x' <- f env x + y' <- f env y + SAWExpr <$> SC.scIntDiv sc x' y' + B.IntMod x y -> + do x' <- f env x + y' <- f env y + SAWExpr <$> SC.scIntMod sc x' y' + B.IntAbs x -> + eval env x >>= \case + SAWExpr z -> SAWExpr <$> (SC.scIntAbs sc z) + + B.IntDivisible x 0 -> + do x' <- f env x + SAWExpr <$> (SC.scIntEq sc x' =<< SC.scIntegerConst sc 0) + B.IntDivisible x k -> + do x' <- f env x + k' <- SC.scIntegerConst sc (toInteger k) + z <- SC.scIntMod sc x' k' + SAWExpr <$> (SC.scIntEq sc z =<< SC.scIntegerConst sc 0) + + B.IntegerToBV x w -> + do n <- SC.scNat sc (natValue w) + SAWExpr <$> (SC.scIntToBv sc n =<< f env x) + + B.BVToInteger x -> + do n <- SC.scNat sc (natValue (bvWidth x)) + SAWExpr <$> (SC.scBvToInt sc n =<< f env x) + + B.SBVToInteger x -> + do n <- SC.scNat sc (natValue (bvWidth x)) + SAWExpr <$> (SC.scSbvToInt sc n =<< f env x) + + -- Proper support for real and complex numbers will require additional + -- work on the SAWCore side + B.IntegerToReal x -> IntToRealSAWExpr . SAWExpr <$> f env x + B.RealToInteger x -> + eval env x >>= \case + IntToRealSAWExpr x' -> return x' + _ -> realFail + + ------------------------------------------------------------------------ + -- Floating point operations + + B.FloatNeg{} -> floatFail + B.FloatAbs{} -> floatFail + B.FloatSqrt{} -> floatFail + B.FloatAdd{} -> floatFail + B.FloatSub{} -> floatFail + B.FloatMul{} -> floatFail + B.FloatDiv{} -> floatFail + B.FloatRem{} -> floatFail + B.FloatFMA{} -> floatFail + B.FloatFpEq{} -> floatFail + B.FloatLe{} -> floatFail + B.FloatLt{} -> floatFail + B.FloatIsNaN{} -> floatFail + B.FloatIsInf{} -> floatFail + B.FloatIsZero{} -> floatFail + B.FloatIsPos{} -> floatFail + B.FloatIsNeg{} -> floatFail + B.FloatIsSubnorm{} -> floatFail + B.FloatIsNorm{} -> floatFail + B.FloatCast{} -> floatFail + B.FloatRound{} -> floatFail + B.FloatFromBinary{} -> floatFail + B.BVToFloat{} -> floatFail + B.SBVToFloat{} -> floatFail + B.RealToFloat{} -> floatFail + B.FloatToBV{} -> floatFail + B.FloatToSBV{} -> floatFail + B.FloatToReal{} -> floatFail + B.FloatToBinary{} -> floatFail + + B.RoundReal{} -> realFail + B.RoundEvenReal{} -> realFail + B.FloorReal{} -> realFail + B.CeilReal{} -> realFail + B.RealDiv{} -> realFail + B.RealSqrt{} -> realFail + B.Pi{} -> realFail + B.RealSin{} -> realFail + B.RealCos{} -> realFail + B.RealSinh{} -> realFail + B.RealCosh{} -> realFail + B.RealExp{} -> realFail + B.RealLog{} -> realFail + B.RealATan2{} -> realFail + + B.Cplx{} -> cplxFail + B.RealPart{} -> cplxFail + B.ImagPart{} -> cplxFail + + B.StringLength{} -> stringFail + B.StringAppend{} -> stringFail + B.StringContains{} -> stringFail + B.StringIsPrefixOf{} -> stringFail + B.StringIsSuffixOf{} -> stringFail + B.StringIndexOf{} -> stringFail + B.StringSubstring{} -> stringFail + + B.StructCtor{} -> nyi -- FIXME + B.StructField{} -> nyi -- FIXME + + -- returns the logical negation of the result of 'go' + -- negations are pushed inside conjunctions and less-than-or-equal + goNeg :: [Maybe SolverSymbol] -> B.Expr n BaseBoolType -> IO (SAWExpr BaseBoolType) + goNeg env expr = + case expr of + -- negation of (x /\ y) becomes (~x \/ ~y) + B.AppExpr (B.appExprApp -> B.ConjPred xs) -> + case BM.viewBoolMap xs of + BM.BoolMapUnit -> SAWExpr <$> SC.scBool sc False + BM.BoolMapDualUnit -> SAWExpr <$> SC.scBool sc True + BM.BoolMapTerms (t:|ts) -> + let pol (x, BM.Positive) = termOfSAWExpr sym sc =<< goNegAtom env x + pol (x, BM.Negative) = f env x + in SAWExpr <$> join (foldM (SC.scOr sc) <$> pol t <*> mapM pol ts) + _ -> goNegAtom env expr + + -- returns the logical negation of the result of 'go' + -- negations are pushed inside less-than-or-equal + goNegAtom :: [Maybe SolverSymbol] -> B.Expr n BaseBoolType -> IO (SAWExpr BaseBoolType) + goNegAtom env expr = + case expr of + -- negation of (x <= y) becomes (y < x) + B.AppExpr (B.appExprApp -> B.SemiRingLe sr xe ye) -> + case sr of + B.OrderedSemiRingRealRepr -> join (scRealLt sym sc <$> eval env ye <*> eval env xe) + B.OrderedSemiRingIntegerRepr -> join (scIntLt sc <$> eval env ye <*> eval env xe) + _ -> SAWExpr <$> (SC.scNot sc =<< f env expr) + diff --git a/saw-core/.gitignore b/saw-core/.gitignore new file mode 100644 index 0000000000..bf2e4eb007 --- /dev/null +++ b/saw-core/.gitignore @@ -0,0 +1,3 @@ +cabal.sandbox.config +dist +.stack-work diff --git a/saw-core/LICENSE b/saw-core/LICENSE new file mode 100644 index 0000000000..9e2f031c53 --- /dev/null +++ b/saw-core/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2012-2016, 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 names of the authors nor the names of other + 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/saw-core/README.md b/saw-core/README.md new file mode 100644 index 0000000000..8d72ded885 --- /dev/null +++ b/saw-core/README.md @@ -0,0 +1,10 @@ +This repository contains the code for SAWCore, an intermediate +language for representing the semantics of software (and potentially +hardware). It provides support for constructing models in a +dependently-typed lambda-calculus, transforming those models using a +rewriting engine, concretely or symbolically interpreting those +models, and emitting them as input to various external theorem +provers. + +Currently, the library supports generating AIG, CNF, and SMT-Lib +output. diff --git a/saw-core/Setup.hs b/saw-core/Setup.hs new file mode 100644 index 0000000000..9a994af677 --- /dev/null +++ b/saw-core/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/saw-core/doc/Makefile b/saw-core/doc/Makefile new file mode 100644 index 0000000000..04ce43ff7e --- /dev/null +++ b/saw-core/doc/Makefile @@ -0,0 +1,7 @@ +formal.pdf : formal.tex + xelatex formal + xelatex formal + +.PHONY : clean +clean : + rm -f *.aux *.log formal.pdf \ No newline at end of file diff --git a/saw-core/doc/formal.tex b/saw-core/doc/formal.tex new file mode 100644 index 0000000000..69720a992d --- /dev/null +++ b/saw-core/doc/formal.tex @@ -0,0 +1,116 @@ +\documentclass{article} +\usepackage{amsmath} +\usepackage{semantic} + +\title{The Logic of SAW} + +%\newcommand{\inference}[2]{\frac{#1}{#2}} +\newcommand{\rectyp}[1]{\#\{#1\}} +\newcommand{\recval}[1]{\{#1\}} +\newcommand{\fn}[1]{\mathtt{#1}} +\newcommand{\set}[1]{\fn{set}_{#1}} +\newcommand{\rctor}[3]{{#1} : {#2} \downarrow {#3}} +\newcommand{\Piexpr}[3]{\Pi {#1}{:}{#2}.\ {#3}} +\newcommand{\rlbl}[1]{\mathrm{\scriptstyle{}#1}} + +\begin{document} + +%Lambda +%Pi +%Tuple Values & Types +%Record Values & Types +%Record selectors + +\section{Syntax} + +We begin by defining \emph{pseudo-terms}, syntactically constructed objects that +may or may not have a valid type according to the type inference rules which we +will define later. In defining the terms, we assume that there are disjoint infinite +sets $X$ and $C$. We call the elements $x \in X$ \emph{variables}, and the elements +$c \in C$ \emph{constructors}. + +\begin{align*} +&\begin{array}{llrll} +\text{Terms} +& T,U &:=\:& x & \text{var term}\\ +& & |\:& (\lambda x . T) &\text{lambda}\\ +& & |\:& T U &\text{app}\\ +& & |\:& \Piexpr{x}{T}{U} &\text{Pi expression}\\ +& & |\:& \set{i}\\ +& & |\:& (T_1, \dots, T_n)\\ % Tuples +& & |\:& \#(T_1, \dots, T_n)\\ % Tuple types +& & |\:& \{ f_1 = T_1; \dots; f_n = T_n \} \\ % records +& & |\:& \#\{ f_1 : T_1; \dots; f_n : T_n \} \\ % record types +& & |\:& c(T_1,\dots,T_n)\\ % Constructors +& & |\:& \fn{let}\ [ D_1; \dots; D_n ]\ \fn{in}\ T\\ % let +\text{Definitions} +&D_i &:=\:&x :: T; E_{x,1}; \dots; E_{x,n}\\ +\text{Equations} +&E_{c,i} &:=\:&c\ P_1\ \dots\ P_n = T\\ +\text{Patterns} +&P &:=\:&x & \text{Variable}\\ +& & |\:&(P_1, \dots, P_n) &\text{Tuple}\\ % Tuples +& & |\:&\{ f_1 = P_1; \dots; f_n = P_n \} & \text{Record}\\ % Records +& & |\:&c(P_1, \dots, P_n) & \text{Constructor}\\ % Constructors +& & |\:&.T & \text{Inaccessible term}\\ +\end{array}\\ +\end{align*} + +A term is logically defined + +\section{Typing Rules} +\begin{gather*} +\begin{array}{rc} +% Variables +\rlbl{var-1}& +\inference{}{\Gamma, x{:}A |- x : A}\\[1em] +\rlbl{var-2}& +\inference{\Gamma |- x : A \quad y \not\in (\{x\} \cup \fn{fv}(A))} + {\Gamma,y{:}B |- x : A}\\[1em] +% Lambda +\rlbl{lambda}& +\inference{\Gamma |- A{:}\set{\alpha} \quad \Gamma,x{:}A |- b{:}B} + {\Gamma |- (\lambda x . b) : (\Piexpr{x}{A}{B})}\\[1em] +\rlbl{app}& +\inference{\Gamma |- f : (\Piexpr{x}{A}{B}) \quad \Gamma |- t : A } + {\Gamma |- f t : B[x/t] }\\[1em] +\rlbl{pi}& +\inference{\Gamma |- A : \set{i} \quad \Gamma,x:A |- B : \set{i}} + {\Gamma |- (\Piexpr{x}{A}{B}) : \set{i}}\\[1em] +%Set +\rlbl{set}& +\inference{}{\Gamma |- \set{i} : \set{i+1}}\\[1em] +\rlbl{subset}& +\inference{\Gamma |- t : \set{i}}{\Gamma |- t : \set{i+1}}\\[1em] +% Tuples +\rlbl{tuple-1}& +\inference{\Gamma |- x_1 : T_1 \quad \dots \quad \Gamma |- x_n : T_n} + {\Gamma |- (x_1, \dots, x_n) : \#(T_1, \dots, T_n)}\\[1em] +\rlbl{tuple-2}& +\inference{\Gamma |- T_1 : \set{i} \quad \dots \quad \Gamma |- T_n : \set{i}} + {\Gamma |- \#(T_1, \dots, T_n) : \set{i}}\\[1em] +% Records +\rlbl{record-1}& +\inference{\Gamma |- t_1 : T_1\ \dots\ \Gamma |- t_n : T_n } + {\Gamma |- \recval{ x_1 = t_1;\ \dots\ ; x_n = t_n} + : \rectyp{ x_1 : T_1;\ \dots\ ; x_n : T_n}}\\[1em] +\rlbl{record-2}& +\inference{\Gamma |- T_1 : \set{i} \quad \dots \quad \Gamma |- T_n : \set{i}} + {\Gamma |- \rectyp{ x_1 : T_1;\ \dots\ ; x_n : T_n} : \set{i}}\\[1em] +\rlbl{record-3}& +\inference{\Gamma |- r : \rectyp{ x : t; \dots }} + {\Gamma |- r.x : t }\\[1em] +% Constructors +\rlbl{ctor-1}& +\inference{c : T \in \Sigma \quad \Gamma |- \rctor{t_1,\dots,t_n}{T}{C}} + {\Gamma |- c(t_1,\dots,t_n) : C}\\[1em] +% Constructor inference. +\rlbl{ctor-2}& +\inference{\Gamma|- t_1 : A \quad \Gamma |- \rctor{t_2,\dots,t_n}{B[x/t_1]}{C}} + {\Gamma |- \rctor{t_1,\dots,t_n}{\Piexpr{x}{A}{B}}{C}}\\[1em] +\rlbl{ctor-3}& +\inference{}{\Gamma |- \rctor{\epsilon}{B}{B}}\\[1em] +\end{array} +\end{gather*} + +\end{document} diff --git a/saw-core/prelude/Prelude.sawcore b/saw-core/prelude/Prelude.sawcore new file mode 100644 index 0000000000..84086c1e58 --- /dev/null +++ b/saw-core/prelude/Prelude.sawcore @@ -0,0 +1,1866 @@ +-- Copyright : Galois, Inc. 2012-2014 +-- License : BSD3 +-- Maintainer : jhendrix@galois.com + +module Prelude where + +-- Grammar for the core prelude types. +-- +-- We use single colons ":" to represent the type constraint on the core symbols. +-- e.g., "Bool : sort 0" indicates "Bool" has type "sort 0". +-- Functions use "->" to separate arguments from result. +-- e.g., "f : Bool -> Bool -> Bool" indicates "f" is a binary operation on Booleans. + + +id : (a : sort 0) -> a -> a; +id _ x = x; + +-- FIXME: We eventually need to remove this, as it violates soundness... +primitive fix : (a : sort 0) -> (a -> a) -> a; + + +-- FIXME: below are some defined data-types that could be used in place of +-- the SAW primitive types + +-------------------------------------------------------------------------------- +-- The Unit type + +data UnitType : sort 0 where { + Unit : UnitType; + } + +-- The recursor for the Unit type at sort 0 +-- UnitType__rec : (p : UnitType -> sort 0) -> p Unit -> (u : UnitType) -> p u; +-- UnitType__rec p f1 u = UnitType#rec p f1 u; +UnitType__rec (p : UnitType -> sort 0) (f1 : p Unit) (u : UnitType) : p u + = UnitType#rec p f1 u; + +-------------------------------------------------------------------------------- +-- Pair types + +data PairType (a b : sort 0) : sort 0 where { + PairValue : a -> b -> PairType a b; +} + +pair_example : (a b : sort 0) -> a -> b -> PairType a b; +pair_example a b x y = PairValue a b x y; + +-- The recursor for primitive pair types at sort 1 +Pair__rec + (a b : sort 0) + (p : PairType a b -> sort 0) + (f : (x:a) -> (y:b) -> p (PairValue a b x y)) + (pair : PairType a b) + : p pair + = PairType#rec a b p f pair; + +Pair_fst : (a b : sort 0) -> PairType a b -> a; +Pair_fst a b = Pair__rec a b (\ (p:PairType a b) -> a) + (\ (x:a) -> \ (y: b) -> x); + +Pair_snd : (a b : sort 0) -> PairType a b -> b; +Pair_snd a b = Pair__rec a b (\ (p:PairType a b) -> b) + (\ (x:a) -> \ (y:b) -> y); + +fst : (a b : sort 0) -> a * b -> a; +fst a b tup = tup.(1); + +snd : (a b : sort 0) -> a * b -> b; +snd a b tup = tup.(2); + +uncurry (a b c : sort 0) (f : a -> b -> c) : a * b -> c + = (\ (x : a * b) -> f x.(1) x.(2)); + +-------------------------------------------------------------------------------- +-- String values + +primitive String : sort 0; + +primitive error : (a : sort 1) -> String -> a; + + +-------------------------------------------------------------------------------- +-- Record types + +-- The empty record +data EmptyType : sort 0 where { + Empty : EmptyType; +} + +-- The recursor for the empty type at sort 0 +EmptyType__rec : (p : EmptyType -> sort 0) -> p Empty -> + (emp : EmptyType) -> p emp; +EmptyType__rec p f1 emp = EmptyType#rec p f1 emp; + +-- Add a named field to a record type +data RecordType (s:String) (a b :sort 0) : sort 0 where { + RecordValue : a -> b -> RecordType s a b; +} + +-- The recursor for record types at sort 0 +RecordType__rec + (s : String) + (a b :sort 0) + (p : RecordType s a b -> sort 1) + (f1 : (x:a) -> (y:b) -> p (RecordValue s a b x y)) + (r : RecordType s a b) + : p r + = RecordType#rec s a b p f1 r; + + +-------------------------------------------------------------------------------- +-- Equality proofs. + +data Eq (t : sort 1) (x : t) : t -> Prop where { + Refl : Eq t x x; + } + + +-- The eliminator for the Eq type at sort 1, assuming the usual parameter-index +-- structure of the Eq type +Eq__rec : (t : sort 1) -> (x : t) -> (p : (y : t) -> Eq t x y -> sort 1) -> + p x (Refl t x) -> (y : t) -> (pf : Eq t x y) -> p y pf; +Eq__rec t x p f1 y pf = Eq#rec t x p f1 y pf; + +-- Congruence closure for equality +eq_cong : (t : sort 1) -> (x : t) -> (y : t) -> Eq t x y -> + (u : sort 1) -> (f : t -> u) -> Eq u (f x) (f y); +eq_cong t x y eq u f = + Eq__rec t x (\ (y':t) -> \ (eq':Eq t x y') -> Eq u (f x) (f y')) + (Refl u (f x)) y eq; + +sym : (a : sort 1) -> (x y : a) -> Eq a x y -> Eq a y x; +sym a x y eq = + Eq__rec a x (\ (y':a) -> \ (eq':Eq a x y') -> Eq a y' x) (Refl a x) y eq; + +trans : (a : sort 1) -> (x y z : a) -> Eq a x y -> Eq a y z -> Eq a x z; +trans a x y z eq1 eq2 = + Eq__rec a y (\ (y':a) -> \ (eq':Eq a y y') -> Eq a x y') eq1 z eq2; + +trans2 : (a : sort 1) -> (x y z : a) -> Eq a x z -> Eq a y z -> Eq a x y; +trans2 a x y z eq1 eq2 = trans a x z y eq1 (sym a y z eq2); + +trans4 : (a : sort 1) -> (w x y z : a) -> + Eq a w x -> Eq a x y -> Eq a y z -> Eq a w z; +trans4 a w x y z eq1 eq2 eq3 = + trans a w x z eq1 (trans a x y z eq2 eq3); + +eq_inv_map : (a b : sort 1) -> (a1 a2 : a) -> Eq a a1 a2 -> + (f1 f2 : a -> b) -> Eq b (f1 a2) (f2 a2) -> + Eq b (f1 a1) (f2 a1); +eq_inv_map a b a1 a2 eq_a f1 f2 eq_f = + trans + b (f1 a1) (f1 a2) (f2 a1) + (eq_cong a a1 a2 eq_a b f1) + (trans b (f1 a2) (f2 a2) (f2 a1) eq_f + (eq_cong a a2 a1 (sym a a1 a2 eq_a) b f2)); + +-- Unchecked assertion that two types are equal. +axiom unsafeAssert : (a : sort 1) -> (x : a) -> (y : a) -> Eq a x y; + + +primitive coerce : (a b : sort 0) -> Eq (sort 0) a b -> a -> b; + +coerce__def : (a b : sort 0) -> Eq (sort 0) a b -> a -> b; +coerce__def a b eq x = + Eq__rec (sort 0) a (\ (b':sort 0) -> \ (eq':Eq (sort 0) a b') -> b') x b eq; + +axiom coerce__eq : + Eq ((a b : sort 0) -> Eq (sort 0) a b -> a -> b) coerce coerce__def; + + +-- NOTE: this is equivalent to UIP / Axiom K +{- +coerce_same : (a : sort 0) -> (q : Eq (sort 0) a a) -> (x : a) -> Eq a (coerce a a q x) x; +coerce_same a (Refl _ _) x = Refl a x; +-} + +rcoerce : (a b : sort 0) -> Eq (sort 0) a b -> b -> a; +rcoerce a b q = coerce b a (sym (sort 0) a b q); + +-- NOTE: this is equivalent to UIP / Axiom K +{- +rcoerce_same : (a : sort 0) -> (q : Eq (sort 0) a a) -> (x : a) -> Eq a (rcoerce a a q x) x; +rcoerce_same a q x = coerce_same a (sym (sort 0) a a q) x; +-} + +unsafeCoerce : (a b : sort 0) -> a -> b; +unsafeCoerce a b = coerce a b (unsafeAssert (sort 0) a b); + +axiom unsafeCoerce_same : (a : sort 0) -> (x : a) -> + Eq a (unsafeCoerce a a x) x; + +-- NOTE: We could prove unsafeCoerce_same if we were willing to allow UIP... +{- +unsafeCoerce_same : (a : sort 0) -> (x : a) -> Eq a (unsafeCoerce a a x) x; +unsafeCoerce_same a x = coerce_same a (unsafeAssert (sort 0) a a) x; +-} + +piCong0 : (r x y : sort 0) -> Eq (sort 0) x y -> (Eq (sort 0) (x -> r) (y -> r)); +piCong0 r x y eq = + Eq__rec + (sort 0) x + (\ (y': sort 0) -> \ (eq': Eq (sort 0) x y') -> + Eq (sort 0) (x -> r) (y' -> r)) + (Refl (sort 0) (x -> r)) y eq; + +piCong1 : (r x y : sort 0) -> Eq (sort 0) x y -> (Eq (sort 0) (r -> x) (r -> y)); +piCong1 r x y eq = + Eq__rec + (sort 0) x + (\ (y': sort 0) -> \ (eq': Eq (sort 0) x y') -> + Eq (sort 0) (r -> x) (r -> y')) + (Refl (sort 0) (r -> x)) y eq; + + +-------------------------------------------------------------------------------- +-- Bits + +data Bit : sort 0 where { + Bit1 : Bit; + Bit0 : Bit; + } + +Bit__rec : (p : Bit -> sort 1) -> (p Bit1) -> (p Bit0) -> (b:Bit) -> p b; +Bit__rec p f1 f2 b = Bit#rec p f1 f2 b; + + +-------------------------------------------------------------------------------- +-- Booleans + +-- Boolean is a primitive type, because it is handled specially by some of the +-- back-ends (e.g., the SAT/SMT solvers) +primitive Bool : sort 0; +primitive True : Bool; +primitive False : Bool; + +-- Elimination form for Bool is dependent if-then-else. This is exactly the same +-- as the recursor for Bit, but it is declared as a primitive because Bool is. +-- It also rearranges the arguments to look more like normal if-then-else. +primitive iteDep : (p : Bool -> sort 1) -> (b:Bool) -> + p True -> p False -> p b; + +-- Reduction rules for iteDep +axiom iteDep_True : (p : Bool -> sort 1) -> (f1:p True) -> (f2:p False) -> + Eq (p True) (iteDep p True f1 f2) f1; +axiom iteDep_False : (p : Bool -> sort 1) -> (f1:p True) -> (f2:p False) -> + Eq (p False) (iteDep p False f1 f2) f2; + +-- Non-dependent if-then-else; this is a primitive because it is handled +-- specially by some of the back-ends (e.g., the SAT/SMT solvers) +primitive ite : (a : sort 1) -> Bool -> a -> a -> a; + +-- ite should be the same as iteDep +axiom ite_eq_iteDep : (a:sort 1) -> (b:Bool) -> (x y:a) -> + Eq a (ite a b x y) (iteDep (\ (_:Bool) -> a) b x y); + +ite_true (a : sort 1) (x y : a) : Eq a (ite a True x y) x = + trans a (ite a True x y) (iteDep (\ (b:Bool) -> a) True x y) x + (ite_eq_iteDep a True x y) (iteDep_True (\ (_:Bool) -> a) x y); + +ite_false (a : sort 1) (x y : a) : Eq a (ite a False x y) y = + trans a (ite a False x y) (iteDep (\ (b:Bool) -> a) False x y) y + (ite_eq_iteDep a False x y) (iteDep_False (\ (_:Bool) -> a) x y); + +-- +-- Converting between Bools and Bits (cause why not?) +-- + +bool2bit : Bool -> Bit; +bool2bit b = iteDep (\ (_:Bool) -> Bit) b Bit1 Bit0; + +bool2bit_True : Eq Bit (bool2bit True) Bit1; +bool2bit_True = iteDep_True (\ (_:Bool) -> Bit) Bit1 Bit0; + +bool2bit_False : Eq Bit (bool2bit False) Bit0; +bool2bit_False = iteDep_False (\ (_:Bool) -> Bit) Bit1 Bit0; + +bit2bool : Bit -> Bool; +bit2bool = Bit__rec (\ (_:Bit) -> Bool) True False; + +bit2bool_Bit1 : Eq Bool (bit2bool Bit1) True; +bit2bool_Bit1 = Refl Bool True; + +bit2bool_Bit0 : Eq Bool (bit2bool Bit0) False; +bit2bool_Bit0 = Refl Bool False; + + +-- +-- The Boolean operations +-- + +primitive not : Bool -> Bool; +axiom not__eq : (b:Bool) -> Eq Bool (not b) (ite Bool b False True); + +primitive and : Bool -> Bool -> Bool; +axiom and__eq : (b1 b2:Bool) -> Eq Bool (and b1 b2) (ite Bool b1 b2 False); + +primitive or : Bool -> Bool -> Bool; +axiom or__eq : (b1 b2:Bool) -> Eq Bool (or b1 b2) (ite Bool b1 True b2); + +primitive xor : Bool -> Bool -> Bool; +axiom xor__eq : (b1 b2:Bool) -> + Eq Bool (xor b1 b2) (ite Bool b1 (not b2) b2); + +-- Decidable Boolean equality, also known as iff +primitive boolEq : Bool -> Bool -> Bool; +axiom boolEq__eq : (b1 b2:Bool) -> + Eq Bool (boolEq b1 b2) (ite Bool b1 b2 (not b2)); + +-- Implies is not a primitive, as it is not mapped by any of the simulator +-- back-ends; instead, it is just defined in terms of or and not +implies : Bool -> Bool -> Bool; +implies = \ (a:Bool) (b:Bool) -> or (not a) b; + +-- FIXME: this rule should be derived by scDefRewriteRules +implies__eq : (a b:Bool) -> Eq Bool (implies a b) (or (not a) b); +implies__eq a b = Refl Bool (implies a b); + + + +unitEq : UnitType -> UnitType -> Bool; +unitEq _ _ = True; + +pairEq : (a b : sort 0) -> (a -> a -> Bool) -> (b -> b -> Bool) -> a * b -> a * b -> Bool; +pairEq a b f g x y = and ( f x.(1) y.(1) ) ( g x.(2) y.(2) ); + + +-- +-- Rewrite rules for booleans +-- + +not_True : Eq Bool (not True) False; +not_True = + trans Bool (not True) (ite Bool True False True) False + (not__eq True) (ite_true Bool False True); + +not_False : Eq Bool (not False) True; +not_False = + trans Bool (not False) (ite Bool False False True) True + (not__eq False) (ite_false Bool False True); + +not_not (x : Bool) : Eq Bool (not (not x)) x = + iteDep (\ (b:Bool) -> Eq Bool (not (not b)) b) x + (trans Bool (not (not True)) (not False) True + (eq_cong Bool (not True) False not_True Bool not) + not_False) + (trans Bool (not (not False)) (not True) False + (eq_cong Bool (not False) True not_False Bool not) + not_True); + + +and_True1 (x : Bool) : Eq Bool (and True x) x = + trans Bool (and True x) (ite Bool True x False) x + (and__eq True x) (ite_true Bool x False); + +and_False1 (x : Bool) : Eq Bool (and False x) False = + trans Bool (and False x) (ite Bool False x False) False + (and__eq False x) (ite_false Bool x False); + +and_True2 (x : Bool) : Eq Bool (and x True) x = + iteDep (\ (b:Bool) -> Eq Bool (and b True) b) x + (and_True1 True) (and_False1 True); + +and_False2 (x : Bool) : Eq Bool (and x False) False = + iteDep (\ (b:Bool) -> Eq Bool (and b False) False) x + (and_True1 False) (and_False1 False); + +and_assoc (x y z : Bool) : Eq Bool (and x (and y z)) (and (and x y) z) = + iteDep (\ (b:Bool) -> Eq Bool (and x (and y b)) (and (and x y) b)) z + (trans2 Bool (and x (and y True)) (and (and x y) True) (and x y) + (eq_cong Bool (and y True) y (and_True2 y) Bool (and x)) + (and_True2 (and x y))) + (trans2 Bool (and x (and y False)) (and (and x y) False) False + (trans Bool (and x (and y False)) (and x False) False + (eq_cong Bool (and y False) False (and_False2 y) Bool (and x)) + (and_False2 x)) + (and_False2 (and x y))); + +and_idem (x : Bool) : Eq Bool (and x x) x = + iteDep (\ (b:Bool) -> Eq Bool (and b b) b) x + (and_True1 True) (and_False1 False); + + +or_True1 (x : Bool) : Eq Bool (or True x) True = + trans Bool (or True x) (ite Bool True True x) True + (or__eq True x) (ite_true Bool True x); + +or_False1 (x : Bool) : Eq Bool (or False x) x = + trans Bool (or False x) (ite Bool False True x) x + (or__eq False x) (ite_false Bool True x); + +or_True2 (x : Bool) : Eq Bool (or x True) True = + iteDep (\ (b:Bool) -> Eq Bool (or b True) True) x + (or_True1 True) (or_False1 True); + +or_False2 (x : Bool) : Eq Bool (or x False) x = + iteDep (\ (b:Bool) -> Eq Bool (or b False) b) x + (or_True1 False) (or_False1 False); + +or_assoc (x y z : Bool) : Eq Bool (or x (or y z)) (or (or x y) z) = + iteDep (\ (b:Bool) -> Eq Bool (or x (or y b)) (or (or x y) b)) z + (trans2 Bool (or x (or y True)) (or (or x y) True) True + (trans Bool (or x (or y True)) (or x True) True + (eq_cong Bool (or y True) True (or_True2 y) Bool (or x)) + (or_True2 x)) + (or_True2 (or x y))) + (trans2 Bool (or x (or y False)) (or (or x y) False) (or x y) + (eq_cong Bool (or y False) y (or_False2 y) Bool (or x)) + (or_False2 (or x y))); + +or_idem (x : Bool) : Eq Bool (or x x) x = + iteDep (\ (b:Bool) -> Eq Bool (or b b) b) x + (or_True1 True) (or_False1 False); + + +implies_True1 (x : Bool) : Eq Bool (implies True x) x = + trans + Bool (or (not True) x) (or False x) x + (eq_cong Bool (not True) False not_True + Bool (\ (y:Bool) -> or y x)) + (or_False1 x); + +implies_False1 (x : Bool) : Eq Bool (implies False x) True = + trans + Bool (or (not False) x) (or True x) True + (eq_cong Bool (not False) True not_False + Bool (\ (y:Bool) -> or y x)) + (or_True1 x); + +-- Legacy name +true_implies (x : Bool) : Eq Bool (implies True x) x = implies_True1 x; + +xor_True1 (x : Bool) : Eq Bool (xor True x) (not x) = + trans Bool (xor True x) (ite Bool True (not x) x) (not x) + (xor__eq True x) (ite_true Bool (not x) x); + +xor_False1 (x : Bool) : Eq Bool (xor False x) x = + trans Bool (xor False x) (ite Bool False (not x) x) x + (xor__eq False x) (ite_false Bool (not x) x); + +xor_False2 (x : Bool) : Eq Bool (xor x False) x = + iteDep (\ (b:Bool) -> Eq Bool (xor b False) b) x + (trans Bool (xor True False) (not False) True (xor_True1 False) not_False) + (xor_False1 False); + +xor_True2 (x : Bool) : Eq Bool (xor x True) (not x) = + iteDep (\ (b:Bool) -> Eq Bool (xor b True) (not b)) x + (xor_True1 True) + (trans2 Bool (xor False True) (not False) True (xor_False1 True) not_False); + +xor_same (x : Bool) : Eq Bool (xor x x) False = + iteDep (\ (b:Bool) -> Eq Bool (xor b b) False) x + (trans Bool (xor True True) (not True) False (xor_True1 True) not_True) + (xor_False1 False); + +boolEq_True1 (x : Bool) : Eq Bool (boolEq True x) x = + trans Bool (boolEq True x) (ite Bool True x (not x)) x + (boolEq__eq True x) (ite_true Bool x (not x)); + +boolEq_False1 (x : Bool) : Eq Bool (boolEq False x) (not x) = + trans Bool (boolEq False x) (ite Bool False x (not x)) (not x) + (boolEq__eq False x) (ite_false Bool x (not x)); + +boolEq_True2 (x : Bool) : Eq Bool (boolEq x True) x = + iteDep (\ (b:Bool) -> Eq Bool (boolEq b True) b) x + (boolEq_True1 True) + (trans Bool (boolEq False True) (not True) False (boolEq_False1 True) not_True); + +boolEq_False2 (x : Bool) : Eq Bool (boolEq x False) (not x) = + iteDep (\ (b:Bool) -> Eq Bool (boolEq b False) (not b)) x + (trans2 Bool (boolEq True False) (not True) False (boolEq_True1 False) not_True) + (boolEq_False1 False); + +boolEq_same (x : Bool) : Eq Bool (boolEq x x) True = + iteDep (\ (b:Bool) -> Eq Bool (boolEq b b) True) x + (boolEq_True1 True) + (trans Bool (boolEq False False) (not False) True (boolEq_False1 False) not_False); + +not_or (x y : Bool) : Eq Bool (not (or x y)) (and (not x) (not y)) = + iteDep (\ (b:Bool) -> Eq Bool (not (or b y)) (and (not b) (not y))) + x + (trans Bool (not (or True y)) False (and (not True) (not y)) + (trans Bool (not (or True y)) (not True) False + (eq_cong Bool (or True y) True (or_True1 y) + Bool not) + not_True) + (trans Bool False (and False (not y)) (and (not True) (not y)) + (sym Bool (and False (not y)) False (and_False1 (not y))) + (eq_cong Bool False (not True) + (sym Bool (not True) False not_True) + Bool (\ (z:Bool) -> (and z (not y)))))) + (trans Bool (not (or False y)) (not y) (and (not False) (not y)) + (eq_cong Bool (or False y) y (or_False1 y) Bool not) + (sym Bool (and (not False) (not y)) (not y) + (trans Bool (and (not False) (not y)) (and True (not y)) + (not y) + (eq_cong Bool (not False) True not_False Bool + (\ (z:Bool) -> (and z (not y)))) + (and_True1 (not y))))); + +not_and (x y : Bool) + : Eq Bool (not (and x y)) (or (not x) (not y)) = + iteDep (\ (b:Bool) -> Eq Bool (not (and b y)) (or (not b) (not y))) + x + (trans Bool (not (and True y)) (not y) (or (not True) (not y)) + (eq_cong Bool (and True y) y (and_True1 y) Bool not) + (sym Bool (or (not True) (not y)) (not y) + (trans Bool (or (not True) (not y)) (or False (not y)) + (not y) + (eq_cong Bool (not True) False not_True Bool + (\ (z:Bool) -> (or z (not y)))) + (or_False1 (not y))))) + (trans Bool (not (and False y)) True (or (not False) (not y)) + (trans Bool (not (and False y)) (not False) True + (eq_cong Bool (and False y) False (and_False1 y) + Bool not) + not_False) + (trans Bool True (or True (not y)) (or (not False) (not y)) + (sym Bool (or True (not y)) True (or_True1 (not y))) + (eq_cong Bool True (not False) + (sym Bool (not False) True not_False) + Bool (\ (z:Bool) -> (or z (not y)))))); + +ite_not (a : sort 1) (b : Bool) (x y : a) + : Eq a (ite a (not b) x y) (ite a b y x) = + iteDep (\ (b':Bool) -> Eq a (ite a (not b') x y) (ite a b' y x)) + b + (trans a (ite a (not True) x y) y (ite a True y x) + (trans a (ite a (not True) x y) (ite a False x y) y + (eq_cong Bool (not True) False not_True a + (\ (z:Bool) -> ite a z x y)) + (ite_false a x y)) + (sym a (ite a True y x) y (ite_true a y x))) + (trans a (ite a (not False) x y) x (ite a False y x) + (trans a (ite a (not False) x y) (ite a True x y) x + (eq_cong Bool (not False) True not_False a + (\ (z:Bool) -> ite a z x y)) + (ite_true a x y)) + (sym a (ite a False y x) x (ite_false a y x))); + +ite_nest1 (a : sort 1) (b : Bool) (x y z : a) + : Eq a (ite a b (ite a b x y) z) (ite a b x z) = + iteDep (\ (b':Bool) -> Eq a (ite a b' (ite a b' x y) z) (ite a b' x z)) + b + (trans a (ite a True (ite a True x y) z) x (ite a True x z) + (trans a (ite a True (ite a True x y) z) (ite a True x y) x + (ite_true a (ite a True x y) z) + (ite_true a x y)) + (sym a (ite a True x z) x (ite_true a x z))) + (trans a (ite a False (ite a False x y) z) z (ite a False x z) + (ite_false a (ite a False x y) z) + (sym a (ite a False x z) z (ite_false a x z))); + +ite_nest2 (a : sort 1) (b : Bool) (x y z : a) + : Eq a (ite a b x (ite a b y z)) (ite a b x z) = + iteDep (\ (b':Bool) -> Eq a (ite a b' x (ite a b' y z)) (ite a b' x z)) + b + (trans a (ite a True x (ite a True y z)) x (ite a True x z) + (ite_true a x (ite a True y z)) + (sym a (ite a True x z) x (ite_true a x z))) + (trans a (ite a False x (ite a False y z)) z (ite a False x z) + (trans a (ite a False x (ite a False y z)) (ite a False y z) z + (ite_false a x (ite a False y z)) + (ite_false a y z)) + (sym a (ite a False x z) z (ite_false a x z))); + +-- This is provable with iteDep on b, but yuck! +axiom ite_bit : (b : Bool) -> (c : Bool) -> (d : Bool) -> + Eq Bool (ite Bool b c d) (and (or (not b) c) (or b d)); + +ite_bit_false_1 (b c : Bool) + : Eq Bool (ite Bool b False c) (and (not b) c) = + iteDep (\ (b':Bool) -> Eq Bool (ite Bool b' False c) (and (not b') c)) b + (trans Bool (ite Bool True False c) False (and (not True) c) + (ite_true Bool False c) + (sym Bool (and (not True) c) False + (trans Bool (and (not True) c) (and False c) False + (eq_cong Bool (not True) False not_True + Bool (\ (z:Bool) -> (and z c))) + (and_False1 c)))) + (trans Bool (ite Bool False False c) c (and (not False) c) + (ite_false Bool False c) + (sym Bool (and (not False) c) c + (trans Bool (and (not False) c) (and True c) c + (eq_cong Bool (not False) True not_False + Bool (\ (z:Bool) -> (and z c))) + (and_True1 c)))); + +ite_bit_true_1 (b c : Bool) : Eq Bool (ite Bool b True c) (or b c) = + iteDep (\ (b':Bool) -> Eq Bool (ite Bool b' True c) (or b' c)) + b + (trans Bool (ite Bool True True c) True (or True c) + (ite_true Bool True c) + (sym Bool (or True c) True (or_True1 c))) + (trans Bool (ite Bool False True c) c (or False c) + (ite_false Bool True c) + (sym Bool (or False c) c (or_False1 c))); + +ite_fold_not (b : Bool) : Eq Bool (ite Bool b False True) (not b) = + iteDep (\ (b':Bool) -> Eq Bool (ite Bool b' False True) (not b')) + b + (trans Bool (ite Bool True False True) False (not True) + (ite_true Bool False True) + (sym Bool (not True) False not_True)) + (trans Bool (ite Bool False False True) True (not False) + (ite_false Bool False True) + (sym Bool (not False) True not_False)); + +ite_eq (a : sort 1) (b : Bool) (x : a) : Eq a (ite a b x x) x = + iteDep (\ (b':Bool) -> Eq a (ite a b' x x) x) + b (ite_true a x x) (ite_false a x x); + +or_triv1 (x : Bool) : Eq Bool (or x (not x)) True = + iteDep (\ (b:Bool) -> Eq Bool (or b (not b)) True) + x + (or_True1 (not True)) + (trans Bool (or False (not False)) (not False) True + (or_False1 (not False)) not_False); + +or_triv2 (x : Bool) : Eq Bool (or (not x) x) True = + iteDep (\ (b:Bool) -> Eq Bool (or (not b) b) True) + x + (or_True2 (not True)) + (trans Bool (or (not False) False) (not False) True + (or_False2 (not False)) not_False); + +and_triv1 (x : Bool) : Eq Bool (and x (not x)) False = + iteDep (\ (b:Bool) -> Eq Bool (and b (not b)) False) + x + (trans Bool (and True (not True)) (not True) False + (and_True1 (not True)) not_True) + (and_False1 (not False)); + +and_triv2 (x : Bool) : Eq Bool (and (not x) x) False = + iteDep (\ (b:Bool) -> Eq Bool (and (not b) b) False) + x + (trans Bool (and (not True) True) (not True) False + (and_True2 (not True)) not_True) + (and_False2 (not False)); + + +-------------------------------------------------------------------------------- +-- Converting Booleans to Propositions + +EqTrue : Bool -> Prop; +EqTrue x = Eq Bool x True; + +TrueI : EqTrue True; +TrueI = Refl Bool True; + +andI : (x y : Bool) -> EqTrue x -> EqTrue y -> EqTrue (and x y); +andI x y p q = + trans4 Bool (and x y) (and x True) x True + (eq_cong Bool y True q Bool (and x)) (and_True2 x) p; + +impliesI (x y : Bool) : (EqTrue x -> EqTrue y) -> EqTrue (implies x y) = + iteDep (\ (x : Bool) -> (EqTrue x -> EqTrue y) -> EqTrue (implies x y)) x + (\ (H : EqTrue True -> EqTrue y) -> + trans Bool (implies True y) y True (implies_True1 y) (H TrueI)) + (\ (_ : EqTrue False -> EqTrue y) -> implies_False1 y); + + +-------------------------------------------------------------------------------- +-- Either + +data Either (s t : sort 0) : sort 0 where { + Left : s -> Either s t; + Right : t -> Either s t; + } + +Either__rec : (s t : sort 0) -> (p : Either s t -> sort 0) -> + ((l : s) -> p (Left s t l)) -> + ((r : t) -> p (Right s t r)) -> + (e : Either s t) -> p e; +Either__rec s t p f1 f2 e = Either#rec s t p f1 f2 e; + +either : (a b c : sort 0) -> (a -> c) -> (b -> c) -> Either a b -> c; +either a b c f g e = + Either__rec a b (\ (p: Either a b) -> c) f g e; + +eitherCong0 : (t x y : sort 0) -> Eq (sort 0) x y -> + Eq (sort 0) (Either x t) (Either y t); +eitherCong0 t x y eq = + eq_cong (sort 0) x y eq (sort 0) (\ (y':sort 0) -> Either y' t); + +eitherCong1 : (t x y : sort 0) -> Eq (sort 0) x y -> + Eq (sort 0) (Either t x) (Either t y); +eitherCong1 t x y eq = + eq_cong (sort 0) x y eq (sort 0) (\ (y':sort 0) -> Either t y'); + + +-------------------------------------------------------------------------------- +-- Maybe + +data Maybe (a : sort 0) : sort 0 where { + Nothing : Maybe a; + Just : a -> Maybe a; + } + +Maybe__rec : (a : sort 0) -> (p : (Maybe a) -> sort 0) -> + p (Nothing a) -> ((x:a) -> p (Just a x)) -> (m : Maybe a) -> p m; +Maybe__rec a p f1 f2 m = Maybe#rec a p f1 f2 m; + +maybe : (a b : sort 0) -> b -> (a -> b) -> Maybe a -> b; +maybe a b f1 f2 m = Maybe__rec a (\ (m':Maybe a) -> b) f1 f2 m; + + +-------------------------------------------------------------------------------- +-- Nat + +data Nat : sort 0 where { + Zero : Nat; + Succ : Nat -> Nat; + } + +Nat__rec : (p : Nat -> sort 1) -> p Zero -> ((n:Nat) -> p n -> p (Succ n)) -> + (n:Nat) -> p n; +Nat__rec p f1 f2 n = Nat#rec p f1 f2 n; + +Nat_cases : (a:sort 1) -> a -> (Nat -> a -> a) -> Nat -> a; +Nat_cases a f1 f2 n = Nat__rec (\ (n:Nat) -> a) f1 f2 n; + +-- Build a binary function for Nats that satisfies: +-- Nat_cases2 a f1 f2 f3 Zero y = f1 y +-- Nat_cases2 a f1 f2 f3 (Succ x) Zero = f2 x +-- Nat_cases2 a f1 f2 f3 (Succ x) (Succ y) = f3 x y (Nat_cases2 ... x y) +Nat_cases2 : (a:sort 1) -> (Nat -> a) -> (Nat -> a) -> + (Nat -> Nat -> a -> a) -> Nat -> Nat -> a; +Nat_cases2 a f1 f2 f3 n m = + Nat__rec (\ (n:Nat) -> Nat -> a) f1 + (\ (n:Nat) -> \ (f_rec : Nat -> a) -> \ (m:Nat) -> + Nat__rec (\ (m':Nat) -> a) (f2 n) + (\ (m':Nat) -> \ (frec':a) -> f3 n m' (f_rec m')) m) n m; + +eqNat : Nat -> Nat -> sort 1; +eqNat x y = Eq Nat x y; + +eqNatSucc : (x y : Nat) -> eqNat x y -> eqNat (Succ x) (Succ y); +eqNatSucc x y eq = eq_cong Nat x y eq Nat (\ (n:Nat) -> Succ n); + +-- Predecessor +pred : Nat -> Nat; +pred x = Nat_cases Nat Zero (\ (n:Nat) -> \ (m:Nat) -> n) x; + +eqNatPrec : (x y : Nat) -> eqNat (Succ x) (Succ y) -> eqNat x y; +eqNatPrec x y eq' = + eq_cong Nat (Succ x) (Succ y) eq' Nat pred; + +-- | Propositional less than or equal to; defined the same way as in Coq +data IsLeNat (n:Nat) : Nat -> Prop where { + IsLeNat_base : IsLeNat n n; + IsLeNat_succ : (m:Nat) -> IsLeNat n m -> IsLeNat n (Succ m); +} + +-- | m < n is defined as m+1 <= n (as in Coq) +IsLtNat : Nat -> Nat -> Prop; +IsLtNat m n = IsLeNat (Succ m) n; + +-- | Test if m < n or n <= m +-- FIXME: implement this! +primitive natCompareLe : (m n : Nat) -> Either (IsLtNat m n) (IsLeNat n m); + +-- | Test if m = n +-- FIXME: implement this! +primitive proveEqNat : (m n : Nat) -> Maybe (Eq Nat m n); + +-- | Try to prove x <= y (FIXME: implement this from natCompareLe!) +primitive proveLeNat : (x y : Nat) -> Maybe (IsLeNat x y); + +-- | Try to prove x < y +proveLtNat : (x y : Nat) -> Maybe (IsLtNat x y); +proveLtNat x y = proveLeNat (Succ x) y; + + +-- | Addition +addNat : Nat -> Nat -> Nat; +addNat x y = + Nat_cases Nat y (\ (_:Nat) -> \ (prev_sum:Nat) -> Succ prev_sum) x; + +eqNatAdd0 (x : Nat) : eqNat (addNat x 0) x = + Nat__rec (\ (n:Nat) -> eqNat (addNat n 0) n) + (Refl Nat 0) + (\ (n:Nat) -> eqNatSucc (addNat n 0) n) + x; + +eqNatAddS (x y : Nat) : eqNat (addNat x (Succ y)) (Succ (addNat x y)) = + Nat__rec (\ (x':Nat) -> (y':Nat) -> + eqNat (addNat x' (Succ y')) (Succ (addNat x' y'))) + (\ (y':Nat) -> Refl Nat (Succ y')) + (\ (x':Nat) -> + \ (eqF : (y':Nat) -> + eqNat (addNat x' (Succ y')) (Succ (addNat x' y'))) -> + \ (y':Nat) -> + eqNatSucc (addNat x' (Succ y')) (Succ (addNat x' y')) (eqF y')) + x y; + +eqNatAddComm (x y : Nat) : eqNat (addNat x y) (addNat y x) = + Nat__rec (\ (y':Nat) -> (x':Nat) -> eqNat (addNat x' y') (addNat y' x')) + (\ (x':Nat) -> eqNatAdd0 x') + (\ (y':Nat) -> + \ (eqF : (x':Nat) -> eqNat (addNat x' y') (addNat y' x')) -> + \ (x':Nat) -> + trans Nat + (addNat x' (Succ y')) + (Succ (addNat x' y')) + (Succ (addNat y' x')) + (eqNatAddS x' y') + (eqNatSucc (addNat x' y') (addNat y' x') (eqF x'))) + y x; + +addNat_assoc (x y z : Nat) : eqNat (addNat x (addNat y z)) (addNat (addNat x y) z) = + Nat__rec (\ (x':Nat) -> eqNat (addNat x' (addNat y z)) (addNat (addNat x' y) z)) + (Refl Nat (addNat y z)) + (\ (x':Nat) -> + \ (eq : eqNat (addNat x' (addNat y z)) (addNat (addNat x' y) z)) -> + eqNatSucc (addNat x' (addNat y z)) (addNat (addNat x' y) z) eq) + x; + +-- | Multiplication +mulNat : Nat -> Nat -> Nat; +mulNat x y = + Nat__rec (\ (x':Nat) -> Nat) 0 + (\ (x':Nat) -> \ (prod:Nat) -> addNat y prod) x; + +equal0Nat : Nat -> Bool; +equal0Nat n = + Nat_cases Bool True (\ (n:Nat) -> \ (b:Bool) -> False) n; + +equalNat : Nat -> Nat -> Bool; +equalNat x y = + Nat_cases (Nat -> Bool) equal0Nat + (\ (n':Nat) -> \ (eqN : Nat -> Bool) -> \ (m:Nat) -> + Nat_cases Bool False + (\ (m':Nat) -> \ (b:Bool) -> eqN m') m) x y; + +ltNat : Nat -> Nat -> Bool; +ltNat x y = + Nat_cases2 Bool (\ (x':Nat) -> False) + (\ (y':Nat) -> True) + (\ (y':Nat) -> \ (x':Nat) -> \ (lt_mn:Bool) -> lt_mn) y x; + +-- | Subtraction +subNat : Nat -> Nat -> Nat; +subNat x y = + Nat_cases2 Nat (\ (x':Nat) -> x') + (\ (y':Nat) -> Zero) + (\ (y':Nat) -> \ (x':Nat) -> \ (sub_xy:Nat) -> sub_xy) y x; + +-- | Minimum +minNat : Nat -> Nat -> Nat; +minNat x y = + Nat_cases2 Nat (\ (y':Nat) -> Zero) + (\ (x':Nat) -> Zero) + (\ (x':Nat) -> \ (y':Nat) -> \ (min_xy:Nat) -> Succ min_xy) x y; + +-- | Maximum +maxNat : Nat -> Nat -> Nat; +maxNat x y = + Nat_cases2 Nat (\ (x':Nat) -> x') + (\ (y':Nat) -> Succ y') + (\ (y':Nat) -> \ (x':Nat) -> \ (sub_xy:Nat) -> sub_xy) y x; + +-- | Width(n) = 1 + floor(log_2(n)) +primitive widthNat : Nat -> Nat; + +-- | Natural exponentiation +expNat : Nat -> Nat -> Nat; +expNat b e = + Nat_cases Nat 1 (\ (e':Nat) -> \ (exp_b_e:Nat) -> mulNat b exp_b_e) e; + +-- | Natural division and modulus +primitive divModNat : Nat -> Nat -> Nat * Nat; + +divNat : Nat -> Nat -> Nat; +divNat x y = (divModNat x y).(1); + +modNat : Nat -> Nat -> Nat; +modNat x y = (divModNat x y).(2); + +-- There are implicit constructors from integer literals. + +-- Dependent, non-recursive pattern matching combinator for natural numbers +natCase : (p : Nat -> sort 0) -> p Zero -> ((n : Nat) -> p (Succ n)) -> + (n : Nat) -> p n; +natCase p z s = Nat__rec p z (\ (n:Nat) -> \ (r:p n) -> s n); + +-- An if-then-else for whether a Nat = 0 +if0Nat : (a : sort 0) -> Nat -> a -> a -> a; +if0Nat a n x y = natCase (\ (_:Nat) -> a) x (\ (_:Nat) -> y) n; + +-- An exponentation operation on arbitrary types. +-- +-- The arguments are: the 1 value for a; +-- the multiplication operation, the base of the exponent +-- and the number of times to multiply. +primitive expByNat : (a:sort 0) -> a -> (a -> a -> a) -> a -> Nat -> a; + +-------------------------------------------------------------------------------- +-- "Vec n a" is an array of n elements, each with type "a". +primitive Vec : Nat -> sort 0 -> sort 0; + +-- Primitive function for generating an array. +primitive gen : (n : Nat) -> (a : sort 0) -> (Nat -> a) -> Vec n a; + +primitive atWithDefault : (n : Nat) -> (a : sort 0) -> a -> Vec n a -> Nat -> a; + +at : (n : Nat) -> (a : sort 0) -> Vec n a -> Nat -> a; +at n a v i = atWithDefault n a (error a "at: index out of bounds") v i; +-- `at n a v i` has the precondition `ltNat i n` + +primitive EmptyVec : (a : sort 0) -> Vec 0 a; + +ConsVec : (a : sort 0) -> a -> (n : Nat) -> Vec n a -> Vec (Succ n) a; +ConsVec a x n v = + gen (Succ n) a (Nat_cases a x (\ (i:Nat) -> \ (a':a) -> at n a v i)); + +upd : (n : Nat) -> (a : sort 0) -> Vec n a -> Nat -> a -> Vec n a; +upd n a v j x = gen n a (\ (i : Nat) -> ite a (equalNat i j) x (at n a v i)); +-- TODO: assertion that j < n + +-- | Defines a function that maps array elements from one range to another. +map : (a b : sort 0) -> (a -> b) -> (n : Nat) -> Vec n a -> Vec n b; +map a b f n v = gen n b (\ (i : Nat) -> f (at n a v i)); + +-- | Defines a function that maps array elements from one range to another. +zipWith : (a b c : sort 0) + -> (a -> b -> c) + -> (n : Nat) -> Vec n a -> Vec n b -> Vec n c; +zipWith a b c f n x y = gen n c (\ (i : Nat) -> f (at n a x i) (at n b y i)); + +-- replicate n x returns an array with n copies of x. +replicate : (n : Nat) -> (a : sort 0) -> a -> Vec n a; +replicate n a x = gen n a (\ (_ : Nat) -> x); + +-- | Create a vector of length 1. +single : (a : sort 0) -> a -> Vec 1 a; +single = replicate 1; + +axiom at_single : (a : sort 0) -> (x : a) -> (i : Nat) -> Eq a (at 1 a (single a x) i) x; + +-- Zip together two lists (truncating the longer of the two). +primitive zip : (a b : sort 0) -> (m n : Nat) -> Vec m a -> Vec n b -> Vec (minNat m n) (a * b); + +primitive foldr : (a b : sort 0) -> (n : Nat) -> (a -> b -> b) -> b -> Vec n a -> b; + +reverse : (n : Nat) -> (a : sort 0) -> Vec n a -> Vec n a; +reverse n a xs = gen n a (\ (i : Nat) -> at n a xs (subNat (subNat n 1) i)); + +transpose : (m n : Nat) -> (a : sort 0) -> Vec m (Vec n a) -> Vec n (Vec m a); +transpose m n a xss = + gen n (Vec m a) (\ (j : Nat) -> + gen m a (\ (i : Nat) -> at n a (at m (Vec n a) xss i) j)); + +-- | Return true if two vectors are equal, given a comparison function +-- for elements. +vecEq : (n : Nat) -> (a : sort 0) -> (a -> a -> Bool) + -> Vec n a -> Vec n a -> Bool; +vecEq n a eqFn x y = + foldr Bool Bool n and True (zipWith a a Bool eqFn n x y); + +-- | Take a prefix of a vector. +take : (a : sort 0) -> (m n : Nat) -> Vec (addNat m n) a -> Vec m a; +take a m n v = gen m a (\ (i : Nat) -> at (addNat m n) a v i); + +vecCong : (a : sort 0) -> (m n : Nat) -> Eq Nat m n -> + Eq (sort 0) (Vec m a) (Vec n a); +vecCong a m n eq = eq_cong Nat m n eq (sort 0) (\ (i:Nat) -> Vec i a); + +coerceVec : (a : sort 0) -> (m n : Nat) -> Eq Nat m n -> Vec m a -> Vec n a; +coerceVec a m n q = coerce (Vec m a) (Vec n a) (vecCong a m n q); + +-- | Simplify take all elements from a vector. +axiom take0 : (a : sort 0) + -> (m : Nat) + -> (v : Vec (addNat m 0) a) + -> Eq (Vec m a) + (take a m 0 v) + (coerceVec a (addNat m 0) m (eqNatAdd0 m) v); + +-- | Returns a suffix of a vector after a given number of elements. +drop : (a : sort 0) -> (m n : Nat) -> Vec (addNat m n) a -> Vec n a; +drop a m n v = gen n a (\ (i : Nat) -> at (addNat m n) a v (addNat m i)); + +-- | Simplify drop 0-elements from a vector. +axiom drop0 : (a : sort 0) + -> (n : Nat) + -> (v : Vec (addNat 0 n) a) + -> Eq (Vec n a) (drop a 0 n v) v; + +-- | Select a range [i,..,i+n] of values from the array. +slice : (a : sort 0) + -> (m n o : Nat) + -> Vec (addNat (addNat m n) o) a -> Vec n a; +slice a m n o v = drop a m n (take a (addNat m n) o v); + +-- Concatenate arrays together. +join : (m n : Nat) + -> (a : sort 0) + -> Vec m (Vec n a) + -> Vec (mulNat m n) a; +join m n a v = + gen (mulNat m n) a (\ (i : Nat) -> + at n a (at m (Vec n a) v (divNat i n)) (modNat i n)); + +-- Split array into list +split : (m n : Nat) -> (a : sort 0) -> Vec (mulNat m n) a -> Vec m (Vec n a); +split m n a v = + gen m (Vec n a) (\ (i : Nat) -> + gen n a (\ (j : Nat) -> + at (mulNat m n) a v (addNat (mulNat i n) j))); + +-- Append two arrays together. +append : (m n : Nat) -> (a : sort 0) -> Vec m a -> Vec n a -> Vec (addNat m n) a; +append m n a x y = + gen (addNat m n) a + (\ (i : Nat) -> + ite a (ltNat i m) (at m a x i) (at n a y (subNat i m))); + +-- Rotate array to the left. +primitive rotateL : (n : Nat) -> (a : sort 0) -> Vec n a -> Nat -> Vec n a; +-- rotateL n a v i = gen n a (\ (j:Nat) -> at n a v (modNat (addNat i j) n)); + +-- Rotate array to the right. +primitive rotateR : (n : Nat) -> (a : sort 0) -> Vec n a -> Nat -> Vec n a; +-- rotateR n a v i = gen n a (\ (j:Nat) -> at n a v (modNat (addNat (subNat n i) j) n)); + +-- Shift array to the left. +primitive shiftL : (n : Nat) -> (a : sort 0) -> a -> Vec n a -> Nat -> Vec n a; + +-- Shift array to the right. +primitive shiftR : (n : Nat) -> (a : sort 0) -> a -> Vec n a -> Nat -> Vec n a; + +joinLittleEndian : (m n : Nat) + -> (a : sort 0) + -> Vec m (Vec n a) + -> Vec (mulNat m n) a; +joinLittleEndian m n a v = join m n a (reverse m (Vec n a) v); + +splitLittleEndian : (m n : Nat) + -> (a : sort 0) + -> Vec (mulNat m n) a + -> Vec m (Vec n a); +splitLittleEndian m n a v = reverse m (Vec n a) (split m n a v); + +-------------------------------------------------------------------------------- +-- Bitvectors + +-- Bitvector operations expect the most-significant bit first. + +-- | Returns most-significant bit in a signed bitvector. +msb : (n : Nat) -> Vec (Succ n) Bool -> Bool; +msb n v = at (Succ n) Bool v 0; + +-- | Returns least-significant bit in a bitvector. +lsb : (n : Nat) -> Vec (Succ n) Bool -> Bool; +lsb n v = at (Succ n) Bool v n; + +-- | (bvNat n x) yields (x mod 2^n) as an n-bit vector. +primitive bvNat : (n : Nat) -> Nat -> Vec n Bool; + +-- | Satisfies @bvNat n (bvToNat n x) = x@. +primitive bvToNat : (n : Nat) -> Vec n Bool -> Nat; + +bvAt : (n : Nat) -> (a : sort 0) -> (w : Nat) -> Vec n a -> Vec w Bool + -> a; +bvAt n a w xs i = at n a xs (bvToNat w i); + +bvUpd : (n : Nat) -> (a : sort 0) -> (w : Nat) -> Vec n a -> Vec w Bool + -> a -> Vec n a; +bvUpd n a w xs i y = upd n a xs (bvToNat w i) y; + +bvRotateL : (n : Nat) -> (a : sort 0) -> (w : Nat) -> Vec n a -> Vec w Bool -> Vec n a; +bvRotateL n a w xs i = rotateL n a xs (bvToNat w i); + +bvRotateR : (n : Nat) -> (a : sort 0) -> (w : Nat) -> Vec n a -> Vec w Bool -> Vec n a; +bvRotateR n a w xs i = rotateR n a xs (bvToNat w i); + +bvShiftL : (n : Nat) -> (a : sort 0) -> (w : Nat) -> a -> Vec n a -> Vec w Bool -> Vec n a; +bvShiftL n a w z xs i = shiftL n a z xs (bvToNat w i); + +bvShiftR : (n : Nat) -> (a : sort 0) -> (w : Nat) -> a -> Vec n a -> Vec w Bool -> Vec n a; +bvShiftR n a w z xs i = shiftR n a z xs (bvToNat w i); + +primitive bvAdd : (n : Nat) -> Vec n Bool -> Vec n Bool -> Vec n Bool; + +-- | Unsigned and signed comparison functions. +primitive bvugt : (n : Nat) -> Vec n Bool -> Vec n Bool -> Bool; +primitive bvuge : (n : Nat) -> Vec n Bool -> Vec n Bool -> Bool; +primitive bvult : (n : Nat) -> Vec n Bool -> Vec n Bool -> Bool; +primitive bvule : (n : Nat) -> Vec n Bool -> Vec n Bool -> Bool; + +primitive bvsgt : (n : Nat) -> Vec n Bool -> Vec n Bool -> Bool; +primitive bvsge : (n : Nat) -> Vec n Bool -> Vec n Bool -> Bool; +primitive bvslt : (n : Nat) -> Vec n Bool -> Vec n Bool -> Bool; +primitive bvsle : (n : Nat) -> Vec n Bool -> Vec n Bool -> Bool; + +primitive bvPopcount : (n : Nat) -> Vec n Bool -> Vec n Bool; +primitive bvCountLeadingZeros : (n : Nat) -> Vec n Bool -> Vec n Bool; +primitive bvCountTrailingZeros : (n : Nat) -> Vec n Bool -> Vec n Bool; + +-- Universal quantification over bitvectors +primitive bvForall : (n : Nat) -> (Vec n Bool -> Bool) -> Bool; + +bvCarry : (n : Nat) -> Vec n Bool -> Vec n Bool -> Bool; +bvCarry n x y = bvult n (bvAdd n x y) x; + +bvSCarry : (n : Nat) -> Vec (Succ n) Bool -> Vec (Succ n) Bool -> Bool; +bvSCarry n x y = and (boolEq (msb n x) (msb n y)) (xor (msb n x) (msb n (bvAdd (Succ n) x y))); + +bvAddWithCarry : (n : Nat) -> Vec n Bool -> Vec n Bool -> Bool * Vec n Bool; +bvAddWithCarry n x y = (bvCarry n x y, bvAdd n x y); + +axiom bvAddZeroL : (n : Nat) -> (x : Vec n Bool) -> Eq (Vec n Bool) (bvAdd n (bvNat n 0) x) x; +axiom bvAddZeroR : (n : Nat) -> (x : Vec n Bool) -> Eq (Vec n Bool) (bvAdd n x (bvNat n 0)) x; + +primitive bvNeg : (n : Nat) -> Vec n Bool -> Vec n Bool; + +primitive bvSub : (n : Nat) -> Vec n Bool -> Vec n Bool -> Vec n Bool; + +bvSBorrow : (n : Nat) -> Vec (Succ n) Bool -> Vec (Succ n) Bool -> Bool; +bvSBorrow n x y = and (xor (msb n x) (msb n y)) (xor (msb n x) (msb n (bvSub (Succ n) x y))); + +primitive bvMul : (n : Nat) -> Vec n Bool -> Vec n Bool -> Vec n Bool; +primitive bvLg2 : (n : Nat) -> Vec n Bool -> Vec n Bool; + +-- Unsigned division and remainder. +-- +-- When the divisor is 0, bvUDiv returns a vector with all bits set. +-- (Equal to 2^x - 1), and bvURem returns the divident unchanged. +-- +-- These two functions satisfy the property that: +-- bvAdd x (bvMul x (bvUDiv x u v) v) (bvURem x u v) == u +primitive bvUDiv : (n : Nat) -> Vec n Bool -> Vec n Bool -> Vec n Bool; +primitive bvURem : (n : Nat) -> Vec n Bool -> Vec n Bool -> Vec n Bool; + + +-- Signed division. +-- When the divisor is 0, bvSDiv returns 2^x - 1 when the dividend +-- is non-negative, and -1 when the dividend is negative; bvSRem +-- returns the dividend unchanged. +-- +-- Otherwise, the sign of the quotient is the exclusive xor of +-- the sign bit of the dividend and divisor; the remainder is negative +-- if the dividend is negative. + +-- bvSDiv and bvSRem satisfy the property that: +-- +-- bvAdd x (bvMul x (bvSDiv x u v) v) (bvSRem x u v) == u +primitive bvSDiv : (n : Nat) -> Vec (Succ n) Bool -> Vec (Succ n) Bool -> Vec (Succ n) Bool; +primitive bvSRem : (n : Nat) -> Vec (Succ n) Bool -> Vec (Succ n) Bool -> Vec (Succ n) Bool; +--TODO: + +-- | Shift left by the given number of bits. +-- New bits are False. +primitive bvShl : (w : Nat) -> Vec w Bool -> Nat -> Vec w Bool; + +-- Logical right shift. New bits are False. +primitive bvShr : (w : Nat) -> Vec w Bool -> Nat -> Vec w Bool; + +-- | Signed right shift. New bits are equal to most-significant bit. +primitive bvSShr : (w : Nat) -> Vec (Succ w) Bool -> Nat -> Vec (Succ w) Bool; + +axiom bvShiftL_bvShl : + (n : Nat) -> (w : Nat) -> (x : Vec n Bool) -> (i : Vec w Bool) -> + Eq (Vec n Bool) (bvShiftL n Bool w False x i) (bvShl n x (bvToNat w i)); + +axiom bvShiftR_bvShr : + (n : Nat) -> (w : Nat) -> (x : Vec n Bool) -> (i : Vec w Bool) -> + Eq (Vec n Bool) (bvShiftR n Bool w False x i) (bvShr n x (bvToNat w i)); + +-- | Zipwith specialized to bitvectors. +bvZipWith : (Bool -> Bool -> Bool) + -> (n : Nat) + -> Vec n Bool -> Vec n Bool -> Vec n Bool; +bvZipWith = zipWith Bool Bool Bool; + +-- | Bitwise complement. +bvNot : (n : Nat) -> Vec n Bool -> Vec n Bool; +bvNot = map Bool Bool not; + +-- | Pairwise conjunction +bvAnd : (n : Nat) -> Vec n Bool -> Vec n Bool -> Vec n Bool; +bvAnd = bvZipWith and; + +-- | Pairwise disjunction +bvOr : (n : Nat) -> Vec n Bool -> Vec n Bool -> Vec n Bool; +bvOr = bvZipWith or; + +-- | Pairwise exclusive or +bvXor : (n : Nat) -> Vec n Bool -> Vec n Bool -> Vec n Bool; +bvXor = bvZipWith xor; + +-- | Return true if two bitvectors are equal. +bvEq : (n : Nat) -> Vec n Bool -> Vec n Bool -> Bool; +bvEq n x y = vecEq n Bool boolEq x y; + +axiom bvEq_refl : (n : Nat) -> (x : Vec n Bool) -> Eq Bool (bvEq n x x) True; + +axiom equalNat_bv : (n : Nat) -> (x : Vec n Bool) -> (i : Nat) -> + Eq Bool (equalNat i (bvToNat n x)) (bvEq n (bvNat n i) x); + +-- | Returns the bitvector 1 if the boolean is true, +-- and returns 0 otherwise +bvBool : (n : Nat) -> Bool -> Vec n Bool; +bvBool n b = ite (Vec n Bool) b (bvNat n 1) (bvNat n 0); + +-- | Return true if two bitvectors are not equal. +bvNe : (n : Nat) -> Vec n Bool -> Vec n Bool -> Bool; +bvNe n x y = not (bvEq n x y); + +-- | Return true if the bitvector is nonzero +bvNonzero : (n : Nat) -> Vec n Bool -> Bool; +bvNonzero n x = bvNe n x (bvNat n 0); + +-- | Truncates a vector a smaller size. +-- msb implementation: +bvTrunc : (m n : Nat) -> Vec (addNat m n) Bool -> Vec n Bool; +bvTrunc = drop Bool; +-- lsb implementation: +-- bvTrunc : (m n : Nat) -> Vec (addNat n m) Bool -> Vec n Bool; +-- bvTrunc m n = take Bool n m; + +-- | Perform a unsigned extension of the bitvector. +-- @bvUExt m n x@ adds m bits of zeros to the most-significant bits of +-- the n-bit vector x. +-- msb implementation: +bvUExt : (m n : Nat) -> Vec n Bool -> Vec (addNat m n) Bool; +bvUExt m n x = append m n Bool (bvNat m 0) x; +-- lsb implementation: +-- bvUExt : (m n : Nat) -> Vec n Bool -> Vec (addNat n m) Bool; +-- bvUExt m n a = append n m Bool x (bvNat m 0); + +-- | 'replicateBool' is an version of 'replicate' optimized for type Bool. +replicateBool : (n : Nat) -> Bool -> Vec n Bool; +replicateBool n b = ite (Vec n Bool) b (bvNot n (bvNat n 0)) (bvNat n 0); + +-- | Perform a signed extension of the bitvector. +-- msb implementation: +bvSExt : (m n : Nat) -> Vec (Succ n) Bool -> Vec (addNat m (Succ n)) Bool; +bvSExt m n x = append m (Succ n) Bool (replicateBool m (msb n x)) x; +-- lsb implementation: +-- bvSExt : (m n : Nat) -> Vec (Succ n) Bool -> Vec (addNat (Succ n) m) Bool; +-- bvSExt m n x = append (Succ n) m Bool x (replicateBool m (msb n x)); + +-------------------------------------------------------------------------------- +-- Infinite streams + +data Stream (a : sort 0) : sort 0 where { + MkStream : (Nat -> a) -> Stream a; + } + +Stream__rec : (a:sort 0) -> (p:Stream a -> sort 0) -> + ((f:Nat -> a) -> p (MkStream a f)) -> (str:Stream a) -> p str; +Stream__rec a p f1 str = Stream#rec a p f1 str; + +streamUpd : (a : sort 0) -> Stream a -> Nat -> a -> Stream a; +streamUpd a strm i y = + Stream__rec a (\ (strm':Stream a) -> Stream a) + (\ (s:Nat -> a) -> + MkStream a (\ (j : Nat) -> ite a (equalNat i j) y (s j))) strm; + +bvStreamUpd : (a : sort 0) -> (w : Nat) -> + Stream a -> Vec w Bool -> a -> Stream a; +bvStreamUpd a w xs i y = streamUpd a xs (bvToNat w i) y; + +streamGet : (a : sort 0) -> Stream a -> Nat -> a; +streamGet a strm i = + Stream__rec a (\ (strm':Stream a) -> a) (\ (s:Nat -> a) -> s i) strm; + +streamConst : (a : sort 0) -> a -> Stream a; +streamConst a x = MkStream a (\ (i : Nat) -> x); + +streamMap : (a b : sort 0) -> (a -> b) -> Stream a -> Stream b; +streamMap a b f xs = MkStream b (\ (i : Nat) -> f (streamGet a xs i)); + +streamMap2 : (a b c : sort 0) -> (a -> b -> c) -> + Stream a -> Stream b -> Stream c; +streamMap2 a b c f xs ys = + MkStream c (\ (i : Nat) -> f (streamGet a xs i) (streamGet b ys i)); + +streamTake : (a : sort 0) -> (n : Nat) -> Stream a -> Vec n a; +streamTake a n xs = gen n a (\ (i : Nat) -> streamGet a xs i); + +streamDrop : (a : sort 0) -> (n : Nat) -> Stream a -> Stream a; +streamDrop a n xs = MkStream a (\ (i : Nat) -> streamGet a xs (addNat n i)); + +streamAppend : (a : sort 0) -> (n : Nat) -> Vec n a -> Stream a -> Stream a; +streamAppend a n xs ys = + MkStream a (\ (i : Nat) -> + atWithDefault n a (streamGet a ys (subNat i n)) xs i); + +streamJoin : (a : sort 0) -> (n : Nat) + -> Stream (Vec (Succ n) a) + -> (Stream a); +streamJoin a n s = + MkStream a (\ (i:Nat) -> + at (Succ n) a (streamGet (Vec (Succ n) a) s (divNat i (Succ n))) + (modNat i (Succ n)) ); + +streamSplit : (a : sort 0) -> (n : Nat) -> Stream a -> Stream (Vec n a); +streamSplit a n xs = + MkStream (Vec n a) (\ (i : Nat) -> + gen n a (\ (j : Nat) -> + streamGet a xs (addNat (mulNat i n) j))); + +streamShiftL : (a : sort 0) -> Stream a -> Nat -> Stream a; +streamShiftL a xs i = streamDrop a i xs; + +streamShiftR : (a : sort 0) -> a -> Stream a -> Nat -> Stream a; +streamShiftR a z xs i = streamAppend a i (replicate i a z) xs; + +-------------------------------------------------------------------------------- +-- Integer values +-- integer values of unbounded precision + +primitive Integer : sort 0; + +primitive intAdd : Integer -> Integer -> Integer; +primitive intSub : Integer -> Integer -> Integer; +primitive intMul : Integer -> Integer -> Integer; +primitive intDiv : Integer -> Integer -> Integer; +primitive intMod : Integer -> Integer -> Integer; +primitive intMin : Integer -> Integer -> Integer; +primitive intMax : Integer -> Integer -> Integer; +primitive intNeg : Integer -> Integer; +primitive intAbs : Integer -> Integer; +primitive intEq : Integer -> Integer -> Bool; +primitive intLe : Integer -> Integer -> Bool; +primitive intLt : Integer -> Integer -> Bool; + +-- intToNat x == max 0 x +primitive intToNat : Integer -> Nat; +primitive natToInt : Nat -> Integer; + +-- for x >= 0, intToBv n x = x `mod` 2^n +-- for x < 0, intToBv n x = bvNeg n (-x `mod` 2^n) +primitive intToBv : (n:Nat) -> Integer -> Vec n Bool; + +-- return the unsigned value of the bitvector as an integer +primitive bvToInt : (n:Nat) -> Vec n Bool -> Integer; + +-- return the 2's complement signed value of the bitvector as an integer +primitive sbvToInt : (n:Nat) -> Vec n Bool -> Integer; + + +-------------------------------------------------------------------------------- +-- Integers mod n + +primitive IntMod : Nat -> sort 0; + +primitive toIntMod : (n : Nat) -> Integer -> IntMod n; +primitive fromIntMod : (n : Nat) -> IntMod n -> Integer; + +primitive intModEq : (n : Nat) -> IntMod n -> IntMod n -> Bool; +primitive intModAdd : (n : Nat) -> IntMod n -> IntMod n -> IntMod n; +primitive intModSub : (n : Nat) -> IntMod n -> IntMod n -> IntMod n; +primitive intModMul : (n : Nat) -> IntMod n -> IntMod n -> IntMod n; +primitive intModNeg : (n : Nat) -> IntMod n -> IntMod n; + + +-------------------------------------------------------------------------------- +-- Point-update functions + +updNatFun : (a:sort 0) + -> (Nat -> a) -> Nat -> a -> (Nat -> a); +updNatFun a f i v x = ite a (equalNat i x) v (f x); + +updBvFun : (n:Nat) -> (a:sort 0) + -> (Vec n Bool -> a) -> Vec n Bool -> a -> (Vec n Bool -> a); +updBvFun n a f i v x = ite a (bvEq n i x) v (f x); + +-------------------------------------------------------------------------------- +-- Floating-point values +-- Currently commented out because they are not implemented... + +primitive Float : sort 0; + +-- mkFloat m e = m * 2^^e +primitive mkFloat : Integer -> Integer -> Float; +-- primitive bvToFloat : Vec 32 Bool -> Float; +-- primitive floatToBV : Float -> Vec 32 Bool; + +primitive Double : sort 0; + +-- mkDouble m e = m * 2^^e +primitive mkDouble : Integer -> Integer -> Float; +-- primitive bvToDouble : Vec 64 Bool -> Double; +-- primitive doubleToBV : Double -> Vec 64 Bool; + + +------------------------------------------------------------------------------- +-- Dependent sums + +data Sigma (a : sort 0) (b : a -> sort 0) : sort 0 + where { + exists : (pa : a) -> b pa -> Sigma a b; + } + +Sigma__rec + (a : sort 0) (b : a -> sort 0) (p : Sigma a b -> sort 0) + (f1 : (pa : a) -> (pb : b pa) -> p (exists a b pa pb)) (u : Sigma a b) : p u + = Sigma#rec a b p f1 u; + +Sigma_proj1 (a : sort 0) (b : a -> sort 0) : Sigma a b -> a + = Sigma__rec a b (\ (_ : Sigma a b) -> a) (\ (pa : a) (_ : b pa) -> pa); + +Sigma_proj2 (a : sort 0) (b : a -> sort 0) + : (p : Sigma a b) -> b (Sigma_proj1 a b p) + = Sigma__rec a b + (\ (p : Sigma a b) -> b (Sigma_proj1 a b p)) + (\ (pa : a) (pb : b pa) -> pb); + + +-------------------------------------------------------------------------------- +-- Lists + +data List (a : sort 0) : sort 0 + where { + Nil : List a; + Cons : a -> List a -> List a; + } + +List__rec : + (a : sort 0) -> (P : List a -> sort 0) -> P (Nil a) -> + ((x : a) -> (l : List a) -> P l -> P (Cons a x l)) -> + (l : List a) -> P l; +List__rec a P f1 f2 l = List#rec a P f1 f2 l; + +unfoldList : (a:sort 0) -> List a -> Either #() (a * List a * #()); +unfoldList a l = + List__rec a (\ (_:List a) -> Either #() (a * List a * #())) + (Left #() (a * List a * #()) ()) + (\ (x:a) (l:List a) (_:Either #() (a * List a * #())) -> + Right #() (a * List a * #()) (x, l, ())) + l; + +foldList : (a:sort 0) -> Either #() (a * List a * #()) -> List a; +foldList a = + either #() (a * List a * #()) (List a) + (\ (_ : #()) -> Nil a) + (\ (tup : (a * List a * #())) -> + Cons a tup.(1) tup.(2).(1)); + + +-------------------------------------------------------------------------------- +-- Lists of 64-bit words (for testing Heapster) + +data W64List : sort 0 where { + W64Nil : W64List; + W64Cons : Vec 64 Bool -> W64List -> W64List; +} + +unfoldedW64List : sort 0; +unfoldedW64List = + Either #() + (Sigma (Vec 64 Bool) (\ (_:Vec 64 Bool) -> #()) * W64List * #()); + +unfoldW64List : W64List -> unfoldedW64List; +unfoldW64List l = + W64List#rec (\ (_:W64List) -> unfoldedW64List) + (Left #() (Sigma (Vec 64 Bool) (\ (_:Vec 64 Bool) -> #()) * W64List * #()) ()) + (\ (bv:Vec 64 Bool) (l':W64List) (_:unfoldedW64List) -> + Right #() (Sigma (Vec 64 Bool) (\ (_:Vec 64 Bool) -> #()) * W64List * #()) + (exists (Vec 64 Bool) (\ (_:Vec 64 Bool) -> #()) bv (), + l', ())) + l; + +foldW64List : unfoldedW64List -> W64List; +foldW64List = + either #() (Sigma (Vec 64 Bool) (\ (_:Vec 64 Bool) -> #()) * W64List * #()) + W64List + (\ (_:#()) -> W64Nil) + (\ (bv_l:(Sigma (Vec 64 Bool) (\ (_:Vec 64 Bool) -> #()) + * W64List * #())) -> + W64Cons (Sigma_proj1 (Vec 64 Bool) + (\ (_:Vec 64 Bool) -> #()) bv_l.(1)) + bv_l.(2).(1)); + + +-------------------------------------------------------------------------------- +-- Vector operations with built-in casts of their resulting lengths + +-- Decide equality on two bitvectors, returning a proof if they are equal +primitive bvEqWithProof : (n : Nat) -> (v1 v2 : Vec n Bool) -> + Maybe (Eq (Vec n Bool) v1 v2); + +-- Compare two bitvectors with bvult, returning a proof if bvult succeeds +bvultWithProof : (n : Nat) -> (v1 v2 : Vec n Bool) -> + Maybe (Eq Bool (bvult n v1 v2) True); +bvultWithProof n v1 v2 = + iteDep (\ (b:Bool) -> Maybe (Eq Bool b True)) (bvult n v1 v2) + (Just (Eq Bool True True) (Refl Bool True)) + (Nothing (Eq Bool False True)); + +-- Compare two bitvectors with bvule, returning a proof if bvule succeeds +bvuleWithProof : (n : Nat) -> (v1 v2 : Vec n Bool) -> + Maybe (Eq Bool (bvule n v1 v2) True); +bvuleWithProof n v1 v2 = + iteDep (\ (b:Bool) -> Maybe (Eq Bool b True)) (bvule n v1 v2) + (Just (Eq Bool True True) (Refl Bool True)) + (Nothing (Eq Bool False True)); + +-- Convert a proof of bitvector equality to one of Nat equality +primitive bvEqToEqNat : (n : Nat) -> (v1 v2 : Vec n Bool) -> + Eq (Vec n Bool) v1 v2 -> + eqNat (bvToNat n v1) (bvToNat n v2); + +-- Convert a proof of bitvector less-than to one of Nat less-than +primitive bvultToIsLtNat : (n : Nat) -> (v1 v2 : Vec n Bool) -> + Eq Bool (bvult n v1 v2) True -> + IsLtNat (bvToNat n v1) (bvToNat n v2); + +-- | Index a vector using a proof that the index is in the range of the vector +-- FIXME: atWithDefault should maybe use this...? +primitive atWithProof : (n : Nat) -> (a : sort 0) -> a -> Vec n a -> + (i : Nat) -> IsLtNat i n -> a; + +-- Set the value at index i in a vector using a proof that i is in range +primitive updWithProof : (n : Nat) -> (a : sort 0) -> Vec n a -> + (i : Nat) -> a -> IsLtNat i n -> Vec n a; + +-- Take a slice of a vector using a proof that the slice is in range +primitive sliceWithProof : (a : sort 0) -> (n off len : Nat) -> + IsLeNat (addNat off len) n -> Vec n a -> Vec len a; + +-- Update a slice of a vector using a proof that the slice is in range +primitive updSliceWithProof : (a : sort 0) -> (n off len : Nat) -> + IsLeNat (addNat off len) n -> + Vec n a -> Vec len a -> Vec n a; + + +-------------------------------------------------------------------------------- +-- Computation monad + +primitive CompM : sort 0 -> sort 0; + +primitive returnM : (a:sort 0) -> a -> CompM a; +primitive bindM : (a b:sort 0) -> CompM a -> (a -> CompM b) -> CompM b; + +composeM : (a b c: sort 0) -> (a -> CompM b) -> (b -> CompM c) -> a -> CompM c; +composeM a b c f g x = bindM b c (f x) g; + +-- Raise an error in the computation monad +primitive errorM : (a:sort 0) -> CompM a; + +-- Run the first computation, and, if it raises an error, catch the error and +-- run the second computation +primitive catchM : (a:sort 0) -> CompM a -> CompM a -> CompM a; + +-- We can define fixM as let rec f x = ... in f +primitive fixM : (a:sort 0) -> (b:a -> sort 0) -> + (((x:a) -> CompM (b x)) -> ((x:a) -> CompM (b x))) -> + (x:a) -> CompM (b x); +-- fixM a b fn x = letRecM1 a b b fn (\ (f:a -> CompM b) -> f x); + +-- A representation of the type (x1:A1) -> ... -> (xn:An) -> CompM (B x1 ... xn) +data LetRecType : sort 1 where { + LRT_Ret : sort 0 -> LetRecType; + LRT_Fun : (a:sort 0) -> (a -> LetRecType) -> LetRecType; +} + +-- Convert a LetRecType to the type it represents +lrtToType : LetRecType -> sort 0; +lrtToType lrt = + LetRecType#rec + (\ (lrt:LetRecType) -> sort 0) + (\ (b:sort 0) -> CompM b) + (\ (a:sort 0) (_: a -> LetRecType) (b: a -> sort 0) -> (x:a) -> b x) + lrt; + +-- NOTE: the following are needed to define multiFixM instead of making it a +-- primitive, which we are keeping commented here in case that is needed +{- +-- Convert the argument types of a LetRecType to their "flat" version of the +-- form { x1:A1 & { x2:A2 & ... { xn:An & unit } ... }} +lrtToFlatArgs : LetRecType -> sort 0; +lrtToFlatArgs lrt = + LetRecType#rec + (\ (lrt:LetRecType) -> sort 0) + (\ (_:sort 0) -> #()) + (\ (a:sort 0) (_: a -> LetRecType) (b: a -> sort 0) -> Sigma a b) + lrt; + +-- Get the dependent return type fun (args:lrtToFlatArgs) => B x.1 ... of a +-- LetRecType in terms of the flat arguments +lrtToFlatRet : (lrt:LetRecType) -> lrtToFlatArgs lrt -> sort 0; +lrtToFlatRet lrt = + LetRecType#rec + (\ (lrt:LetRecType) -> lrtToFlatArgs lrt -> sort 0) + (\ (a:sort 0) (_:#()) -> a) + (\ (a:sort 0) (lrtF: a -> LetRecType) + (retF: (x:a) -> lrtToFlatArgs (lrtF x) -> sort 0) + (args: Sigma a (\ (x:a) -> lrtToFlatArgs (lrtF x))) -> + retF (Sigma_proj1 a (\ (x:a) -> lrtToFlatArgs (lrtF x)) args) + (Sigma_proj2 a (\ (x:a) -> lrtToFlatArgs (lrtF x)) args)) + lrt; + +-- Extract out the "flat" version of a LetRecType +lrtToFlatType : LetRecType -> sort 0; +lrtToFlatType lrt = (args:lrtToFlatArgs lrt) -> CompM (lrtToFlatRet lrt args); + + +-- "Flatten" a function described by a LetRecType +flattenLRTFun : (lrt:LetRecType) -> lrtToType lrt -> lrtToFlatType lrt; +flattenLRTFun lrt = + LetRecType#rec + (\ (lrt:LetRecType) -> lrtToType lrt -> lrtToFlatType lrt) + (\ (b:sort 0) (f:CompM b) (_:#()) -> f) + (\ (a:sort 0) (lrtF: a -> LetRecType) + (restF: (x:a) -> lrtToType (lrtF x) -> lrtToFlatType (lrtF x)) + (f: lrtToType (LRT_Fun a lrtF)) (args:lrtToFlatArgs (LRT_Fun a lrtF)) -> + restF (Sigma_proj1 a (\ (x:a) -> lrtToFlatArgs (lrtF x)) args) + (f (Sigma_proj1 a (\ (x:a) -> lrtToFlatArgs (lrtF x)) args)) + (Sigma_proj2 a (\ (x:a) -> lrtToFlatArgs (lrtF x)) args)) + lrt; + +-- "Unflatten" a function described by a LetRecType +unflattenLRTFun : (lrt:LetRecType) -> lrtToFlatType lrt -> lrtToType lrt; +unflattenLRTFun lrt = + LetRecType#rec + (\ (lrt:LetRecType) -> lrtToFlatType lrt -> lrtToType lrt) + (\ (b:sort 0) (f:#() -> CompM b) -> f ()) + (\ (a:sort 0) (lrtF: a -> LetRecType) + (restF: (x:a) -> lrtToFlatType (lrtF x) -> lrtToType (lrtF x)) + (f: lrtToFlatType (LRT_Fun a lrtF)) (x:a) -> + restF x (\ (args:lrtToFlatArgs (lrtF x)) -> + f (exists a (\ (y:a) -> lrtToFlatArgs (lrtF y)) x args))) + lrt; +-} + +-- A list of 0 or more LetRecTypes +data LetRecTypes : sort 1 where { + LRT_Nil : LetRecTypes; + LRT_Cons : LetRecType -> LetRecTypes -> LetRecTypes; +} + +-- Build the function type lrtToType lrt1 -> ... -> lrtToType lrtn -> b from the +-- LetRecTypes list [lrt1, ..., lrtn] +lrtPi : LetRecTypes -> sort 0 -> sort 0; +lrtPi lrts b = + LetRecTypes#rec + (\ (lrts:LetRecTypes) -> sort 0) + b + (\ (lrt:LetRecType) (_:LetRecTypes) (rest:sort 0) -> lrtToType lrt -> rest) + lrts; + +-- Build the product type (lrtToType lrt1, ..., lrtToType lrtn) from the +-- LetRecTypes list [lrt1, ..., lrtn] +lrtTupleType : LetRecTypes -> sort 0; +lrtTupleType lrts = + LetRecTypes#rec + (\ (lrts:LetRecTypes) -> sort 0) + #() + (\ (lrt:LetRecType) (_:LetRecTypes) (rest:sort 0) -> #(lrtToType lrt, rest)) + lrts; + +-- NOTE: the following are needed to define multiFixM instead of making it a +-- primitive, which we are keeping commented here in case that is needed +{- +-- Construct a multi-arity function of type lrtPi lrts B from one of type +-- lrtTupleType lrts -> B +lrtLambda : (lrts:LetRecTypes) -> (B:sort 0) -> (lrtTupleType lrts -> B) -> lrtPi lrts B; +lrtLambda top_lrts B = + LetRecTypes#rec + (\ (lrts:LetRecTypes) -> (lrtTupleType lrts -> B) -> lrtPi lrts B) + (\ (F:#() -> B) -> F ()) + (\ (lrt:LetRecType) (lrts:LetRecTypes) + (rest:(lrtTupleType lrts -> B) -> lrtPi lrts B) + (F:lrtTupleType (LRT_Cons lrt lrts) -> B) (f:lrtToType lrt) -> + rest (\ (fs:lrtTupleType lrts) -> F (f, fs))) + top_lrts; + +-- Apply a multi-arity function of type lrtPi lrts B to an lrtTupleType lrts +lrtApply : (lrts:LetRecTypes) -> (B:sort 0) -> lrtPi lrts B -> lrtTupleType lrts -> B; +lrtApply top_lrts B = + LetRecTypes#rec + (\ (lrts:LetRecTypes) -> lrtPi lrts B -> lrtTupleType lrts -> B) + (\ (F:B) (_:#()) -> F) + (\ (lrt:LetRecType) (lrts:LetRecTypes) (rest:lrtPi lrts B -> lrtTupleType lrts -> B) + (F:lrtPi (LRT_Cons lrt lrts) B) (fs:lrtTupleType (LRT_Cons lrt lrts)) -> + rest (F fs.(1)) fs.(2)) + top_lrts; + +-- Build a multi-argument fixed-point of type A1 -> ... -> An -> CompM B +multiArgFixM : (lrt:LetRecType) -> (lrtToType lrt -> lrtToType lrt) -> + lrtToType lrt; +multiArgFixM lrt F = + unflattenLRTFun + lrt + (fixM (lrtToFlatArgs lrt) (lrtToFlatRet lrt) + (\ (f:lrtToFlatType lrt) -> + flattenLRTFun lrt (F (unflattenLRTFun lrt f)))); + +-- Construct a mutual fixed-point over tuples of LRT functions +multiTupleFixM : (lrts:LetRecTypes) -> (lrtTupleType lrts -> lrtTupleType lrts) -> + lrtTupleType lrts; +multiTupleFixM top_lrts = + LetRecTypes#rec + (\ (lrts:LetRecTypes) -> (lrtTupleType lrts -> lrtTupleType lrts) -> lrtTupleType lrts) + (\ (_:#() -> #()) -> ()) + (\ (lrt:LetRecType) (lrts:LetRecTypes) + (restF: (lrtTupleType lrts -> lrtTupleType lrts) -> lrtTupleType lrts) + (F:lrtTupleType (LRT_Cons lrt lrts) -> lrtTupleType (LRT_Cons lrt lrts)) -> + (multiArgFixM lrt (\ (f:lrtToType lrt) -> + (F (f, restF (\ (fs:lrtTupleType lrts) -> + (F (f, fs)).(2)))).(1)), + restF (\ (fs:lrtTupleType lrts) -> + (F (multiArgFixM lrt + (\ (f:lrtToType lrt) -> + (F (f, restF (\ (fs:lrtTupleType lrts) -> + (F (f, fs)).(2)))).(1)), + fs)).(2)))) + top_lrts; + +-- A nicer version of multiTupleFixM that abstracts the functions one at a time +multiFixM : (lrts:LetRecTypes) -> lrtPi lrts (lrtTupleType lrts) -> + lrtTupleType lrts; +multiFixM lrts F = + multiTupleFixM lrts (\ (fs:lrtTupleType lrts) -> lrtApply lrts (lrtTupleType lrts) F fs); + +-- A letrec construct for binding 0 or more mutually recursive functions +letRecM : (lrts : LetRecTypes) -> (B:sort 0) -> lrtPi lrts (lrtTupleType lrts) -> + lrtPi lrts (CompM B) -> CompM B; +letRecM lrts B F body = lrtApply lrts (CompM B) body (multiFixM lrts F); +-} + +-- Construct a fixed-point for a tuple of mutually-recursive functions +primitive multiFixM : (lrts:LetRecTypes) -> lrtPi lrts (lrtTupleType lrts) -> + lrtTupleType lrts; + +-- This is like let rec in ML: letRecM defs body defines N recursive functions +-- in terms of themselves using defs, and then passes them to body. We use this +-- instead of the more standard fixM because it offers a more compact +-- representation, and because fixM messes with functional extensionality by +-- introducing an irreducible term at function type. +primitive letRecM : (lrts : LetRecTypes) -> (b : sort 0) -> + (lrtPi lrts (lrtTupleType lrts)) -> + (lrtPi lrts (CompM b)) -> CompM b; + +-- This is let rec with exactly one binding +letRecM1 : (a b c : sort 0) -> ((a -> CompM b) -> (a -> CompM b)) -> + ((a -> CompM b) -> CompM c) -> CompM c; +letRecM1 a b c fn body = + letRecM + (LRT_Cons (LRT_Fun a (\ (_:a) -> LRT_Ret b)) LRT_Nil) c + (\ (f:a -> CompM b) -> (fn f, ())) + (\ (f:a -> CompM b) -> body f); + + +-- Test computations +test_fun0 : Vec 64 Bool -> CompM (Vec 64 Bool); +test_fun0 _ = returnM (Vec 64 Bool) (bvNat 64 0); + +test_fun1 : Vec 64 Bool -> CompM (Vec 64 Bool); +test_fun1 _ = returnM (Vec 64 Bool) (bvNat 64 1); + +test_fun2 : Vec 64 Bool -> CompM (Vec 64 Bool); +test_fun2 x = returnM (Vec 64 Bool) x; + +-- If x == 0 then x else 0; should be equal to 0 +test_fun3 : Vec 64 Bool -> CompM (Vec 64 Bool); +test_fun3 x = + ite (CompM (Vec 64 Bool)) (bvEq 64 x (bvNat 64 0)) + (returnM (Vec 64 Bool) x) + (returnM (Vec 64 Bool) (bvNat 64 0)); + +-- let rec f x = 0 in f x +test_fun4 : Vec 64 Bool -> CompM (Vec 64 Bool); +test_fun4 x = + letRecM1 + (Vec 64 Bool) (Vec 64 Bool) (Vec 64 Bool) + (\ (f: Vec 64 Bool -> CompM (Vec 64 Bool)) (y:Vec 64 Bool) -> + returnM (Vec 64 Bool) (bvNat 64 0)) + (\ (f: Vec 64 Bool -> CompM (Vec 64 Bool)) -> + f x); + +{- Alternate version of test_fun4 that uses letRecM directly +test_fun4 : Vec 64 Bool -> CompM (Vec 64 Bool); +test_fun4 x = + letRecM + (LRT_Cons (Vec 64 Bool) (\ (_:Vec 64 Bool) -> LRT_Ret (Vec 64 Bool)) + LRT_Nil) + (Vec 64 Bool) + (\ (f:(Vec 64 Bool -> CompM (Vec 64 Bool))) -> + ((\ (y:Vec 64 Bool) -> returnM (Vec 64 Bool) (bvNat 64 0)), ())) + (\ (f:(Vec 64 Bool -> CompM (Vec 64 Bool))) -> f x); +-} + +-- let rec f = f in f x +test_fun5 : Vec 64 Bool -> CompM (Vec 64 Bool); +test_fun5 x = + letRecM1 + (Vec 64 Bool) (Vec 64 Bool) (Vec 64 Bool) + (\ (f: Vec 64 Bool -> CompM (Vec 64 Bool)) -> f) + (\ (f: Vec 64 Bool -> CompM (Vec 64 Bool)) -> f x); + +-- let rec f = g and g = f in f x +test_fun6 : Vec 64 Bool -> CompM (Vec 64 Bool); +test_fun6 x = + letRecM + (LRT_Cons + (LRT_Fun (Vec 64 Bool) (\ (_:Vec 64 Bool) -> LRT_Ret (Vec 64 Bool))) + (LRT_Cons + (LRT_Fun (Vec 64 Bool) (\ (_:Vec 64 Bool) -> LRT_Ret (Vec 64 Bool))) + LRT_Nil)) + (Vec 64 Bool) + (\ (f1:(Vec 64 Bool -> CompM (Vec 64 Bool))) + (f2:(Vec 64 Bool -> CompM (Vec 64 Bool))) -> + (f2, (f1, ()))) + (\ (f1:(Vec 64 Bool -> CompM (Vec 64 Bool))) + (f2:(Vec 64 Bool -> CompM (Vec 64 Bool))) -> + f1 x); + +-------------------------------------------------------------------------------- +-- SMT Array + +primitive Array : sort 0 -> sort 0 -> sort 0; + +primitive arrayConstant : (a b : sort 0) -> b -> (Array a b); +primitive arrayLookup : (a b : sort 0) -> (Array a b) -> a -> b; +primitive arrayUpdate : (a b : sort 0) -> (Array a b) -> a -> b -> (Array a b); +primitive arrayEq : (a b : sort 0) -> (Array a b) -> (Array a b) -> Bool; + +-------------------------------------------------------------------------------- +-- General axioms + +axiom bveq_sameL : (n : Nat) + -> (x z : Vec n Bool) + -> Eq Bool + (bvEq n x (bvAdd n x z)) + (bvEq n (bvNat n 0) z); + +axiom bveq_sameR : (n : Nat) + -> (x y : Vec n Bool) + -> Eq Bool + (bvEq n (bvAdd n x y) x) + (bvEq n y (bvNat n 0)); + +axiom bveq_same2 : (n : Nat) + -> (x y z : Vec n Bool) + -> Eq Bool + (bvEq n (bvAdd n x y) (bvAdd n x z)) + (bvEq n y z); + +axiom bvNat_bvToNat : (n : Nat) + -> (x : Vec n Bool) + -> Eq (Vec n Bool) + (bvNat n (bvToNat n x)) + x; + +axiom ite_split_cong : (b : Bool) -> (x : Vec 384 Bool) -> (y : Vec 384 Bool) + -> Eq (Vec 12 (Vec 32 Bool)) + (split 12 32 Bool (ite (Vec 384 Bool) b x y)) + (ite (Vec 12 (Vec 32 Bool)) b (split 12 32 Bool x) (split 12 32 Bool y)); + +axiom ite_join_cong : (b : Bool) + -> (x : Vec 12 (Vec 32 Bool)) + -> (y : Vec 12 (Vec 32 Bool)) + -> Eq (Vec 384 Bool) + (join 12 32 Bool (ite (Vec 12 (Vec 32 Bool)) b x y)) + (ite (Vec 384 Bool) b (join 12 32 Bool x) (join 12 32 Bool y)); + +axiom map_map : (a b c : sort 0) -> (f : a -> b) -> (g : b -> c) -> + (n : Nat) -> (xs : Vec n a) -> + Eq (Vec n c) (map b c g n (map a b f n xs)) + (map a c (\ (x:a) -> g (f x)) n xs); diff --git a/saw-core/saw-core.cabal b/saw-core/saw-core.cabal new file mode 100644 index 0000000000..c591c204bb --- /dev/null +++ b/saw-core/saw-core.cabal @@ -0,0 +1,143 @@ +Name: saw-core +Version: 0.1 +License: BSD3 +License-file: LICENSE +Author: Galois, Inc. +Maintainer: huffman@galois.com +Copyright: (c) 2012-2016 Galois Inc. +Category: Formal Methods +Build-type: Simple +cabal-version: >= 1.8 +Synopsis: SAWCore intermediate language +Description: + The implementation of the SAWCore intermediate language, + used by LSS, JSS, and SAWScript + +extra-source-files: + prelude/Prelude.sawcore + src/Verifier/SAW/Grammar.y + src/Verifier/SAW/Lexer.x + +library + build-tools: + alex >= 3.1.3, + happy >= 1.9.6 + + build-depends: + base == 4.*, + array, + bytestring, + containers, + data-inttrie, + data-ref, + directory, + filepath, + hashable >= 1.2, + lens >= 3.8, + modern-uri >= 0.3.2 && < 0.4, + MonadRandom, + mtl, + panic, + parameterized-utils, + pretty, + prettyprinter >= 1.7.0, + prettyprinter-ansi-terminal >= 1.1.2, + random, + rme, + template-haskell, + text, + th-lift-instances, + tf-random, + transformers, + transformers-compat, + unordered-containers, + utf8-string, + vector + hs-source-dirs: src + exposed-modules: + Verifier.SAW + Verifier.SAW.Constant + Verifier.SAW.ExternalFormat + Verifier.SAW.Conversion + Verifier.SAW.Cache + Verifier.SAW.FiniteValue + Verifier.SAW.Grammar + Verifier.SAW.Lexer + Verifier.SAW.Module + Verifier.SAW.Name + Verifier.SAW.ParserUtils + Verifier.SAW.Position + Verifier.SAW.Prelude + Verifier.SAW.Prelude.Constants + Verifier.SAW.Prim + Verifier.SAW.Recognizer + Verifier.SAW.Rewriter + Verifier.SAW.SATQuery + Verifier.SAW.SCTypeCheck + Verifier.SAW.Simulator + Verifier.SAW.Simulator.Concrete + Verifier.SAW.Simulator.MonadLazy + Verifier.SAW.Simulator.Prims + Verifier.SAW.Simulator.RME + Verifier.SAW.Simulator.Value + Verifier.SAW.SharedTerm + Verifier.SAW.Term.Functor + Verifier.SAW.Term.CtxTerm + Verifier.SAW.OpenTerm + Verifier.SAW.Term.Pretty + Verifier.SAW.TermNet + Verifier.SAW.Testing.Random + Verifier.SAW.Typechecker + Verifier.SAW.TypedAST + Verifier.SAW.Unique + Verifier.SAW.UntypedAST + Verifier.SAW.Change + Verifier.SAW.Utils + other-modules: + Verifier.SAW.UnionFind + + GHC-options: -Wall -Werror -Wcompat + if impl(ghc == 8.0.1) + ghc-options: -Wno-redundant-constraints + GHC-prof-options: -fprof-auto -fprof-cafs + extensions: + DeriveFunctor + GeneralizedNewtypeDeriving + ImplicitParams + ViewPatterns + +test-suite test-sawcore + type: exitcode-stdio-1.0 + GHC-options: -Wall -Werror -Wcompat + main-is: Tests.hs + hs-source-dirs: tests/src + build-depends: + base >= 4 + , containers + , data-ref + , hashable + , lens + , mtl + , saw-core + , time + , unordered-containers + , vector + , QuickCheck >= 2.7 + , tasty + , tasty-ant-xml >= 1.1.0 + , tasty-hunit + , tasty-quickcheck + , tagged + + other-modules: + Tests.CacheTests + Tests.Parser + Tests.Rewriter + Tests.SharedTerm + +executable extcore-info + main-is: extcore-info.hs + hs-source-dirs: tools + build-depends: + base >= 4 + , saw-core diff --git a/saw-core/saw-core.el b/saw-core/saw-core.el new file mode 100644 index 0000000000..c2eeeb1bd6 --- /dev/null +++ b/saw-core/saw-core.el @@ -0,0 +1,137 @@ +;;; saw-core.el --- A major mode for editing saw-core -*- lexical-binding: t; -*- + +;; Copyright (C) 2020 Galois, Inc + +;; Author: David Thrane Christiansen +;; Keywords: languages + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; This is a major mode for editing saw-core's concrete syntax. + +;;; Code: + +(require 'compile) +(require 'flycheck) + +;;; Config + +(defgroup saw-core '() + "saw-core" + :group 'languages + :tag "saw-core") + +(defcustom saw-core-saw-script-command "saw" + "The command to run to execute saw." + :type 'string + :group 'saw-core) + +(defface saw-core-keyword-face + '((t (:inherit font-lock-keyword-face))) + "How to highlight saw-core keywords." + :group 'saw-core) + +(defface saw-core-builtin-face + '((t (:inherit font-lock-builtin-face))) + "How to highlight saw-core built-in syntax." + :group 'saw-core) + +(defface saw-core-eliminator-face + '((t (:inherit font-lock-string-face))) + "How to highlight saw-core eliminators." + :group 'saw-core) + +(defface saw-core-punctuation-face + '((t (:inherit font-lock-constant-face))) + "How to highlight saw-core punctuation elements." + :group 'saw-core) + + +;;; Syntax table + +(defvar saw-core-mode-syntax-table + (let ((syntax-table (make-syntax-table))) + ;; Set up -- line comments and {- ... -} block comments + (modify-syntax-entry ?\- ". 123" syntax-table) + (modify-syntax-entry ?\{ "(} 1bn" syntax-table) + (modify-syntax-entry ?\} "){ 4bn" syntax-table) + (modify-syntax-entry ?\n ">" syntax-table) + + syntax-table) + "Syntax table for `saw-core-mode'.") + +;;; font-lock + +(defconst saw-core-keywords + (list "axiom" "module" "import" "where" "data" "sort" "primitive") + "Keywords to highlight in saw-core buffers.") + +(defconst saw-core--keyword-regexp + (regexp-opt saw-core-keywords 'words) + "Regular expression that matches saw-core keywords for highlighting.") + +(defconst saw-core-punctuation + (list ":" "(" ")" "{" "}" ";" "=" ",") + "Punctuation to highlight in saw-core buffers.") + +(defconst saw-core--punctuation-regexp + (regexp-opt saw-core-punctuation) + "Regular expression that matches saw-core keywords for highlighting.") + +(defconst saw-core-font-lock-defaults + `(( (,saw-core--keyword-regexp . 'saw-core-keyword-face) + (,saw-core--punctuation-regexp . 'saw-core-punctuation-face) + ("\\<[a-zA-Z]+#rec\\>" . 'saw-core-eliminator-face) + ;; Language elements named by syntax rather than by an identifier + ("#" . 'saw-core-builtin-face) + ("\\(\\\\\\)[^\\]" . (0 'saw-core-builtin-face)) + ("->" . 'saw-core-builtin-face) + ("*" . 'saw-core-builtin-face) + ("\\.([0-9]+)" . 'saw-core-builtin-face) + ) + nil nil nil nil) + "Highlighting instructions for saw-core.") + +;;; imenu support for navigation + +(defconst saw-core-imenu-generic-expression + (list + `(nil "\\ +\\([a-zA-Z_][a-zA-Z0-9_]+\\)" 1) + `(nil "\\ +\\([a-zA-Z_][a-zA-Z0-9_]+\\)" 1) + `(nil "^\\([a-zA-Z_][a-zA-Z0-9_]+\\) *:" 1))) + +;;; The mode itself +(define-derived-mode saw-core-mode prog-mode "saw-core" + "A major mode for editing saw-core files." + :syntax-table saw-core-mode-syntax-table + (setq font-lock-defaults saw-core-font-lock-defaults) + (setq font-lock-multiline t) + + ;; Comment syntax + (setq-local comment-start "-- ") + (setq-local comment-end "") + + ;; imenu + (setq-local imenu-generic-expression saw-core-imenu-generic-expression) + + ;; Indentation + (setq-local indent-line-function 'indent-relative)) + +(add-to-list 'auto-mode-alist '("\\.sawcore\\'" . saw-core-mode)) + +(provide 'saw-core) +;;; saw-core.el ends here diff --git a/saw-core/src/Verifier/SAW.hs b/saw-core/src/Verifier/SAW.hs new file mode 100644 index 0000000000..86f61bb115 --- /dev/null +++ b/saw-core/src/Verifier/SAW.hs @@ -0,0 +1,26 @@ +{- | +Module : Verifier.SAW +Copyright : Galois, Inc. 2012-2015 +License : BSD3 +Maintainer : jhendrix@galois.com +Stability : experimental +Portability : non-portable (language extensions) +-} + +{-# LANGUAGE TemplateHaskell #-} + +module Verifier.SAW + ( module Verifier.SAW.SharedTerm + , module Verifier.SAW.ExternalFormat + , Module + , preludeModule + , scLoadPreludeModule + ) where + +import Verifier.SAW.SharedTerm +import Verifier.SAW.Prelude +import Verifier.SAW.ExternalFormat + +-- The following type-checks the Prelude at compile time, as a sanity check +import Language.Haskell.TH +$(runIO (mkSharedContext >>= \sc -> scLoadPreludeModule sc >> return [])) diff --git a/saw-core/src/Verifier/SAW/Cache.hs b/saw-core/src/Verifier/SAW/Cache.hs new file mode 100644 index 0000000000..75864ace3f --- /dev/null +++ b/saw-core/src/Verifier/SAW/Cache.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE ExistentialQuantification #-} + +{- | +Module : Verifier.SAW.Cache +Copyright : Galois, Inc. 2012-2015 +License : BSD3 +Maintainer : jhendrix@galois.com +Stability : experimental +Portability : non-portable (language extensions) +-} + +module Verifier.SAW.Cache + ( Cache + , newCache + , newCacheMap + , newCacheMap' + , newCacheIntMap + , newCacheIntMap' + , useCache + ) +where + +import Control.Monad (liftM) +import qualified Data.IntMap as IntMap +import qualified Data.Map as Map +import Data.Ref +import Prelude hiding (lookup) + +data Cache m k a = forall t. Cache (T m t) (k -> t -> Maybe a) (k -> a -> t -> t) + +useCache :: C m => Cache m k a -> k -> m a -> m a +useCache (Cache ref lookup update) k action = do + result <- liftM (lookup k) (Data.Ref.read ref) + case result of + Just x -> return x + Nothing -> do + x <- action + modify ref (update k x) + return x + +newCache :: (C m, Ord k) => m (Cache m k a) +newCache = newCacheMap + +newCacheMap :: (C m, Ord k) => m (Cache m k a) +newCacheMap = newCacheMap' Map.empty + +newCacheMap' :: (C m, Ord k) => Map.Map k a -> m (Cache m k a) +newCacheMap' initialMap = do + ref <- new initialMap + return (Cache ref Map.lookup Map.insert) + +newCacheIntMap :: (C m) => m (Cache m Int a) +newCacheIntMap = newCacheIntMap' IntMap.empty + +newCacheIntMap' :: (C m) => IntMap.IntMap a -> m (Cache m Int a) +newCacheIntMap' initialMap = do + ref <- new initialMap + return (Cache ref IntMap.lookup IntMap.insert) diff --git a/saw-core/src/Verifier/SAW/Change.hs b/saw-core/src/Verifier/SAW/Change.hs new file mode 100644 index 0000000000..aa7a4e51bb --- /dev/null +++ b/saw-core/src/Verifier/SAW/Change.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} + +{- | +Module : Verifier.SAW.Change +Copyright : Galois, Inc. 2012-2015 +License : BSD3 +Maintainer : jhendrix@galois.com +Stability : experimental +Portability : non-portable (language extensions) +-} + +module Verifier.SAW.Change + ( ChangeMonad(..) + , Change(..) + , ChangeT(..) + , change + , changeList + , commitChange + , commitChangeT + , preserveChangeT + , flatten + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif +import Control.Monad (liftM, liftM2) +import Control.Monad.Trans + +---------------------------------------------------------------------- +-- Monads for tracking whether values have changed + +class (Monad m, Applicative m) => ChangeMonad m where + preserve :: a -> m a -> m a + taint :: m a -> m a + taint m = m >>= modified + modified :: a -> m a + modified x = taint (pure x) + -- Laws (not a minimal set): + -- taint (taint m) = taint m + -- taint (pure x) = modified x + -- fmap f (taint m) = taint (fmap f m) + -- taint m1 <*> m2 = taint (m1 <*> m2) + -- m1 <*> taint m2 = taint (m1 <*> m2) + -- fmap f (modified x) = modified (f x) + -- modified x >>= k = taint (k x) + -- m >>= modified = taint m + -- taint (modified x) = modified x + -- taint (return x) = modified x + -- taint (m >>= k) = taint m >>= k + -- taint (m >>= k) = m >>= (taint . k) + -- preserve x (pure _) = pure x + -- preserve _ (modified y) = modified y + -- preserve _ (taint m) = taint m + +change :: ChangeMonad m => (a -> Maybe a) -> a -> m a +change f a = + case f a of + Nothing -> pure a + Just x -> modified x + +changeList :: ChangeMonad m => (a -> m a) -> [a] -> m [a] +changeList f xs = + preserve xs $ + case xs of + [] -> pure [] + y : ys -> (:) <$> f y <*> changeList f ys + +---------------------------------------------------------------------- +-- Change monad + +data Change a = Original a | Modified a + deriving (Show, Functor) + +instance Applicative Change where + pure x = Original x + Original f <*> Original x = Original (f x) + Original f <*> Modified x = Modified (f x) + Modified f <*> Original x = Modified (f x) + Modified f <*> Modified x = Modified (f x) + +instance Monad Change where + return x = Original x + Original x >>= k = k x + Modified x >>= k = taint (k x) + +instance ChangeMonad Change where + preserve x (Original _) = Original x + preserve _ c@(Modified _) = c + taint (Original x) = Modified x + taint c@(Modified _) = c + modified x = Modified x + +commitChange :: Change a -> a +commitChange (Original x) = x +commitChange (Modified x) = x +-- ^ Satisfies the following laws: +-- @commitChange (fmap f m) = f (commitChange m)@ +-- @commitChange (taint m) = commitChange m@ +-- @commitChange (m >>= k) = commitChange (k (commitChange m))@ + +---------------------------------------------------------------------- +-- Change monad transformer + +newtype ChangeT m a = ChangeT { runChangeT :: m (Change a) } + +instance Monad m => Functor (ChangeT m) where + fmap f (ChangeT m) = ChangeT (liftM (fmap f) m) + +instance Monad m => Applicative (ChangeT m) where + pure x = ChangeT (return (Original x)) + ChangeT m1 <*> ChangeT m2 = ChangeT (liftM2 (<*>) m1 m2) + +instance Monad m => Monad (ChangeT m) where + return x = ChangeT (return (Original x)) + ChangeT m >>= k = ChangeT (m >>= f) + where f (Original x) = runChangeT (k x) + f (Modified x) = runChangeT (k x) >>= (return . taint) + +instance MonadTrans ChangeT where + lift m = ChangeT (liftM Original m) + +instance MonadIO m => MonadIO (ChangeT m) where + liftIO m = lift (liftIO m) + +instance Monad m => ChangeMonad (ChangeT m) where + preserve x (ChangeT m) = ChangeT (liftM (preserve x) m) + taint (ChangeT m) = ChangeT (liftM taint m) + modified x = ChangeT (return (modified x)) + +commitChangeT :: Monad m => ChangeT m a -> m a +commitChangeT (ChangeT m) = liftM commitChange m +-- ^ Is a natural transformation from @ChangeT m@ to @m@: +-- @commitChangeT (fmap f m) = fmap f (commitChangeT m)@ +-- @commitChangeT (lift m) = m@ +-- @commitChangeT (m >>= k) = commitChangeT m >>= (commitChangeT . k)@ +-- @commitChangeT (return x) = return x@ +-- @commitChangeT (taint m) = commitChangeT m@ + +preserveChangeT :: Monad m => a -> ChangeT m (m a) -> ChangeT m a +preserveChangeT x (ChangeT c) = ChangeT (c >>= k) + where k (Original _) = return (Original x) + k (Modified m) = liftM Modified m +-- ^ Satisfies @preserveChangeT x (return _) = return x@ and +-- @preserveChangeT _ (modified m) = taint (lift m)@. + +flatten :: Monad m => (a -> ChangeT m (m a)) -> a -> ChangeT m a +flatten f x = ChangeT (runChangeT (f x) >>= k) + where k (Original _) = return (Original x) + k (Modified m) = liftM Modified m +-- ^ @flatten f x = preserveChangeT x (f x)@ diff --git a/saw-core/src/Verifier/SAW/Constant.hs b/saw-core/src/Verifier/SAW/Constant.hs new file mode 100644 index 0000000000..8b124445bc --- /dev/null +++ b/saw-core/src/Verifier/SAW/Constant.hs @@ -0,0 +1,19 @@ +{- | +Module : Verifier.SAW.Constant +Copyright : Galois, Inc. 2012-2015 +License : BSD3 +Maintainer : huffman@galois.com +Stability : experimental +Portability : non-portable (language extensions) +-} + +module Verifier.SAW.Constant (scConst) where +import Verifier.SAW.SharedTerm +import Verifier.SAW.Rewriter +import Verifier.SAW.Conversion + +scConst :: SharedContext -> String -> Term -> IO Term +scConst sc name t = do + ty <- scTypeOf sc t + ty' <- rewriteSharedTerm sc (addConvs natConversions emptySimpset) ty + scConstant sc name t ty' diff --git a/saw-core/src/Verifier/SAW/Conversion.hs b/saw-core/src/Verifier/SAW/Conversion.hs new file mode 100644 index 0000000000..8fbd8d74e4 --- /dev/null +++ b/saw-core/src/Verifier/SAW/Conversion.hs @@ -0,0 +1,728 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DoAndIfThenElse #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE IncoherentInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +{- | +Module : Verifier.SAW.Conversion +Copyright : Galois, Inc. 2012-2015 +License : BSD3 +Maintainer : jhendrix@galois.com +Stability : experimental +Portability : non-portable (language extensions) +-} + +module Verifier.SAW.Conversion + ( (:*:)(..) + , Net.toPat + , termToPat + -- * Matcher + , Matcher + , matcherPat + , runMatcher + , thenMatcher + , asVar + , asAny + -- ** Matcher arguments + , ArgsMatcher(..) + , ArgsMatchable + , asEmpty + , (>:) + , runArgsMatcher + -- ** Term matchers + , asGlobalDef + , (<:>) + , (<:>>) + , asAnyTupleValue + , asTupleValue + , asAnyTupleType + , asTupleType + , asTupleSelector + , asAnyRecordValue + , asAnyRecordType + , asRecordSelector + , asCtor + , asDataType + , asAnySort + , asSort + , asAnyNatLit + , asAnyVecLit + , asExtCns + , asLocalVar + -- ** Prelude matchers + , asBoolType + , asSuccLit + , asBvNatLit + -- ** Matchable typeclass + , Matchable(..) + -- ** TermBuilder + , TermBuilder + , runTermBuilder + , mkGlobalDef + , mkApp + , pureApp + , mkTuple + , mkCtor + , mkDataType + , mkNatLit + , mkVecLit + -- ** Prelude builders + , mkBool + , mkBvNat + -- * Conversion + , Conversion(..) + , runConversion + -- ** Prelude conversions + , tupleConversion + , recordConversion + , eq_Tuple + , eq_Record + , natConversions + , vecConversions + , bvConversions + , zero_NatLit + , succ_NatLit + , addNat_NatLit + , append_VecLit + , append_bvNat + , bvAdd_bvNat + , bvSub_bvNat + , bvule_bvNat + , bvult_bvNat + , bvsle_bvNat + , bvslt_bvNat + , slice_bvNat + , remove_coerce + , remove_unsafeCoerce + , remove_ident_coerce + , remove_ident_unsafeCoerce + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative (Applicative(..), (<$>), (<*>)) +#endif +import Control.Lens (view, _1, _2) +import Control.Monad (ap, guard, liftM, liftM2, (>=>), (<=<)) +import Data.Bits +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Data.Vector as V +import Numeric.Natural (Natural) + +import qualified Verifier.SAW.Prim as Prim +import Verifier.SAW.Recognizer ((:*:)(..)) +import Verifier.SAW.Prim +import qualified Verifier.SAW.Recognizer as R +import qualified Verifier.SAW.TermNet as Net +import Verifier.SAW.Utils (panic) +import Verifier.SAW.Term.Functor + +-- | A hack to allow storage of conversions in a term net. +instance Eq Conversion where + x == y = Net.toPat x == Net.toPat y + +instance Show Conversion where + show x = show (Net.toPat x) + +---------------------------------------------------------------------- +-- Matchers for terms + +data Matcher a = Matcher { matcherPat :: Net.Pat, runMatcher :: Term -> Maybe a } + +instance Net.Pattern (Matcher a) where + toPat = matcherPat + +instance Functor Matcher where + fmap f (Matcher p m) = Matcher p (fmap f . m) + +-- | @thenMatcher +thenMatcher :: Matcher a -> (a -> Maybe b) -> Matcher b +thenMatcher (Matcher pat match) f = Matcher pat (f <=< match) + +asVar :: (Term -> Maybe a) -> Matcher a +asVar = Matcher Net.Var + +asAny :: Matcher Term +asAny = asVar pure + +-- | Match a list of terms as arguments to a term. +-- Note that the pats and arguments are in reverse order. +data ArgsMatcher a = ArgsMatcher [Net.Pat] ([Term] -> Maybe (a, [Term])) + +class ArgsMatchable v a where + defaultArgsMatcher :: v a -> ArgsMatcher a + +instance ArgsMatchable Matcher a where + defaultArgsMatcher (Matcher p f) = ArgsMatcher [p] match + where match (h:r) = do v <- f h; return (v,r) + match [] = Nothing + +instance ArgsMatchable ArgsMatcher a where + defaultArgsMatcher = id + +consArgsMatcher :: ArgsMatcher a -> Matcher b -> ArgsMatcher (a :*: b) +consArgsMatcher (ArgsMatcher pl f) (Matcher p g) = ArgsMatcher (pl ++ [p]) match + where match l = do + (a,l1) <- f l + case l1 of + (h:l2) -> do b <- g h; return (a :*: b, l2) + [] -> Nothing + +asEmpty :: ArgsMatcher () +asEmpty = ArgsMatcher [] (\l -> return ((),l)) + +infixl 9 >: + +-- | @x >: y@ appends @y@ to the list of arguments to match. +(>:) :: (ArgsMatchable v a) => v a -> Matcher b -> ArgsMatcher (a :*: b) +(>:) = consArgsMatcher . defaultArgsMatcher + +runArgsMatcher :: ArgsMatcher a -> [Term] -> Maybe a +runArgsMatcher (ArgsMatcher _ f) l = do + (v,[]) <- f l + return v + +-- | Produces a matcher from an ArgsMatcher and a matcher that yields +-- subterms. +resolveArgs :: (ArgsMatchable v a) + -- Given a term, matches arguments to term. + => Matcher [Term] + -> v a + -> Matcher a +resolveArgs (Matcher p m) (defaultArgsMatcher -> args@(ArgsMatcher pl _)) = + Matcher (foldl Net.App p pl) (m >=> runArgsMatcher args) + +---------------------------------------------------------------------- +-- Term matchers + +-- | Match a global definition. +asGlobalDef :: Ident -> Matcher () +asGlobalDef ident = Matcher (Net.Atom (identText ident)) f + where f (R.asGlobalDef -> Just o) | ident == o = return () + f _ = Nothing + +infixl 8 <:> + +-- | Match an application +(<:>) :: Matcher a -> Matcher b -> Matcher (a :*: b) +(<:>) (Matcher p1 f1) (Matcher p2 f2) = Matcher (Net.App p1 p2) match + where + match (unwrapTermF -> App t1 t2) = liftM2 (:*:) (f1 t1) (f2 t2) + match _ = Nothing + +-- | Match an application and return second term. +(<:>>) :: Matcher a -> Matcher b -> Matcher b +x <:>> y = fmap (view _2) $ x <:> y + + +-- | Matches any tuple. +asAnyTupleValue :: Matcher [Term] +asAnyTupleValue = asVar R.asTupleValue + +-- | Matches a tuple with arguments matching constraints. +asTupleValue :: ArgsMatchable v a => v a -> Matcher a +asTupleValue (defaultArgsMatcher -> m) = asVar $ \t -> do + l <- R.asTupleValue t + runArgsMatcher m l + +-- | Matches the type of any tuple. +asAnyTupleType :: Matcher [Term] +asAnyTupleType = asVar R.asTupleType + +-- | Matches a tuple type with arguments matching constraints. +asTupleType :: ArgsMatchable v a => v a -> Matcher a +asTupleType (defaultArgsMatcher -> m) = asVar $ \t -> do + l <- R.asTupleType t + runArgsMatcher m l + +asTupleSelector :: Matcher a -> Matcher (a, Int) +asTupleSelector m = asVar $ \t -> _1 (runMatcher m) =<< R.asTupleSelector t + +-- | Matches record values, and returns fields. +asAnyRecordValue :: Matcher (Map FieldName Term) +asAnyRecordValue = asVar R.asRecordValue + +-- | Matches record types, and returns fields. +asAnyRecordType :: Matcher (Map FieldName Term) +asAnyRecordType = asVar R.asRecordType + +-- | Matches +asRecordSelector :: Matcher a -> Matcher (a, FieldName) +asRecordSelector m = asVar $ \t -> _1 (runMatcher m) =<< R.asRecordSelector t + +--TODO: RecordSelector + +-- | Match a constructor +asCtor :: ArgsMatchable v a => Ident -> v a -> Matcher a +asCtor o = resolveArgs $ Matcher (Net.Atom (identText o)) match + where match t = do + CtorApp c params l <- R.asFTermF t + guard (c == o) + return (params ++ l) + +-- | Match a datatype. +asDataType :: ArgsMatchable v a => Ident -> v a -> Matcher a +asDataType o = resolveArgs $ Matcher (Net.Atom (identText o)) match + where match t = do + DataTypeApp dt params l <- R.asFTermF t + guard (dt == o) + return (params ++ l) + +-- | Match any sort. +asAnySort :: Matcher Sort +asAnySort = asVar $ \t -> do Sort v <- R.asFTermF t; return v + +-- | Match a specific sort. +asSort :: Sort -> Matcher () +asSort s = Matcher (termToPat (Unshared (FTermF (Sort s)))) fn + where fn t = do s' <- R.asSort t + guard (s == s') + +-- | Match a Nat literal +asAnyNatLit :: Matcher Natural +asAnyNatLit = asVar $ \t -> do NatLit i <- R.asFTermF t; return i + +-- | Match a Vec literal +asAnyVecLit :: Matcher (Term, V.Vector Term) +asAnyVecLit = asVar $ \t -> do ArrayValue u xs <- R.asFTermF t; return (u,xs) + +-- | Match any external constant. +asExtCns :: Matcher (ExtCns Term) +asExtCns = asVar $ \t -> do ExtCns ec <- R.asFTermF t; return ec + +-- | Returns index of local var if any. +asLocalVar :: Matcher DeBruijnIndex +asLocalVar = asVar $ \t -> do i <- R.asLocalVar t; return i + +---------------------------------------------------------------------- +-- Prelude matchers + +asBoolType :: Matcher () +asBoolType = asGlobalDef "Prelude.Bool" + +asSuccLit :: Matcher Natural +asSuccLit = asCtor "Prelude.Succ" asAnyNatLit + +asBvNatLit :: Matcher Prim.BitVector +asBvNatLit = + (\(_ :*: n :*: x) -> Prim.bv (fromIntegral n) (toInteger x)) <$> + (asGlobalDef "Prelude.bvNat" <:> asAnyNatLit <:> asAnyNatLit) + +checkedIntegerToNonNegInt :: Integer -> Maybe Int +checkedIntegerToNonNegInt x + | 0 <= x && x <= toInteger (maxBound :: Int) = return (fromInteger x) + | otherwise = Nothing + +---------------------------------------------------------------------- +-- Matchable + +class Matchable a where + defaultMatcher :: Matcher a + +instance Matchable () where + defaultMatcher = asVar (const (pure ())) + +instance Matchable Term where + defaultMatcher = asAny + +instance Matchable Natural where + defaultMatcher = asAnyNatLit + +instance Matchable Integer where + defaultMatcher = toInteger <$> asAnyNatLit + +instance Matchable Int where + defaultMatcher = thenMatcher asAnyNatLit (checkedIntegerToNonNegInt . toInteger) + +instance Matchable Prim.BitVector where + defaultMatcher = asBvNatLit + +instance Matchable (Prim.Vec Term Term) where + defaultMatcher = uncurry Prim.Vec <$> asAnyVecLit + +---------------------------------------------------------------------- +-- Term builders + +newtype TermBuilder v = + TermBuilder + { runTermBuilder :: + forall m. Monad m => (Ident -> m Term) -> (TermF Term -> m Term) -> m v + } + +instance Monad TermBuilder where + m >>= h = TermBuilder $ \mg mk -> do + r <- runTermBuilder m mg mk + runTermBuilder (h r) mg mk + return v = TermBuilder $ \_ _ -> return v + +instance Functor TermBuilder where + fmap = liftM + +instance Applicative TermBuilder where + pure = return + (<*>) = ap + +mkTermF :: TermF Term -> TermBuilder Term +mkTermF tf = TermBuilder (\_ mk -> mk tf) + +mkGlobalDef :: Ident -> TermBuilder Term +mkGlobalDef i = TermBuilder (\mg _ -> mg i) + +infixl 9 `mkApp` +infixl 9 `pureApp` + +mkApp :: TermBuilder Term -> TermBuilder Term -> TermBuilder Term +mkApp mx my = do + x <- mx + y <- my + mkTermF (App x y) + +pureApp :: TermBuilder Term -> Term -> TermBuilder Term +pureApp mx y = do + x <- mx + mkTermF (App x y) + +mkTuple :: [TermBuilder Term] -> TermBuilder Term +mkTuple [] = mkTermF (FTermF UnitValue) +mkTuple (t : ts) = mkTermF . FTermF =<< (PairValue <$> t <*> mkTuple ts) + +mkTupleSelector :: Int -> Term -> TermBuilder Term +mkTupleSelector i t + | i == 1 = mkTermF (FTermF (PairLeft t)) + | i > 1 = mkTermF (FTermF (PairRight t)) >>= mkTupleSelector (i - 1) + | otherwise = panic "Verifier.SAW.Conversion.mkTupleSelector" ["non-positive index:", show i] + +mkCtor :: Ident -> [TermBuilder Term] -> [TermBuilder Term] -> TermBuilder Term +mkCtor i paramsB argsB = + do params <- sequence paramsB + args <- sequence argsB + mkTermF $ FTermF $ CtorApp i params args + +mkDataType :: Ident -> [TermBuilder Term] -> [TermBuilder Term] -> + TermBuilder Term +mkDataType i paramsB argsB = + do params <- sequence paramsB + args <- sequence argsB + mkTermF $ FTermF $ DataTypeApp i params args + +mkNatLit :: Natural -> TermBuilder Term +mkNatLit n = mkTermF (FTermF (NatLit n)) + +mkVecLit :: Term -> V.Vector Term -> TermBuilder Term +mkVecLit t xs = mkTermF (FTermF (ArrayValue t xs)) + +mkBool :: Bool -> TermBuilder Term +mkBool True = mkGlobalDef "Prelude.True" +mkBool False = mkGlobalDef "Prelude.False" + +mkBvNat :: Natural -> Integer -> TermBuilder Term +mkBvNat n x = do + mkGlobalDef "Prelude.bvNat" + `mkApp` (mkNatLit n) + `mkApp` (mkNatLit $ fromInteger $ x .&. bitMask (fromIntegral n)) + +class Buildable a where + defaultBuilder :: a -> TermBuilder Term + +instance Buildable Term where + defaultBuilder = return + +instance Buildable Bool where + defaultBuilder = mkBool + +instance Buildable Natural where + defaultBuilder = mkNatLit + +instance Buildable Integer where + defaultBuilder = mkNatLit . fromInteger + +instance Buildable Int where + defaultBuilder = mkNatLit . fromIntegral + +instance (Buildable a, Buildable b) => Buildable (a, b) where + defaultBuilder (x, y) = mkTuple [defaultBuilder x, defaultBuilder y] + +instance Buildable (Prim.Vec Term Term) where + defaultBuilder (Prim.Vec t v) = mkVecLit t v + +instance Buildable Prim.BitVector where + defaultBuilder (Prim.BV w x) = mkBvNat (fromIntegral w) x + +---------------------------------------------------------------------- +-- Conversions + +-- | These are conversions in the LCF-style term-rewriting sense: A +-- conversion is a function that takes a term and returns (possibly) a +-- rewritten term. We use conversions to model the behavior of +-- primitive operations in SAWCore. + +newtype Conversion = Conversion (Matcher (TermBuilder Term)) + +instance Net.Pattern Conversion where + toPat (Conversion m) = Net.toPat m + +runConversion :: Conversion -> Term -> Maybe (TermBuilder Term) +runConversion (Conversion m) = runMatcher m + +-- | This class is meant to include n-ary function types whose +-- arguments are all in class @Matchable@ and whose result type is +-- in class @Buildable@. Given a matcher for the global constant +-- itself, we can construct a conversion that applies the function to +-- its arguments and builds the result. + +class Conversionable a where + convOfMatcher :: Matcher a -> Conversion + +instance (Matchable a, Conversionable b) => Conversionable (a -> b) where + convOfMatcher m = convOfMatcher + (thenMatcher (m <:> defaultMatcher) (\(f :*: x) -> Just (f x))) + +instance Buildable a => Conversionable (Maybe a) where + convOfMatcher m = Conversion (thenMatcher m (fmap defaultBuilder)) + +defaultConvOfMatcher :: Buildable a => Matcher a -> Conversion +defaultConvOfMatcher m = Conversion (thenMatcher m (Just . defaultBuilder)) + +instance Conversionable Term where + convOfMatcher = defaultConvOfMatcher + +instance Conversionable Bool where + convOfMatcher = defaultConvOfMatcher + +instance Conversionable Natural where + convOfMatcher = defaultConvOfMatcher + +instance Conversionable Integer where + convOfMatcher = defaultConvOfMatcher + +instance Conversionable Prim.BitVector where + convOfMatcher = defaultConvOfMatcher + +instance Conversionable (Prim.Vec Term Term) where + convOfMatcher = defaultConvOfMatcher + +instance (Buildable a, Buildable b) => Conversionable (a, b) where + convOfMatcher = defaultConvOfMatcher + +globalConv :: (Conversionable a) => Ident -> a -> Conversion +globalConv ident f = convOfMatcher (thenMatcher (asGlobalDef ident) (const (Just f))) + +---------------------------------------------------------------------- +-- Conversions for Prelude operations + +-- | Conversion for selector on a tuple +tupleConversion :: Conversion +tupleConversion = Conversion $ thenMatcher (asTupleSelector asAnyTupleValue) action + where + action (ts, i) + | i > length ts = + panic "Verifier.SAW.Conversion.tupleConversion" + ["index out of bounds:", show (i, length ts)] + | otherwise = + Just (return (ts !! (i - 1))) + +-- | Conversion for selector on a record +recordConversion :: Conversion +recordConversion = Conversion $ thenMatcher (asRecordSelector asAnyRecordValue) action + where action (m, i) = fmap return (Map.lookup i m) + +-- | Conversion for equality on tuple types +eq_Tuple :: Conversion +eq_Tuple = Conversion $ thenMatcher matcher action + where + matcher = asGlobalDef "Prelude.eq" <:> asAnyTupleType <:> asAny <:> asAny + action (_ :*: ts :*: x :*: y) = + Just (foldr mkAnd (mkBool True) (map mkEq (zip [1 ..] ts))) + where + mkAnd t1 t2 = mkGlobalDef "Prelude.and" `mkApp` t1 `mkApp` t2 + mkEq (i, t) = mkGlobalDef "Prelude.eq" + `mkApp` return t + `mkApp` mkTupleSelector i x + `mkApp` mkTupleSelector i y + +-- | Conversion for equality on record types +eq_Record :: Conversion +eq_Record = Conversion $ thenMatcher matcher action + where + matcher = asGlobalDef "Prelude.eq" <:> asAnyRecordType <:> asAny <:> asAny + action (_ :*: tm :*: x :*: y) = + Just (foldr mkAnd (mkBool True) (map mkEq (Map.assocs tm))) + where + mkAnd t1 t2 = mkGlobalDef "Prelude.and" `mkApp` t1 `mkApp` t2 + sel t i = mkTermF (FTermF (RecordProj t i)) + mkEq (i, t) = mkGlobalDef "Prelude.eq" + `mkApp` return t + `mkApp` sel x i + `mkApp` sel y i + +-- | Conversions for operations on Nat literals +natConversions :: [Conversion] +natConversions = [ zero_NatLit, succ_NatLit, addNat_NatLit, subNat_NatLit + , mulNat_NatLit, expNat_NatLit, divNat_NatLit, remNat_NatLit + , equalNat_NatLit + ] + +zero_NatLit :: Conversion +zero_NatLit = + Conversion $ + thenMatcher (asCtor "Prelude.Zero" asEmpty) (\_ -> return $ mkNatLit 0) + +succ_NatLit :: Conversion +succ_NatLit = + Conversion $ thenMatcher asSuccLit (\n -> return $ mkNatLit (n + 1)) + +addNat_NatLit :: Conversion +addNat_NatLit = globalConv "Prelude.addNat" ((+) :: Natural -> Natural -> Natural) + +subNat_NatLit :: Conversion +subNat_NatLit = Conversion $ + thenMatcher (asGlobalDef "Prelude.subNat" <:> asAnyNatLit <:> asAnyNatLit) + (\(_ :*: x :*: y) -> if x >= y then Just (mkNatLit (x - y)) else Nothing) + +mulNat_NatLit :: Conversion +mulNat_NatLit = globalConv "Prelude.mulNat" ((*) :: Natural -> Natural -> Natural) + +expNat_NatLit :: Conversion +expNat_NatLit = globalConv "Prelude.expNat" ((^) :: Natural -> Natural -> Natural) + +divNat_NatLit :: Conversion +divNat_NatLit = Conversion $ + thenMatcher (asGlobalDef "Prelude.divNat" <:> asAnyNatLit <:> asAnyNatLit) + (\(_ :*: x :*: y) -> + if y /= 0 then Just (mkNatLit (x `div` y)) else Nothing) + +remNat_NatLit :: Conversion +remNat_NatLit = Conversion $ + thenMatcher (asGlobalDef "Prelude.remNat" <:> asAnyNatLit <:> asAnyNatLit) + (\(_ :*: x :*: y) -> + if y /= 0 then Just (mkNatLit (x `rem` y)) else Nothing) + +equalNat_NatLit :: Conversion +equalNat_NatLit = globalConv "Prelude.equalNat" ((==) :: Natural -> Natural -> Bool) + +-- | Conversions for operations on vector literals +vecConversions :: [Conversion] +vecConversions = [at_VecLit, atWithDefault_VecLit, append_VecLit] + +at_VecLit :: Conversion +at_VecLit = globalConv "Prelude.at" + (Prim.at :: Int -> Term -> Prim.Vec Term Term -> Int -> Term) + +atWithDefault_VecLit :: Conversion +atWithDefault_VecLit = globalConv "Prelude.atWithDefault" + (Prim.atWithDefault :: Int -> Term -> Term -> Prim.Vec Term Term -> Int -> Term) + +append_VecLit :: Conversion +append_VecLit = globalConv "Prelude.append" + (Prim.append :: Int -> Int -> Term -> Prim.Vec Term Term -> Prim.Vec Term Term -> Prim.Vec Term Term) + + +-- | Conversions for operations on bitvector literals +bvConversions :: [Conversion] +bvConversions = + [ globalConv "Prelude.bvToNat" Prim.bvToNat + , append_bvNat + , bvAdd_bvNat + , globalConv "Prelude.bvAddWithCarry" Prim.bvAddWithCarry + , bvSub_bvNat + , globalConv "Prelude.bvNeg" Prim.bvNeg + , globalConv "Prelude.bvMul" Prim.bvMul + , globalConv "Prelude.bvUDiv" Prim.bvUDiv + , globalConv "Prelude.bvURem" Prim.bvURem + , globalConv "Prelude.bvSDiv" Prim.bvSDiv + , globalConv "Prelude.bvSRem" Prim.bvSRem + , globalConv "Prelude.bvShl" Prim.bvShl + , globalConv "Prelude.bvShr" Prim.bvShr + , globalConv "Prelude.bvSShr" Prim.bvSShr + , globalConv "Prelude.bvNot" Prim.bvNot + , globalConv "Prelude.bvAnd" Prim.bvAnd + , globalConv "Prelude.bvOr" Prim.bvOr + , globalConv "Prelude.bvXor" Prim.bvXor + , globalConv "Prelude.bvEq" Prim.bvEq + + , bvugt_bvNat, bvuge_bvNat, bvult_bvNat, bvule_bvNat + , bvsgt_bvNat, bvsge_bvNat, bvsle_bvNat, bvslt_bvNat + + , globalConv "Prelude.bvTrunc" Prim.bvTrunc + , globalConv "Prelude.bvUExt" Prim.bvUExt + , globalConv "Prelude.bvSExt" Prim.bvSExt + + , at_bvNat, atWithDefault_bvNat, slice_bvNat + , take_bvNat, drop_bvNat + ] + +append_bvNat :: Conversion +append_bvNat = globalConv "Prelude.append" Prim.append_bv + +bvAdd_bvNat :: Conversion +bvAdd_bvNat = globalConv "Prelude.bvAdd" Prim.bvAdd + +bvSub_bvNat :: Conversion +bvSub_bvNat = globalConv "Prelude.bvSub" Prim.bvSub + +bvugt_bvNat, bvuge_bvNat, bvult_bvNat, bvule_bvNat :: Conversion +bvugt_bvNat = globalConv "Prelude.bvugt" Prim.bvugt +bvuge_bvNat = globalConv "Prelude.bvuge" Prim.bvuge +bvult_bvNat = globalConv "Prelude.bvult" Prim.bvult +bvule_bvNat = globalConv "Prelude.bvule" Prim.bvule + +bvsgt_bvNat, bvsge_bvNat, bvslt_bvNat, bvsle_bvNat :: Conversion +bvsgt_bvNat = globalConv "Prelude.bvsgt" Prim.bvsgt +bvsge_bvNat = globalConv "Prelude.bvsge" Prim.bvsge +bvslt_bvNat = globalConv "Prelude.bvslt" Prim.bvslt +bvsle_bvNat = globalConv "Prelude.bvsle" Prim.bvsle + +at_bvNat :: Conversion +at_bvNat = globalConv "Prelude.at" Prim.at_bv + +atWithDefault_bvNat :: Conversion +atWithDefault_bvNat = + Conversion $ + (\(_ :*: n :*: a :*: d :*: x :*: i) -> + if fromIntegral i < width x then mkBool (Prim.at_bv n a x i) else return d) <$> + (asGlobalDef "Prelude.atWithDefault" <:> + defaultMatcher <:> defaultMatcher <:> asAny <:> asBvNatLit <:> asAnyNatLit) + +take_bvNat :: Conversion +take_bvNat = globalConv "Prelude.take" Prim.take_bv + +drop_bvNat :: Conversion +drop_bvNat = globalConv "Prelude.drop" Prim.drop_bv + +slice_bvNat :: Conversion +slice_bvNat = globalConv "Prelude.slice" Prim.slice_bv + +mixfix_snd :: (a :*: b) -> b +mixfix_snd (_ :*: y) = y + +remove_coerce :: Conversion +remove_coerce = Conversion $ + return . mixfix_snd <$> + (asGlobalDef "Prelude.coerce" <:> asAny <:> asAny <:> asAny <:> asAny) + +remove_unsafeCoerce :: Conversion +remove_unsafeCoerce = Conversion $ + return . mixfix_snd <$> + (asGlobalDef "Prelude.unsafeCoerce" <:> asAny <:> asAny <:> asAny) + +remove_ident_coerce :: Conversion +remove_ident_coerce = Conversion $ thenMatcher pat action + where pat = asGlobalDef "Prelude.coerce" <:> asAny <:> asAny <:> asAny <:> asAny + action (() :*: t :*: f :*: _prf :*: x) + | alphaEquiv t f = return (return x) + | otherwise = Nothing + +remove_ident_unsafeCoerce :: Conversion +remove_ident_unsafeCoerce = Conversion $ thenMatcher pat action + where pat = asGlobalDef "Prelude.unsafeCoerce" <:> asAny <:> asAny <:> asAny + action (() :*: t :*: f :*: x) + | alphaEquiv t f = return (return x) + | otherwise = Nothing diff --git a/saw-core/src/Verifier/SAW/ExternalFormat.hs b/saw-core/src/Verifier/SAW/ExternalFormat.hs new file mode 100644 index 0000000000..8f989dcfc8 --- /dev/null +++ b/saw-core/src/Verifier/SAW/ExternalFormat.hs @@ -0,0 +1,266 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE RankNTypes #-} + +{- | +Module : Verifier.SAW.ExternalFormat +Copyright : Galois, Inc. 2012-2015 +License : BSD3 +Maintainer : huffman@galois.com +Stability : experimental +Portability : non-portable (language extensions) +-} +module Verifier.SAW.ExternalFormat ( + scWriteExternal, scReadExternal + ) where + +import Control.Monad.State.Strict as State +#if !MIN_VERSION_base(4,8,0) +import Data.Traversable +#endif +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Data.Text as Text +import Data.Text (Text) +import Data.List (elemIndex) +import qualified Data.Vector as V +import Text.Read (readMaybe) +import Text.URI + +import Verifier.SAW.SharedTerm +import Verifier.SAW.TypedAST + +-------------------------------------------------------------------------------- +-- External text format + +-- | A string to use to separate parameters from normal arguments of datatypes +-- and constructors +argsep :: String +argsep = "|" + +-- | Separate a list of arguments into parameters and normal arguments by +-- finding the occurrence of 'argSep' in the list +separateArgs :: [String] -> Maybe ([String], [String]) +separateArgs args = + case elemIndex argsep args of + Just i -> Just (take i args, drop (i+1) args) + Nothing -> Nothing + +-- | Split the last element from the rest of a list, for non-empty lists +splitLast :: [a] -> Maybe ([a], a) +splitLast [] = Nothing +splitLast xs = Just (take (length xs - 1) xs, last xs) + +type WriteM = State.State (Map TermIndex Int, Map VarIndex NameInfo, [String], Int) + +renderNames :: Map VarIndex NameInfo -> String +renderNames nms = show + [ (idx, f nmi) + | (idx,nmi) <- Map.toList nms + ] + where + f (ModuleIdentifier i) = Left (show i) + f (ImportedName uri as) = Right (render uri, as) + +readNames :: String -> Maybe (Map VarIndex NameInfo) +readNames xs = Map.fromList <$> (mapM readName =<< readMaybe xs) + where + readName :: (VarIndex, Either Text (Text,[Text])) -> Maybe (VarIndex, NameInfo) + readName (idx, Left i) = pure (idx, ModuleIdentifier (parseIdent (Text.unpack i))) + readName (idx, Right (uri,as)) = + do uri' <- mkURI uri + pure (idx, ImportedName uri' as) + +-- | Render to external text format +scWriteExternal :: Term -> String +scWriteExternal t0 = + let (x, (_, nms, lns, _)) = State.runState (go t0) (Map.empty, Map.empty, [], 1) + in unlines $ + [ unwords ["SAWCoreTerm", show x] + , renderNames nms + ] ++ reverse lns + where + nextId :: WriteM Int + nextId = + do (m, nms, lns, x) <- State.get + State.put (m, nms, lns, x+1) + return x + output :: String -> WriteM () + output l = + do (m, nms, lns, x) <- State.get + State.put (m, nms, l:lns, x) + memoize :: TermIndex -> WriteM Int + memoize i = + do (m, nms, lns, x) <- State.get + State.put (Map.insert i x m, nms, lns, x+1) + return x + stashName :: ExtCns Int -> WriteM () + stashName ec = + do (m, nms, lns, x) <- State.get + State.put (m, Map.insert (ecVarIndex ec) (ecName ec) nms, lns, x) + + go :: Term -> WriteM Int + go (Unshared tf) = do + tf' <- traverse go tf + body <- writeTermF tf' + x <- nextId + output (unwords [show x, body]) + return x + + go STApp{ stAppIndex = i, stAppTermF = tf } = do + (memo, _, _, _) <- State.get + case Map.lookup i memo of + Just x -> return x + Nothing -> do + tf' <- traverse go tf + body <- writeTermF tf' + x <- memoize i + output (unwords [show x, body]) + return x + + writeTermF :: TermF Int -> WriteM String + writeTermF tf = + case tf of + App e1 e2 -> pure $ unwords ["App", show e1, show e2] + Lambda s t e -> pure $ unwords ["Lam", Text.unpack s, show t, show e] + Pi s t e -> pure $ unwords ["Pi", Text.unpack s, show t, show e] + LocalVar i -> pure $ unwords ["Var", show i] + Constant ec e -> + do stashName ec + pure $ unwords ["Constant", show (ecVarIndex ec), show (ecType ec), show e] + FTermF ftf -> + case ftf of + Primitive ec -> + do stashName ec + pure $ unwords ["Primitive", show (ecVarIndex ec), show (ecType ec)] + UnitValue -> pure $ unwords ["Unit"] + UnitType -> pure $ unwords ["UnitT"] + PairValue x y -> pure $ unwords ["Pair", show x, show y] + PairType x y -> pure $ unwords ["PairT", show x, show y] + PairLeft e -> pure $ unwords ["ProjL", show e] + PairRight e -> pure $ unwords ["ProjR", show e] + CtorApp i ps es -> pure $ + unwords ("Ctor" : show i : map show ps ++ argsep : map show es) + DataTypeApp i ps es -> pure $ + unwords ("Data" : show i : map show ps ++ argsep : map show es) + RecursorApp i ps p_ret cs_fs ixs e -> pure $ + unwords (["Recursor" , show i] ++ map show ps ++ + [argsep, show p_ret, show cs_fs] ++ + map show ixs ++ [show e]) + RecordType elem_tps -> pure $ unwords ["RecordType", show elem_tps] + RecordValue elems -> pure $ unwords ["Record", show elems] + RecordProj e prj -> pure $ unwords ["RecordProj", show e, Text.unpack prj] + Sort s -> pure $ + if s == propSort then unwords ["Prop"] else + unwords ["Sort", drop 5 (show s)] -- Ugly hack to drop "sort " + NatLit n -> pure $ unwords ["Nat", show n] + ArrayValue e v -> pure $ unwords ("Array" : show e : + map show (V.toList v)) + StringLit s -> pure $ unwords ["String", show s] + ExtCns ec -> + do stashName ec + pure $ unwords ["ExtCns",show (ecVarIndex ec), show (ecType ec)] + + +-- | During parsing, we maintain two maps used for renumbering: The +-- first is for the 'Int' values that appear in the external core +-- file, and the second is for the 'VarIndex' values that appear +-- inside 'Constant' and 'ExtCns' constructors. We do not reuse any +-- such numbers that appear in the external file, but generate fresh +-- ones that are valid in the current 'SharedContext'. +type ReadM = State.StateT (Map Int Term, Map VarIndex NameInfo, Map VarIndex VarIndex) IO + +scReadExternal :: SharedContext -> String -> IO Term +scReadExternal sc input = + case lines input of + ( (words -> ["SAWCoreTerm", final]) : nmlist : rows ) -> + case readNames nmlist of + Nothing -> fail "scReadExternal: failed to parse name table" + Just nms -> + State.evalStateT (mapM_ (go . words) rows >> readIdx final) (Map.empty, nms, Map.empty) + + _ -> fail "scReadExternal: failed to parse input file" + where + go :: [String] -> ReadM () + go (tok : tokens) = + do i <- readM tok + tf <- parse tokens + t <- lift $ scTermF sc tf + (ts, nms, vs) <- State.get + put (Map.insert i t ts, nms, vs) + go [] = pure () -- empty lines are ignored + + readM :: forall a. Read a => String -> ReadM a + readM tok = + case readMaybe tok of + Nothing -> fail $ "scReadExternal: parse error: " ++ show tok + Just x -> pure x + + getTerm :: Int -> ReadM Term + getTerm i = + do (ts,_,_) <- State.get + case Map.lookup i ts of + Nothing -> fail $ "scReadExternal: invalid term index: " ++ show i + Just t -> pure t + + readIdx :: String -> ReadM Term + readIdx tok = getTerm =<< readM tok + + readEC :: String -> String -> ReadM (ExtCns Term) + readEC i t = + do vi <- readM i + t' <- readIdx t + (ts, nms, vs) <- State.get + nmi <- case Map.lookup vi nms of + Just nmi -> pure nmi + Nothing -> lift $ fail $ "scReadExternal: ExtCns missing name info: " ++ show vi + case Map.lookup vi vs of + Just vi' -> pure $ EC vi' nmi t' + Nothing -> + do vi' <- lift $ scFreshGlobalVar sc + State.put (ts, nms, Map.insert vi vi' vs) + pure $ EC vi' nmi t' + + parse :: [String] -> ReadM (TermF Term) + parse tokens = + case tokens of + ["App", e1, e2] -> App <$> readIdx e1 <*> readIdx e2 + ["Lam", x, t, e] -> Lambda (Text.pack x) <$> readIdx t <*> readIdx e + ["Pi", s, t, e] -> Pi (Text.pack s) <$> readIdx t <*> readIdx e + ["Var", i] -> pure $ LocalVar (read i) + ["Constant",i,t,e] -> Constant <$> readEC i t <*> readIdx e + ["Primitive", i, t] -> FTermF <$> (Primitive <$> readEC i t) + ["Unit"] -> pure $ FTermF UnitValue + ["UnitT"] -> pure $ FTermF UnitType + ["Pair", x, y] -> FTermF <$> (PairValue <$> readIdx x <*> readIdx y) + ["PairT", x, y] -> FTermF <$> (PairType <$> readIdx x <*> readIdx y) + ["ProjL", x] -> FTermF <$> (PairLeft <$> readIdx x) + ["ProjR", x] -> FTermF <$> (PairRight <$> readIdx x) + ("Ctor" : i : (separateArgs -> Just (ps, es))) -> + FTermF <$> (CtorApp (parseIdent i) <$> traverse readIdx ps <*> traverse readIdx es) + ("Data" : i : (separateArgs -> Just (ps, es))) -> + FTermF <$> (DataTypeApp (parseIdent i) <$> traverse readIdx ps <*> traverse readIdx es) + ("Recursor" : i : + (separateArgs -> + Just (ps, p_ret : cs_fs : (splitLast -> Just (ixs, arg))))) -> + FTermF <$> + (RecursorApp (parseIdent i) <$> + traverse readIdx ps <*> + readIdx p_ret <*> + (traverse (traverse getTerm) =<< readM cs_fs) <*> + traverse readIdx ixs <*> + readIdx arg) + ["RecordType", elem_tps] -> + FTermF <$> (RecordType <$> (traverse (traverse getTerm) =<< readM elem_tps)) + ["Record", elems] -> + FTermF <$> (RecordValue <$> (traverse (traverse getTerm) =<< readM elems)) + ["RecordProj", e, prj] -> FTermF <$> (RecordProj <$> readIdx e <*> pure (Text.pack prj)) + ["Prop"] -> pure $ FTermF (Sort propSort) + ["Sort", s] -> FTermF <$> (Sort <$> (mkSort <$> readM s)) + ["Nat", n] -> FTermF <$> (NatLit <$> readM n) + ("Array" : e : es) -> FTermF <$> (ArrayValue <$> readIdx e <*> (V.fromList <$> traverse readIdx es)) + ("String" : ts) -> FTermF <$> (StringLit <$> (readM (unwords ts))) + ["ExtCns", i, t] -> FTermF <$> (ExtCns <$> readEC i t) + _ -> fail $ "Parse error: " ++ unwords tokens diff --git a/saw-core/src/Verifier/SAW/FiniteValue.hs b/saw-core/src/Verifier/SAW/FiniteValue.hs new file mode 100644 index 0000000000..13addd7c54 --- /dev/null +++ b/saw-core/src/Verifier/SAW/FiniteValue.hs @@ -0,0 +1,335 @@ +{-# LANGUAGE CPP #-} + +{- | +Module : Verifier.SAW.FiniteValue +Copyright : Galois, Inc. 2012-2015 +License : BSD3 +Maintainer : huffman@galois.com +Stability : experimental +Portability : non-portable (language extensions) +-} +module Verifier.SAW.FiniteValue where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +import Data.Traversable +#endif + +import Control.Monad (mzero) +import Control.Monad.Trans (lift) +import Control.Monad.Trans.Maybe +import qualified Control.Monad.State as S +import Data.List (intersperse) +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Data.Text as Text +import Numeric.Natural (Natural) + +import Prettyprinter hiding (Doc) + +import qualified Verifier.SAW.Recognizer as R +import Verifier.SAW.SharedTerm +import Verifier.SAW.TypedAST +import Verifier.SAW.Term.Pretty + +-- | Finite types that can be encoded as bits for a SAT/SMT solver. +data FiniteType + = FTBit + | FTVec Natural FiniteType + | FTTuple [FiniteType] + | FTRec (Map FieldName FiniteType) + deriving (Eq, Show) + +-- | Values inhabiting those finite types. +data FiniteValue + = FVBit Bool + | FVWord Natural Integer -- ^ a more efficient special case for 'FVVec FTBit _'. + | FVVec FiniteType [FiniteValue] + | FVTuple [FiniteValue] + | FVRec (Map FieldName FiniteValue) + deriving Eq + +-- | First-order types that can be encoded in an SMT solver. +data FirstOrderType + = FOTBit + | FOTInt + | FOTIntMod Natural + | FOTVec Natural FirstOrderType + | FOTArray FirstOrderType FirstOrderType + | FOTTuple [FirstOrderType] + | FOTRec (Map FieldName FirstOrderType) + deriving (Eq, Show) + +-- | Values inhabiting those first-order types. +data FirstOrderValue + = FOVBit Bool + | FOVInt Integer + | FOVIntMod Natural Integer + | FOVWord Natural Integer -- ^ a more efficient special case for 'FOVVec FOTBit _'. + | FOVVec FirstOrderType [FirstOrderValue] + | FOVArray FirstOrderType FirstOrderType + | FOVTuple [FirstOrderValue] + | FOVRec (Map FieldName FirstOrderValue) + deriving Eq + +toFirstOrderType :: FiniteType -> FirstOrderType +toFirstOrderType ft = + case ft of + FTBit -> FOTBit + FTVec n t -> FOTVec n (toFirstOrderType t) + FTTuple ts -> FOTTuple (map toFirstOrderType ts) + FTRec tm -> FOTRec (fmap toFirstOrderType tm) + +toFirstOrderValue :: FiniteValue -> FirstOrderValue +toFirstOrderValue fv = + case fv of + FVBit b -> FOVBit b + FVWord w i -> FOVWord w i + FVVec t vs -> FOVVec (toFirstOrderType t) (map toFirstOrderValue vs) + FVTuple vs -> FOVTuple (map toFirstOrderValue vs) + FVRec vm -> FOVRec (fmap toFirstOrderValue vm) + + +toFiniteType :: FirstOrderType -> Maybe FiniteType +toFiniteType FOTBit = pure FTBit +toFiniteType (FOTVec n t) = FTVec n <$> toFiniteType t +toFiniteType (FOTTuple ts) = FTTuple <$> traverse toFiniteType ts +toFiniteType (FOTRec fs) = FTRec <$> traverse toFiniteType fs +toFiniteType FOTInt{} = Nothing +toFiniteType FOTIntMod{} = Nothing +toFiniteType FOTArray{} = Nothing + +instance Show FiniteValue where + showsPrec p fv = showsPrec p (toFirstOrderValue fv) + +instance Show FirstOrderValue where + showsPrec _ fv = + case fv of + FOVBit b -> shows b + FOVInt i -> shows i + FOVIntMod _ i -> shows i + FOVWord _ x -> shows x + FOVVec _ vs -> showString "[" . commaSep (map shows vs) . showString "]" + FOVArray{} -> shows $ firstOrderTypeOf fv + FOVTuple vs -> showString "(" . commaSep (map shows vs) . showString ")" + FOVRec vm -> showString "{" . commaSep (map showField (Map.assocs vm)) . showString "}" + where + commaSep ss = foldr (.) id (intersperse (showString ",") ss) + showField (field, v) = showString (Text.unpack field) . showString " = " . shows v + +ppFiniteValue :: PPOpts -> FiniteValue -> SawDoc +ppFiniteValue opts fv = ppFirstOrderValue opts (toFirstOrderValue fv) + +ppFirstOrderValue :: PPOpts -> FirstOrderValue -> SawDoc +ppFirstOrderValue opts = loop + where + loop fv = case fv of + FOVBit b + | b -> pretty "True" + | otherwise -> pretty "False" + FOVInt i -> pretty i + FOVIntMod _ i -> pretty i + FOVWord _w i -> ppNat opts i + FOVVec _ xs -> brackets (sep (punctuate comma (map loop xs))) + FOVArray{} -> viaShow $ firstOrderTypeOf fv + FOVTuple xs -> parens (sep (punctuate comma (map loop xs))) + FOVRec xs -> braces (sep (punctuate comma (map ppField (Map.toList xs)))) + where ppField (f,x) = pretty f <+> pretty '=' <+> loop x + + +-- | Smart constructor +fvVec :: FiniteType -> [FiniteValue] -> FiniteValue +fvVec t vs = + case (t, traverse toBit vs) of + (FTBit, Just bs) -> FVWord (fromIntegral (length bs)) (fromBits bs) + _ -> FVVec t vs + where + toBit :: FiniteValue -> Maybe Bool + toBit (FVBit b) = Just b + toBit _ = Nothing + + fromBits :: [Bool] -> Integer + fromBits = foldl (\n b -> 2*n + if b then 1 else 0) 0 + +-- | Smart constructor +fovVec :: FirstOrderType -> [FirstOrderValue] -> FirstOrderValue +fovVec t vs = + case (t, traverse toBit vs) of + (FOTBit, Just bs) -> FOVWord (fromIntegral (length bs)) (fromBits bs) + _ -> FOVVec t vs + where + toBit :: FirstOrderValue -> Maybe Bool + toBit (FOVBit b) = Just b + toBit _ = Nothing + + fromBits :: [Bool] -> Integer + fromBits = foldl (\n b -> 2*n + if b then 1 else 0) 0 + +finiteTypeOf :: FiniteValue -> FiniteType +finiteTypeOf fv = + case fv of + FVBit _ -> FTBit + FVWord n _ -> FTVec n FTBit + FVVec t vs -> FTVec (fromIntegral (length vs)) t + FVTuple vs -> FTTuple (map finiteTypeOf vs) + FVRec vm -> FTRec (fmap finiteTypeOf vm) + +firstOrderTypeOf :: FirstOrderValue -> FirstOrderType +firstOrderTypeOf fv = + case fv of + FOVBit _ -> FOTBit + FOVInt _ -> FOTInt + FOVIntMod n _ -> FOTIntMod n + FOVWord n _ -> FOTVec n FOTBit + FOVVec t vs -> FOTVec (fromIntegral (length vs)) t + -- Note: FOVArray contains type information, but not an actual Array value, + -- because it is not possible to obtain Array values from SMT solvers. This + -- is needed to display a counterexample that includes variables of Array + -- type. + FOVArray t1 t2 -> FOTArray t1 t2 + FOVTuple vs -> FOTTuple (map firstOrderTypeOf vs) + FOVRec vm -> FOTRec (fmap firstOrderTypeOf vm) + +-- | Compute the number of bits in the type +sizeFiniteType :: FiniteType -> Int +sizeFiniteType x = + case x of + FTBit -> 1 + FTVec n xs -> fromIntegral n * sizeFiniteType xs + FTTuple xs -> sum (map sizeFiniteType xs) + FTRec xm -> sum (map sizeFiniteType (Map.elems xm)) + +asFiniteType :: SharedContext -> Term -> IO FiniteType +asFiniteType sc t = do + t' <- scWhnf sc t + case t' of + (R.asBoolType -> Just ()) + -> return FTBit + (R.isVecType return -> Just (n R.:*: tp)) + -> FTVec n <$> asFiniteType sc tp + (R.asTupleType -> Just ts) + -> FTTuple <$> traverse (asFiniteType sc) ts + (R.asRecordType -> Just tm) + -> FTRec <$> traverse (asFiniteType sc) tm + _ -> fail $ "asFiniteType: unsupported argument type: " ++ scPrettyTerm defaultPPOpts t' + +asFirstOrderType :: SharedContext -> Term -> IO FirstOrderType +asFirstOrderType sc t = maybe err pure =<< runMaybeT (asFirstOrderTypeMaybe sc t) + where + err = + do t' <- scWhnf sc t + fail ("asFirstOrderType: unsupported argument type: " ++ scPrettyTerm defaultPPOpts t') + +asFirstOrderTypeMaybe :: SharedContext -> Term -> MaybeT IO FirstOrderType +asFirstOrderTypeMaybe sc t = + do t' <- lift (scWhnf sc t) + case t' of + (R.asBoolType -> Just ()) + -> return FOTBit + (R.asIntegerType -> Just ()) + -> return FOTInt + (R.asIntModType -> Just n) + -> return (FOTIntMod n) + (R.isVecType return -> Just (n R.:*: tp)) + -> FOTVec n <$> asFirstOrderTypeMaybe sc tp + (R.asArrayType -> Just (tp1 R.:*: tp2)) -> do + tp1' <- asFirstOrderTypeMaybe sc tp1 + tp2' <- asFirstOrderTypeMaybe sc tp2 + return $ FOTArray tp1' tp2' + (R.asTupleType -> Just ts) + -> FOTTuple <$> traverse (asFirstOrderTypeMaybe sc) ts + (R.asRecordType -> Just tm) + -> FOTRec <$> traverse (asFirstOrderTypeMaybe sc) tm + _ -> mzero + + +asFiniteTypePure :: Term -> Maybe FiniteType +asFiniteTypePure t = + case t of + (R.asBoolType -> Just ()) -> Just FTBit + (R.isVecType return -> Just (n R.:*: tp)) -> FTVec n <$> asFiniteTypePure tp + (R.asTupleType -> Just ts) -> FTTuple <$> traverse asFiniteTypePure ts + (R.asRecordType -> Just tm) -> FTRec <$> traverse asFiniteTypePure tm + _ -> Nothing + +-- The definitions of the next two functions depend on the encoding of +-- tuples that we want to use. Maybe it is better not to include them +-- in this library, and we should have them in the SAWScript project +-- instead. + +-- | Convert a finite type to a Term. +scFiniteType :: SharedContext -> FiniteType -> IO Term +scFiniteType sc ft = scFirstOrderType sc (toFirstOrderType ft) + +-- | Convert a finite type to a Term. +scFirstOrderType :: SharedContext -> FirstOrderType -> IO Term +scFirstOrderType sc ft = + case ft of + FOTBit -> scBoolType sc + FOTInt -> scIntegerType sc + FOTIntMod n -> scIntModType sc =<< scNat sc n + FOTVec n t -> do n' <- scNat sc n + t' <- scFirstOrderType sc t + scVecType sc n' t' + FOTArray t1 t2 -> do t1' <- scFirstOrderType sc t1 + t2' <- scFirstOrderType sc t2 + scArrayType sc t1' t2' + FOTTuple ts -> scTupleType sc =<< traverse (scFirstOrderType sc) ts + FOTRec tm -> + scRecordType sc =<< (Map.assocs <$> traverse (scFirstOrderType sc) tm) + +-- | Convert a finite value to a SharedTerm. +scFiniteValue :: SharedContext -> FiniteValue -> IO Term +scFiniteValue sc fv = scFirstOrderValue sc (toFirstOrderValue fv) + +-- | Convert a finite value to a SharedTerm. +scFirstOrderValue :: SharedContext -> FirstOrderValue -> IO Term +scFirstOrderValue sc fv = + case fv of + FOVBit b -> scBool sc b + FOVInt i + | i >= 0 -> scNatToInt sc =<< scNat sc (fromInteger i) + | True -> scIntNeg sc =<< scNatToInt sc =<< scNat sc (fromInteger (- i)) + FOVIntMod 0 i -> + do n' <- scNat sc 0 + scToIntMod sc n' =<< scFirstOrderValue sc (FOVInt i) + FOVIntMod n i -> + do n' <- scNat sc n + i' <- scNatToInt sc =<< scNat sc (fromInteger (i `mod` toInteger n)) + scToIntMod sc n' i' + FOVWord n x -> scBvConst sc n x + FOVVec t vs -> do t' <- scFirstOrderType sc t + vs' <- traverse (scFirstOrderValue sc) vs + scVector sc t' vs' + FOVArray t1 t2 -> do t1' <- scFirstOrderType sc t1 + t2' <- scFirstOrderType sc t2 + scArrayType sc t1' t2' + FOVTuple vs -> scTuple sc =<< traverse (scFirstOrderValue sc) vs + FOVRec vm -> scRecord sc =<< traverse (scFirstOrderValue sc) vm + +-- Parsing values from lists of booleans --------------------------------------- + +readFiniteValue' :: FiniteType -> S.StateT [Bool] Maybe FiniteValue +readFiniteValue' ft = + case ft of + FTBit -> do bs <- S.get + case bs of + [] -> S.lift Nothing + b : bs' -> S.put bs' >> return (FVBit b) + FTVec n t -> fvVec t <$> S.replicateM (fromIntegral n) (readFiniteValue' t) + FTTuple ts -> FVTuple <$> traverse readFiniteValue' ts + FTRec tm -> FVRec <$> traverse readFiniteValue' tm + +readFiniteValues :: [FiniteType] -> [Bool] -> Maybe [FiniteValue] +readFiniteValues ts bs = do + (vs, rest) <- S.runStateT (traverse readFiniteValue' ts) bs + case rest of + [] -> return vs + _ -> Nothing + +readFiniteValue :: FiniteType -> [Bool] -> Maybe FiniteValue +readFiniteValue t bs = do + (v, rest) <- S.runStateT (readFiniteValue' t) bs + case rest of + [] -> return v + _ -> Nothing diff --git a/saw-core/src/Verifier/SAW/Grammar.y b/saw-core/src/Verifier/SAW/Grammar.y new file mode 100644 index 0000000000..498f2a1065 --- /dev/null +++ b/saw-core/src/Verifier/SAW/Grammar.y @@ -0,0 +1,365 @@ +{ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} + +{- | +Module : Verifier.SAW.Grammar +Copyright : Galois, Inc. 2012-2014 +License : BSD3 +Maintainer : jhendrix@galois.com +Stability : experimental +Portability : non-portable (language extensions) +-} + +module Verifier.SAW.Grammar + ( Decl(..) + , Term(..) + , parseSAW + , parseSAWTerm + , lexer + ) where + +import Control.Applicative ((<$>)) +import Control.Monad () +import Control.Monad.State (State, get, gets, modify, put, runState, evalState) +import Control.Monad.Except (ExceptT, throwError, runExceptT) +import qualified Data.ByteString.Lazy.UTF8 as B +import Data.Maybe (isJust) +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Traversable +import Data.Word +import Numeric.Natural +import System.Directory (getCurrentDirectory) + +import Prelude hiding (mapM, sequence) + +import Verifier.SAW.UntypedAST +import Verifier.SAW.Module (DefQualifier(..)) +import Verifier.SAW.Lexer + +} + +%name parseSAW2 Module +%name parseSAWTerm2 Term + +%tokentype { PosPair Token } +%monad { Parser } +%lexer { lexer } { PosPair _ TEnd } +%error { parseError } +%expect 0 + +%token + '#' { PosPair _ (TKey "#") } + '->' { PosPair _ (TKey "->") } + '=' { PosPair _ (TKey "=") } + '\\' { PosPair _ (TKey "\\") } + ';' { PosPair _ (TKey ";") } + ':' { PosPair _ (TKey ":") } + ',' { PosPair _ (TKey ",") } + '.' { PosPair _ (TKey ".") } + '(' { PosPair _ (TKey "(") } + ')' { PosPair _ (TKey ")") } + '[' { PosPair _ (TKey "[") } + ']' { PosPair _ (TKey "]") } + '{' { PosPair _ (TKey "{") } + '}' { PosPair _ (TKey "}") } + '|' { PosPair _ (TKey "|") } + '*' { PosPair _ (TKey "*") } + 'data' { PosPair _ (TKey "data") } + 'hiding' { PosPair _ (TKey "hiding") } + 'import' { PosPair _ (TKey "import") } + 'module' { PosPair _ (TKey "module") } + 'sort' { PosPair _ (TKey "sort") } + 'Prop' { PosPair _ (TKey "Prop") } + 'where' { PosPair _ (TKey "where") } + 'axiom' { PosPair _ (TKey "axiom") } + 'primitive' { PosPair _ (TKey "primitive") } + nat { PosPair _ (TNat _) } + '_' { PosPair _ (TIdent "_") } + ident { PosPair _ (TIdent _) } + identrec { PosPair _ (TRecursor _) } + string { PosPair _ (TString _) } + +%% + +Module :: { Module } +Module : 'module' ModuleName 'where' list(Import) list(SAWDecl) { Module $2 $4 $5 } + +ModuleName :: { PosPair ModuleName } +ModuleName : sepBy (Ident, '.') { mkPosModuleName $1 } + +Import :: { Import } +Import : 'import' ModuleName opt(ModuleImports) ';' + { Import $2 $3 } + +SAWDecl :: { Decl } +SAWDecl : 'data' Ident VarCtx ':' LTerm 'where' '{' list(CtorDecl) '}' + { DataDecl $2 $3 $5 $8 } + | 'primitive' Ident ':' LTerm ';' + { TypeDecl PrimQualifier $2 $4 } + | 'axiom' Ident ':' LTerm ';' + { TypeDecl AxiomQualifier $2 $4 } + | Ident ':' LTerm opt(DefBody) ';' { maybe (TypeDecl NoQualifier $1 $3) + (TypedDef $1 [] $3) $4 } + | Ident list(TermVar) '=' LTerm ';' { TermDef $1 $2 $4 } + | Ident VarCtxItem VarCtx ':' LTerm '=' LTerm ';' { TypedDef $1 ($2 ++ $3) $5 $7 } + +DefBody :: { Term } +DefBody : '=' LTerm { $2 } + +ModuleImports :: { ImportConstraint } +ModuleImports : 'hiding' ImportNames { HidingImports $2 } + | ImportNames { SpecificImports $1 } + +ImportNames :: { [String] } +ImportNames : '(' sepBy(ImportName, ',') ')' { $2 } + +ImportName :: { String } +ImportName : ident { tokIdent $ val $1 } + +TermVar :: { TermVar } +TermVar + : Ident { TermVar $1 } + | '_' { UnusedVar (pos $1) } + +-- A context of variables which may or may not be typed +DefVarCtx :: { [(TermVar, Maybe Term)] } +DefVarCtx : list(DefVarCtxItem) { concat $1 } + +DefVarCtxItem :: { [(TermVar, Maybe Term)] } +DefVarCtxItem : TermVar { [($1, Nothing)] } + | '(' list(TermVar) ':' LTerm ')' + { map (\var -> (var, Just $4)) $2 } + +-- A context of variables, all of which must be typed; i.e., a list syntactic +-- elements of the form (x y z :: tp) (x2 y3 :: tp2) ... +VarCtx :: { [(TermVar, Term)] } +VarCtx : list(VarCtxItem) { concat $1 } + +VarCtxItem :: { [(TermVar, Term)] } +VarCtxItem : '(' list(TermVar) ':' LTerm ')' { map (\var -> (var,$4)) $2 } + +-- Constructor declaration of the form "c (x1 x2 :: tp1) ... (z1 :: tpn) :: tp" +CtorDecl :: { CtorDecl } +CtorDecl : Ident VarCtx ':' LTerm ';' { Ctor $1 $2 $4 } + +Term :: { Term } +Term : LTerm { $1 } + | LTerm ':' LTerm { TypeConstraint $1 (pos $2) $3 } + +-- Term with uses of pi and lambda, but no type ascriptions +LTerm :: { Term } +LTerm : ProdTerm { $1 } + | PiArg '->' LTerm { Pi (pos $2) $1 $3 } + | '\\' VarCtx '->' LTerm { Lambda (pos $1) $2 $4 } + +PiArg :: { [(TermVar, Term)] } +PiArg : ProdTerm { mkPiArg $1 } + +-- Term formed from infix product type operator (right-associative) +ProdTerm :: { Term } +ProdTerm + : AppTerm { $1 } + | AppTerm '*' ProdTerm { PairType (pos $1) $1 $3 } + +-- Term formed from applications of atomic expressions +AppTerm :: { Term } +AppTerm : AtomTerm { $1 } + | AppTerm AtomTerm { App $1 $2 } + +AtomTerm :: { Term } +AtomTerm + : nat { NatLit (pos $1) (tokNat (val $1)) } + | string { StringLit (pos $1) (Text.pack (tokString (val $1))) } + | Ident { Name $1 } + | IdentRec { Recursor Nothing $1 } + | 'Prop' { Sort (pos $1) propSort } + | 'sort' nat { Sort (pos $1) (mkSort (tokNat (val $2))) } + | AtomTerm '.' Ident { RecordProj $1 (val $3) } + | AtomTerm '.' IdentRec {% parseRecursorProj $1 $3 } + | AtomTerm '.' nat {% parseTupleSelector $1 (fmap tokNat $3) } + | '(' sepBy(Term, ',') ')' { mkTupleValue (pos $1) $2 } + | '#' '(' sepBy(Term, ',') ')' { mkTupleType (pos $1) $3 } + | '[' sepBy(Term, ',') ']' { VecLit (pos $1) $2 } + | '{' sepBy(FieldValue, ',') '}' { RecordValue (pos $1) $2 } + | '#' '{' sepBy(FieldType, ',') '}' { RecordType (pos $1) $3 } + | AtomTerm '.' '(' nat ')' {% mkTupleProj $1 (tokNat (val $4)) } + +Ident :: { PosPair Text } +Ident : ident { fmap (Text.pack . tokIdent) $1 } + +IdentRec :: { PosPair Text } +IdentRec : identrec { fmap (Text.pack . tokRecursor) $1 } + +FieldValue :: { (PosPair FieldName, Term) } +FieldValue : Ident '=' Term { ($1, $3) } + +FieldType :: { (PosPair FieldName, Term) } +FieldType : Ident ':' LTerm { ($1, $3) } + +opt(q) :: { Maybe q } + : { Nothing } + | q { Just $1 } + +-- Two elements p and r separated by q and terminated by s +sepPair(p,q,r,s) :: { (p,r) } + : p q r s { ($1,$3) } + +-- A possibly-empty list of p's separated by q. +sepBy(p,q) :: { [p] } + : {- empty -} { [] } + | sepBy1(p,q) { $1 } + +-- A possibly-empty list of p's separated by q. +sepBy1(p,q) :: { [p] } + : rsepBy1(p,q) { reverse $1 } + +rsepBy1(p,q) :: { [p] } + : p { [$1] } + | rsepBy1(p,q) q p { $3 : $1 } + +-- A list of 0 or more p's, terminated by q's +list(p) :: { [p] } + : {- empty -} { [] } + | rlist1(p) { reverse $1 } + +-- A list of 0 or more p's, terminated by q's +list1(p) :: { [p] } + : rlist1(p) { reverse $1 } + +-- A reversed list of at least 1 p's +rlist1(p) :: { [p] } + : p { [$1] } + | rlist1(p) p { $2 : $1 } + +{ +data ParseError + = UnexpectedLex [Word8] + | UnexpectedToken Token + | ParseError String + deriving (Show) + +newtype Parser a = Parser { _unParser :: ExceptT (PosPair ParseError) (State AlexInput) a } + deriving (Applicative, Functor, Monad) + +addError :: Pos -> ParseError -> Parser a +addError p err = Parser $ throwError (PosPair p err) + +setInput :: AlexInput -> Parser () +setInput inp = Parser $ put inp + +parsePos :: Parser Pos +parsePos = Parser $ gets pos + +lexer :: (PosPair Token -> Parser a) -> Parser a +lexer f = do + let go prevErr next = do + let addErrors = + case prevErr of + Nothing -> return () + Just (po,l) -> addError po (UnexpectedLex (reverse l)) + s <- Parser get + let inp@(PosPair p (Buffer _ b)) = s + end = addErrors >> next (PosPair p TEnd) + case alexScan inp 0 of + AlexEOF -> end + AlexError _ -> + case alexGetByte inp of + Just (w,inp') -> do + setInput inp' + case prevErr of + Nothing -> go (Just (p,[w])) next + Just (po,l) -> go (Just (po,w:l)) next + Nothing -> end + AlexSkip inp' _ -> addErrors >> setInput inp' >> go Nothing next + AlexToken inp' l act -> do + addErrors + setInput inp' + let v = act (B.toString (B.take (fromIntegral l) b)) + next (PosPair p v) + let read i tkn = + case val tkn of + TCmntS -> go Nothing (read (i+1)) + TCmntE | i > 0 -> go Nothing (read (i-1)) + | otherwise -> do + addError (pos tkn) (UnexpectedLex (fmap (fromIntegral . fromEnum) "-}")) + go Nothing (read 0) + _ | i > 0 -> go Nothing (read i) + | otherwise -> f tkn + go Nothing (read (0::Integer)) + +-- | Run parser given a directory for the base (used for making pathname relative), +-- bytestring to parse, and parser to run. +runParser :: Parser a -> FilePath -> FilePath -> B.ByteString -> Either (PosPair ParseError) a +runParser (Parser m) base path b = evalState (runExceptT m) initState + where initState = initialAlexInput base path b + +parseSAW :: FilePath -> FilePath -> B.ByteString -> Either (PosPair ParseError) Module +parseSAW = runParser parseSAW2 + +parseSAWTerm :: FilePath -> FilePath -> B.ByteString -> Either (PosPair ParseError) Term +parseSAWTerm = runParser parseSAWTerm2 + +parseError :: PosPair Token -> Parser a +parseError pt = addError (pos pt) (UnexpectedToken (val pt)) + +addParseError :: Pos -> String -> Parser () +addParseError p s = addError p (ParseError s) + +-- Try to parse an expression as a list of identifiers +exprAsIdentList :: Term -> Maybe [TermVar] +exprAsIdentList (Name x) = return [TermVar x] +exprAsIdentList (App expr (Name x)) = + (++ [TermVar x]) <$> exprAsIdentList expr +exprAsIdentList _ = Nothing + +-- | Pi expressions should have one of the forms: +-- +-- * '(' list(Ident) ':' LTerm ')' '->' LTerm +-- * AppTerm '->' LTerm +-- +-- This function takes in a term for the LHS and tests if it is of the first +-- form, or, if not, converts the second form into the first by making a single +-- "unused" variable with the name "_" +mkPiArg :: Term -> [(TermVar, Term)] +mkPiArg (TypeConstraint (exprAsIdentList -> Just xs) _ t) = + map (\x -> (x, t)) xs +mkPiArg lhs = [(UnusedVar (pos lhs), lhs)] + +-- | Parse a tuple projection of the form @t.(1)@ or @t.(2)@ +mkTupleProj :: Term -> Natural -> Parser Term +mkTupleProj t 1 = return $ PairLeft t +mkTupleProj t 2 = return $ PairRight t +mkTupleProj t _ = + do addParseError (pos t) "Projections must be either .(1) or .(2)" + return (badTerm (pos t)) + +-- | Parse a term as a dotted list of strings +parseModuleName :: Term -> Maybe [String] +parseModuleName (RecordProj t str) = (++ [Text.unpack str]) <$> parseModuleName t +parseModuleName _ = Nothing + +-- | Parse a qualified recursor @M1.M2...Mn.d#rec@ +parseRecursorProj :: Term -> PosPair Text -> Parser Term +parseRecursorProj (parseModuleName -> Just mnm) i = + return $ Recursor (Just $ mkModuleName mnm) i +parseRecursorProj t _ = + do addParseError (pos t) "Malformed recursor projection" + return (badTerm (pos t)) + +parseTupleSelector :: Term -> PosPair Natural -> Parser Term +parseTupleSelector t i = + if val i >= 1 then return (mkTupleSelector t (val i)) else + do addParseError (pos t) "non-positive tuple projection index" + return (badTerm (pos t)) + +-- | Create a module name given a list of strings with the top-most +-- module name given first. +mkPosModuleName :: [PosPair Text] -> PosPair ModuleName +mkPosModuleName [] = error "internal: Unexpected empty module name" +mkPosModuleName l = PosPair p (mkModuleName (fmap Text.unpack nms)) + where nms = fmap val l + p = pos (last l) +} diff --git a/saw-core/src/Verifier/SAW/Lexer.x b/saw-core/src/Verifier/SAW/Lexer.x new file mode 100644 index 0000000000..8f20832b04 --- /dev/null +++ b/saw-core/src/Verifier/SAW/Lexer.x @@ -0,0 +1,147 @@ +{ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# OPTIONS_GHC -fno-warn-unused-binds #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +{-# OPTIONS_GHC -fno-warn-unused-matches #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} + +{- | +Module : Verifier.SAW.Lexer +Copyright : Galois, Inc. 2012-2014 +License : BSD3 +Maintainer : jhendrix@galois.com +Stability : experimental +Portability : non-portable (language extensions) +-} + +module Verifier.SAW.Lexer + ( module Verifier.SAW.Position + , Token(..) + , ppToken + , Buffer(..) + , AlexInput + , initialAlexInput + , alexScan + , alexGetByte + , AlexReturn(..) + ) where + +import Codec.Binary.UTF8.Generic () +import Control.Monad.State.Strict +import qualified Data.ByteString.Lazy as B +import Data.ByteString.Lazy.UTF8 (toString) +import Data.Word (Word8) +import Numeric.Natural + +import Verifier.SAW.Position + +} + +$whitechar = [ \t\n\r\f\v] +$special = [\(\)\,\;\[\]\`\{\}] +$digit = 0-9 +$binit = 0-1 +$octit = 0-7 +$hexit = [0-9 A-F a-f] +$large = [A-Z] +$small = [a-z] +$alpha = [$small $large] +$symbol = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~] # [$special \_\:\"\'] +$graphic = [$alpha $symbol $digit $special \:\"\'\_] +$charesc = [abfnrtv\\\"\'\&] +$cntrl = [$large \@\[\\\]\^\_] +@ascii = \^ $cntrl | NUL | SOH | STX | ETX | EOT | ENQ | ACK + | BEL | BS | HT | LF | VT | FF | CR | SO | SI | DLE + | DC1 | DC2 | DC3 | DC4 | NAK | SYN | ETB | CAN | EM + | SUB | ESC | FS | GS | RS | US | SP | DEL +@num = $digit+ +@decimal = $digit+ +@binary = $binit+ +@octal = $octit+ +@hex = $hexit+ +$idchar = [a-z A-Z 0-9 \' \_] +@ident = [a-z A-Z \_] $idchar* + +@punct = "#" | "," | "->" | "." | ";" | ":" | "=" | "*" + | "\" | "(" | ")" | "[" | "]" | "{" | "}" | "|" +@keywords = "data" | "hiding" | "import" | "module" + | "sort" | "Prop" | "where" | "primitive" | "axiom" +@key = @punct | @keywords + +@escape = \\ ($charesc | @ascii | @decimal | o @octal | x @hex) +@gap = \\ $whitechar+ \\ +@string = $graphic # [\"\\] | " " | @escape | @gap + +sawTokens :- + +$white+; +"--".*; +"{-" { \_ -> TCmntS } +"-}" { \_ -> TCmntE } +\" @string* \" { TString . read } +@num { TNat . read } +@key { TKey } +@ident { TIdent } +@ident "#rec" { TRecursor . dropRecSuffix } +. { TIllegal } + +{ +data Token + = TIdent { tokIdent :: String } -- ^ Identifier + | TRecursor { tokRecursor :: String } -- ^ Recursor + | TNat { tokNat :: Natural } -- ^ Natural number literal + | TString { tokString :: String } -- ^ String literal + | TKey String -- ^ Keyword or predefined symbol + | TEnd -- ^ End of file. + | TCmntS -- ^ Start of a block comment + | TCmntE -- ^ End of a block comment. + | TIllegal String -- ^ Illegal character + deriving (Show) + +-- | Remove the "#rec" suffix of a recursor string +dropRecSuffix :: String -> String +dropRecSuffix str = take (length str - 4) str + +ppToken :: Token -> String +ppToken tkn = + case tkn of + TIdent s -> s + TRecursor s -> s ++ "#rec" + TNat n -> show n + TString s -> show s + TKey s -> s + TEnd -> "END" + TCmntS -> "XXXS" + TCmntE -> "XXXE" + TIllegal s -> "illegal " ++ show s + +data Buffer = Buffer Char !B.ByteString + +type AlexInput = PosPair Buffer + +initialAlexInput :: FilePath -> FilePath -> B.ByteString -> AlexInput +initialAlexInput base path b = PosPair pos input + where pos = Pos { posBase = base + , posPath = path + , posLine = 1 + , posCol = 0 + } + prevChar = error "internal: runLexer prev char undefined" + input = Buffer prevChar b + +alexInputPrevChar :: AlexInput -> Char +alexInputPrevChar (val -> Buffer c _) = c + +alexGetByte :: AlexInput -> Maybe (Word8, AlexInput) +alexGetByte (PosPair p (Buffer _ b)) = fmap fn (B.uncons b) + where fn (w,b') = (w, PosPair p' (Buffer c b')) + where c = toEnum (fromIntegral w) + isNew = c == '\n' + p' = if isNew then incLine p else incCol p +} diff --git a/saw-core/src/Verifier/SAW/Module.hs b/saw-core/src/Verifier/SAW/Module.hs new file mode 100644 index 0000000000..f8d476507e --- /dev/null +++ b/saw-core/src/Verifier/SAW/Module.hs @@ -0,0 +1,479 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE LambdaCase #-} + +{- | +Module : Verifier.SAW.Module +Copyright : Galois, Inc. 2012-2017 +License : BSD3 +Maintainer : huffman@galois.com +Stability : experimental +Portability : non-portable (language extensions) +-} + +module Verifier.SAW.Module + ( -- * Data types and definitions. + DefQualifier(..) + , Def(..) + , CtorArg(..) + , CtorArgStruct(..) + , Ctor(..) + , ctorNumParams + , ctorNumArgs + , DataType(..) + , dtNumParams + , dtNumIndices + -- * Modules + , Module + , ModuleDecl(..) + , ResolvedName(..) + , resolvedNameIdent + , moduleName + , moduleImports + , moduleImportNames + , emptyModule + , resolveName + , findDataType + , insImport + , insDataType + , beginDataType + , completeDataType + , moduleDataTypes + , moduleCtors + , findCtor + , moduleDefs + , findDef + , insDef + , moduleDecls + , modulePrimitives + , moduleAxioms + , moduleActualDefs + -- * Module Maps + , ModuleMap + , findCtorInMap + , findDataTypeInMap + , allModuleDefs + , allModuleDecls + , allModulePrimitives + , allModuleAxioms + , allModuleActualDefs + , allModuleDataTypes + , allModuleCtors + -- * Pretty-printing + , ppModule + ) where + +#if !MIN_VERSION_base(4,8,0) +import Data.Foldable (Foldable) +#endif +import Data.Foldable (foldl', foldr') +import Data.Hashable +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HMap +import Data.Text (Text) +import GHC.Generics (Generic) + +import qualified Language.Haskell.TH.Syntax as TH + +import Prelude hiding (all, foldr, sum) + +import Verifier.SAW.Term.Functor +import Verifier.SAW.Term.Pretty +import Verifier.SAW.Term.CtxTerm +import Verifier.SAW.Utils (internalError) + +-- Definitions ----------------------------------------------------------------- + +data DefQualifier + = NoQualifier + | PrimQualifier + | AxiomQualifier + deriving (Eq, Show, Generic, TH.Lift) + +instance Hashable DefQualifier -- automatically derived + +-- | A Definition contains an identifier, the type of the definition, and an +-- optional body (axioms and primitives do not have a body) +data Def = + Def + { defIdent :: Ident + , defQualifier :: DefQualifier + , defType :: Term + , defBody :: Maybe Term + } + deriving (Eq, Show, Generic) + +instance Hashable Def -- automatically derived + + +-- Constructors ---------------------------------------------------------------- + +-- | A specification of a constructor +data Ctor = + forall d params ixs. + Ctor + { ctorName :: !Ident + -- ^ The name of this constructor + , ctorArgStruct :: CtorArgStruct d params ixs + -- ^ Arguments to the constructor + , ctorDataTypeName :: Ident + -- ^ The datatype this constructor belongs to + , ctorType :: Term + -- ^ Cached type of the constructor, which should always be equal to + -- + -- > (p1::P1) -> .. -> (pn::Pn) -> (x1::arg1) -> .. -> (xm::argm) -> + -- > d p1 .. pn ix1 .. ixk + -- + -- where the @pi@ are the 'ctorParams', the @argi@ are the types specified + -- by the 'ctorArgs', and the @ixi@ are the 'ctorDataTypeIndices'. Note that + -- this type should always be top-level, i.e., have no free variables. + , ctorElimTypeFun :: [Term] -> Term -> IO Term + -- ^ Cached function for generating the type of an eliminator for this + -- constructor by passing it a list of parameters and a @p_ret@ function, + -- also known as the "motive function", which itself must have type + -- + -- > (x1::ix1) -> .. -> (xm::ixm) -> d p1 .. pn x1 .. xm -> Type i + -- + -- where the @ps@ are the parameters and the @ix@s are the indices of + -- datatype @d@ + , ctorIotaReduction :: Term + -- ^ Cached result of one step of iota reduction of the term + -- + -- > RecursorApp d params p_ret elims ixs (c params args) + -- + -- where @params@, @p_ret@, @elims@, and @args@ are distinct free variables, + -- in that order, so that the last @arg@ is the most recently-bound + -- variable, i.e., has deBruijn index 0. This means that an iota reduction + -- of the above recursor application can be performed by substituting the + -- concrete parameters, eliminators, and constructor arguments into the + -- 'Term' stored in 'ctorIotaReduction'. Note that we are assuming that the + -- @elims@ are in the same order as they are listed in the corresponding + -- 'DataType' for this constructor. + } + +-- | Return the number of parameters of a constructor +ctorNumParams :: Ctor -> Int +ctorNumParams (Ctor { ctorArgStruct = CtorArgStruct {..}}) = + bindingsLength ctorParams + +-- | Return the number of non-parameter arguments of a constructor +ctorNumArgs :: Ctor -> Int +ctorNumArgs (Ctor { ctorArgStruct = CtorArgStruct {..}}) = + bindingsLength ctorArgs + + +lift2 :: (a -> b) -> (b -> b -> c) -> a -> a -> c +lift2 f h x y = h (f x) (f y) + +instance Eq Ctor where + (==) = lift2 ctorName (==) + +instance Ord Ctor where + compare = lift2 ctorName compare + +instance Show Ctor where + show = show . ctorName + + +-- Datatypes ------------------------------------------------------------------- + +-- | An inductively-defined datatype +data DataType = + DataType + { dtName :: Ident + -- ^ The name of this datatype + , dtParams :: [(LocalName, Term)] + -- ^ The context of parameters of this datatype + , dtIndices :: [(LocalName, Term)] + -- ^ The context of indices of this datatype + , dtSort :: Sort + -- ^ The universe of this datatype + , dtCtors :: [Ctor] + -- ^ The list of constructors of this datatype + , dtType :: Term + -- ^ The cached type of this datatype, which should always be equal to + -- + -- > (p1::P1) -> .. -> (pn::Pn) -> (i1::I1) -> .. -> (im::Im) -> 'dtSort' + -- + -- where the @pi@ are the 'dtParams' and the @ii@ are the 'dtIndices'. Note + -- that this type should always be top-level, i.e., have no free variables. + } + +-- | Return the number of parameters of a datatype +dtNumParams :: DataType -> Int +dtNumParams dt = length $ dtParams dt + +-- | Return the number of indices of a datatype +dtNumIndices :: DataType -> Int +dtNumIndices dt = length $ dtIndices dt + +instance Eq DataType where + (==) = lift2 dtName (==) + +instance Ord DataType where + compare = lift2 dtName compare + +instance Show DataType where + show = show . dtName + + +-- Modules --------------------------------------------------------------------- + +-- | Declarations that can occur in a module +data ModuleDecl = TypeDecl DataType + | DefDecl Def + +-- | The different sorts of things that a 'Text' name can be resolved to +data ResolvedName + = ResolvedCtor Ctor + | ResolvedDataType DataType + | ResolvedDef Def + +-- | Get the 'Ident' for a 'ResolvedName' +resolvedNameIdent :: ResolvedName -> Ident +resolvedNameIdent (ResolvedCtor ctor) = ctorName ctor +resolvedNameIdent (ResolvedDataType dt) = dtName dt +resolvedNameIdent (ResolvedDef d) = defIdent d + +-- | Modules define namespaces of datatypes, constructors, and definitions, +-- i.e., mappings from 'Text' names to these objects. A module is allowed to +-- map a 'Text' name to an object defined in a different module. Modules also +-- keep a record of the top-level declarations and the imports that were used to +-- build them. +data Module = Module { + moduleName :: !ModuleName + , moduleImports :: !(Map ModuleName Module) + , moduleResolveMap :: !(Map Text ResolvedName) + , moduleRDecls :: [ModuleDecl] -- ^ All declarations in reverse order they were added. + } + +-- | Get the names of all modules imported by the given one +moduleImportNames :: Module -> [ModuleName] +moduleImportNames m = Map.keys (moduleImports m) + +emptyModule :: ModuleName -> Module +emptyModule nm = + Module { moduleName = nm + , moduleImports = Map.empty + , moduleResolveMap = Map.empty + , moduleRDecls = [] + } + + +-- | Resolve a 'Text' name in the namespace defined by a 'Module', to either a +-- 'Ctor', 'DataType', or 'Def' +resolveName :: Module -> Text -> Maybe ResolvedName +resolveName m str = Map.lookup str (moduleResolveMap m) + +-- | Resolve a 'Text' name to a 'Ctor' +findCtor :: Module -> Text -> Maybe Ctor +findCtor m str = + resolveName m str >>= \case { ResolvedCtor ctor -> Just ctor; _ -> Nothing } + +-- | Resolve a 'Text' name to a 'DataType' +findDataType :: Module -> Text -> Maybe DataType +findDataType m str = + resolveName m str >>= \case { ResolvedDataType d -> Just d; _ -> Nothing } + +-- | Resolve a 'Text' name to a 'Def' +findDef :: Module -> Text -> Maybe Def +findDef m str = + resolveName m str >>= \case { ResolvedDef d -> Just d; _ -> Nothing } + + +-- | Insert a 'ResolvedName' into a 'Module', adding a mapping from the 'Text' +-- name of that resolved name to it. Signal an error in the case of a name +-- clash, i.e., an existing binding for the same 'Text' name. +insResolvedName :: Module -> ResolvedName -> Module +insResolvedName m nm = + let str = identBaseName $ resolvedNameIdent nm in + if Map.member str (moduleResolveMap m) then + internalError ("Duplicate name " ++ show str ++ " being inserted into module " + ++ show (moduleName m)) + else + m { moduleResolveMap = Map.insert str nm (moduleResolveMap m) } + +-- | @insImport i m@ returns the module obtained by importing @i@ into @m@, +-- using a predicate to specify which names are imported from @i@ into @m@. In +-- the case of name clashes, an error is signaled. +insImport :: (ResolvedName -> Bool) -> Module -> Module -> Module +insImport name_p i m = + (foldl' insResolvedName m $ Map.elems $ + Map.filter name_p (moduleResolveMap i)) + { moduleImports = Map.insert (moduleName i) i (moduleImports m) } + +-- | Insert a 'DataType' declaration, along with its 'Ctor's, into a module +insDataType :: Module -> DataType -> Module +insDataType m dt = + foldl' insResolvedName (m { moduleRDecls = TypeDecl dt : moduleRDecls m}) $ + (ResolvedDataType dt : map ResolvedCtor (dtCtors dt)) + +-- | Insert an "incomplete" datatype, used as part of building up a 'DataType' +-- to typecheck its constructors. This incomplete datatype must have no +-- constructors, and it will not be added to the 'moduleRDecls' list until it is +-- completed by 'completeDataType'. +beginDataType :: Module -> DataType -> Module +beginDataType m dt = + if null (dtCtors dt) then insResolvedName m (ResolvedDataType dt) else + internalError + "insTempDataType: attempt to insert a non-empty temporary datatype" + +-- | Complete a datatype, by adding its constructors +completeDataType :: Module -> Ident -> [Ctor] -> Module +completeDataType m (identBaseName -> str) ctors = + case resolveName m str of + Just (ResolvedDataType dt) + | null (dtCtors dt) -> + let dt' = dt {dtCtors = ctors} in + flip (foldl' insResolvedName) (map ResolvedCtor ctors) $ + m { moduleResolveMap = + Map.insert str (ResolvedDataType dt') (moduleResolveMap m), + moduleRDecls = TypeDecl dt' : moduleRDecls m } + Just (ResolvedDataType _) -> + internalError $ "completeDataType: datatype already completed: " ++ show str + Just _ -> + internalError $ "completeDataType: not a datatype: " ++ show str + Nothing -> + internalError $ "completeDataType: datatype not found: " ++ show str + + +-- | Insert a definition into a module +insDef :: Module -> Def -> Module +insDef m d = + insResolvedName + (m { moduleRDecls = DefDecl d : moduleRDecls m }) + (ResolvedDef d) + +-- | Get the resolved names that are local to a module +localResolvedNames :: Module -> [ResolvedName] +localResolvedNames m = + filter ((== moduleName m) . identModule . resolvedNameIdent) + (Map.elems $ moduleResolveMap m) + +-- | Get all data types defined in a module +moduleDataTypes :: Module -> [DataType] +moduleDataTypes = + foldr' (\case { ResolvedDataType dt -> (dt :); _ -> id } ) [] . + localResolvedNames + +-- | Get all constructors defined in a module +moduleCtors :: Module -> [Ctor] +moduleCtors = + foldr' (\case { ResolvedCtor ctor -> (ctor :); _ -> id } ) [] . + localResolvedNames + +-- | Get all definitions defined in a module +moduleDefs :: Module -> [Def] +moduleDefs = + foldr' (\case { ResolvedDef d -> (d :); _ -> id } ) [] . + localResolvedNames + +-- | Get all declarations that are local to a module, i.e., that defined names +-- that were not imported from some other module +moduleDecls :: Module -> [ModuleDecl] +moduleDecls = reverse . moduleRDecls + +-- | Get all local declarations in a module that are marked as primitives +modulePrimitives :: Module -> [Def] +modulePrimitives m = + [ def + | DefDecl def <- moduleDecls m + , defQualifier def == PrimQualifier + ] + +-- | Get all local declarations in a module that are marked as axioms +moduleAxioms :: Module -> [Def] +moduleAxioms m = + [ def + | DefDecl def <- moduleDecls m + , defQualifier def == AxiomQualifier + ] + +-- | Get all local declarations in a module that are not marked as primitives or +-- axioms +moduleActualDefs :: Module -> [Def] +moduleActualDefs m = + [ def + | DefDecl def <- moduleDecls m + , defQualifier def == NoQualifier + ] + +-- | The type of mappings from module names to modules +type ModuleMap = HashMap ModuleName Module + +-- | Resolve an 'Ident' to a 'Ctor' in a 'ModuleMap' +findCtorInMap :: ModuleMap -> Ident -> Maybe Ctor +findCtorInMap m i = + HMap.lookup (identModule i) m >>= flip findCtor (identBaseName i) + +-- | Resolve an 'Ident' to a 'DataType' in a 'ModuleMap' +findDataTypeInMap :: ModuleMap -> Ident -> Maybe DataType +findDataTypeInMap m i = + HMap.lookup (identModule i) m >>= flip findDataType (identBaseName i) + +-- | Get all definitions defined in any module in an entire module map. Note +-- that the returned list might have redundancies if a definition is visible / +-- imported in multiple modules in the module map. +allModuleDefs :: ModuleMap -> [Def] +allModuleDefs modmap = concatMap moduleDefs (HMap.elems modmap) + +-- | Get all local declarations from all modules in an entire module map +allModuleDecls :: ModuleMap -> [ModuleDecl] +allModuleDecls modmap = concatMap moduleDecls (HMap.elems modmap) + +-- | Get all local declarations from all modules in an entire module map that +-- are marked as primitives +allModulePrimitives :: ModuleMap -> [Def] +allModulePrimitives modmap = + [ def + | DefDecl def <- allModuleDecls modmap + , defQualifier def == PrimQualifier + ] + +-- | Get all local declarations from all modules in an entire module map that +-- are marked as axioms +allModuleAxioms :: ModuleMap -> [Def] +allModuleAxioms modmap = + [ def + | DefDecl def <- allModuleDecls modmap + , defQualifier def == AxiomQualifier + ] + +-- | Get all local declarations from all modules in an entire module map that +-- are marked as neither primitives nor axioms +allModuleActualDefs :: ModuleMap -> [Def] +allModuleActualDefs modmap = + [ def + | DefDecl def <- allModuleDecls modmap + , defQualifier def == NoQualifier + ] + +-- | Get all datatypes in all modules in a module map +allModuleDataTypes :: ModuleMap -> [DataType] +allModuleDataTypes modmap = concatMap moduleDataTypes (HMap.elems modmap) + +-- | Get all constructors in all modules in a module map +allModuleCtors :: ModuleMap -> [Ctor] +allModuleCtors modmap = concatMap moduleCtors (HMap.elems modmap) + + +-- | Pretty-print a 'Module' +ppModule :: PPOpts -> Module -> SawDoc +ppModule opts m = + ppPPModule opts (PPModule (moduleImportNames m) (map toDecl $ moduleDecls m)) + where + toDecl (TypeDecl (DataType {..})) = + PPTypeDecl dtName dtParams dtIndices dtSort + (map (\c -> (ctorName c, ctorType c)) dtCtors) + toDecl (DefDecl (Def {..})) = + PPDefDecl defIdent defType defBody diff --git a/saw-core/src/Verifier/SAW/Name.hs b/saw-core/src/Verifier/SAW/Name.hs new file mode 100644 index 0000000000..c2961e6e91 --- /dev/null +++ b/saw-core/src/Verifier/SAW/Name.hs @@ -0,0 +1,319 @@ +{- | +Module : Verifier.SAW.Name +Copyright : Galois, Inc. 2012-2015 +License : BSD3 +Maintainer : huffman@galois.com +Stability : experimental +Portability : non-portable (language extensions) + +Various kinds of names. +-} + +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module Verifier.SAW.Name + ( -- * Module names + ModuleName, mkModuleName + , preludeName + , moduleNameText + , moduleNamePieces + -- * Identifiers + , Ident(identModule, identBaseName), identName, mkIdent + , mkIdentText + , parseIdent + , isIdent + , identText + , identPieces + -- * NameInfo + , NameInfo(..) + , toShortName + , toAbsoluteName + , moduleIdentToURI + , nameURI + , nameAliases + -- * ExtCns + , VarIndex + , ExtCns(..) + , scFreshNameURI + -- * Naming Environments + , SAWNamingEnv(..) + , emptySAWNamingEnv + , registerName + , resolveURI + , resolveName + , bestAlias + ) where + +import Control.Exception (assert) +import Data.Char +import Data.Hashable +import qualified Data.List as L +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe +import Data.Set (Set) +import qualified Data.Set as Set +import Data.String (IsString(..)) +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Word +import GHC.Generics (Generic) +import Text.URI +import qualified Language.Haskell.TH.Syntax as TH +import Instances.TH.Lift () -- for instance TH.Lift Text + +import Verifier.SAW.Utils (panic, internalError) + + +-- Module Names ---------------------------------------------------------------- + +newtype ModuleName = ModuleName Text + deriving (Eq, Ord, Generic, TH.Lift) + +instance Hashable ModuleName -- automatically derived + +instance Show ModuleName where + show (ModuleName s) = Text.unpack s + + +moduleNameText :: ModuleName -> Text +moduleNameText (ModuleName x) = x + +moduleNamePieces :: ModuleName -> [Text] +moduleNamePieces (ModuleName x) = Text.splitOn (Text.pack ".") x + +-- | Create a module name given a list of strings with the top-most +-- module name given first. +mkModuleName :: [String] -> ModuleName +mkModuleName [] = error "internal: mkModuleName given empty module name" +mkModuleName nms = assert (all isCtor nms) $ ModuleName (Text.pack s) + where s = L.intercalate "." (reverse nms) + +preludeName :: ModuleName +preludeName = mkModuleName ["Prelude"] + + +-- Identifiers ----------------------------------------------------------------- + +data Ident = + Ident + { identModule :: ModuleName + , identBaseName :: Text + } + deriving (Eq, Ord, Generic) + +instance Hashable Ident -- automatically derived + +instance Show Ident where + show (Ident m s) = shows m ('.' : Text.unpack s) + +identText :: Ident -> Text +identText i = moduleNameText (identModule i) <> Text.pack "." <> identBaseName i + +identPieces :: Ident -> NonEmpty Text +identPieces i = + case moduleNamePieces (identModule i) of + [] -> identBaseName i :| [] + (x:xs) -> x :| (xs ++ [identBaseName i]) + +identName :: Ident -> String +identName = Text.unpack . identBaseName + +instance Read Ident where + readsPrec _ str = + let (str1, str2) = break (not . isIdChar) str in + [(parseIdent str1, str2)] + +mkIdent :: ModuleName -> String -> Ident +mkIdent m s = Ident m (Text.pack s) + +mkIdentText :: ModuleName -> Text -> Ident +mkIdentText m s = Ident m s + +-- | Parse a fully qualified identifier. +parseIdent :: String -> Ident +parseIdent s0 = + case reverse (breakEach s0) of + (_:[]) -> internalError $ "parseIdent given empty module name." + (nm:rMod) -> mkIdent (mkModuleName (reverse rMod)) nm + _ -> internalError $ "parseIdent given bad identifier " ++ show s0 + where breakEach s = + case break (=='.') s of + (h,[]) -> [h] + (h,'.':r) -> h : breakEach r + _ -> internalError "parseIdent.breakEach failed" + +instance IsString Ident where + fromString = parseIdent + +isIdent :: String -> Bool +isIdent (c:l) = isAlpha c && all isIdChar l +isIdent [] = False + +isCtor :: String -> Bool +isCtor (c:l) = isUpper c && all isIdChar l +isCtor [] = False + +-- | Returns true if character can appear in identifier. +isIdChar :: Char -> Bool +isIdChar c = isAlphaNum c || (c == '_') || (c == '\'') || (c == '.') + + +-------------------------------------------------------------------------------- +-- NameInfo + + +-- | Descriptions of the origins of names that may be in scope +data NameInfo + = -- | This name arises from an exported declaration from a module + ModuleIdentifier Ident + + | -- | This name was imported from some other programming language/scope + ImportedName + URI -- ^ An absolutely-qualified name, which is required to be unique + [Text] -- ^ A collection of aliases for this name. Sorter or "less-qualified" + -- aliases should be nearer the front of the list + + deriving (Eq,Ord,Show) + +nameURI :: NameInfo -> URI +nameURI = + \case + ModuleIdentifier i -> moduleIdentToURI i + ImportedName uri _ -> uri + +nameAliases :: NameInfo -> [Text] +nameAliases = + \case + ModuleIdentifier i -> [identBaseName i, identText i] + ImportedName _ aliases -> aliases + +toShortName :: NameInfo -> Text +toShortName (ModuleIdentifier i) = identBaseName i +toShortName (ImportedName uri []) = render uri +toShortName (ImportedName _ (x:_)) = x + +toAbsoluteName :: NameInfo -> Text +toAbsoluteName (ModuleIdentifier i) = identText i +toAbsoluteName (ImportedName uri _) = render uri + +moduleIdentToURI :: Ident -> URI +moduleIdentToURI ident = fromMaybe (panic "moduleIdentToURI" ["Failed to constructed ident URI", show ident]) $ + do sch <- mkScheme "sawcore" + path <- mapM mkPathPiece (identPieces ident) + pure URI + { uriScheme = Just sch + , uriAuthority = Left True -- absolute path + , uriPath = Just (False, path) + , uriQuery = [] + , uriFragment = Nothing + } + + +-- External Constants ---------------------------------------------------------- + +type VarIndex = Word64 + +-- | An external constant with a name. +-- Names are not necessarily unique, but the var index should be. +data ExtCns e = + EC + { ecVarIndex :: !VarIndex + , ecName :: !NameInfo + , ecType :: !e + } + deriving (Show, Functor, Foldable, Traversable) + +instance Eq (ExtCns e) where + x == y = ecVarIndex x == ecVarIndex y + +instance Ord (ExtCns e) where + compare x y = compare (ecVarIndex x) (ecVarIndex y) + +instance Hashable (ExtCns e) where + hashWithSalt x ec = hashWithSalt x (ecVarIndex ec) + +scFreshNameURI :: Text -> VarIndex -> URI +scFreshNameURI nm i = fromMaybe (panic "scFreshNameURI" ["Failed to constructed name URI", show nm, show i]) $ + do sch <- mkScheme "fresh" + nm' <- mkPathPiece (if Text.null nm then "_" else nm) + i' <- mkFragment (Text.pack (show i)) + pure URI + { uriScheme = Just sch + , uriAuthority = Left False -- relative path + , uriPath = Just (False, (nm' :| [])) + , uriQuery = [] + , uriFragment = Just i' + } + + +-- Naming Environments --------------------------------------------------------- + +data SAWNamingEnv = SAWNamingEnv + { resolvedNames :: !(Map VarIndex NameInfo) + , absoluteNames :: !(Map URI VarIndex) + , aliasNames :: !(Map Text (Set VarIndex)) + } +-- Invariants: The 'resolvedNames' and 'absoluteNames' maps should be +-- inverses of each other. That is, 'resolvedNames' maps @i@ to @n@ if +-- and only if 'absoluteNames' maps @nameURI n@ to @i@. Also, every +-- 'VarIndex' appearing in 'aliasNames' must be present as a key in +-- 'resolvedNames'. + +emptySAWNamingEnv :: SAWNamingEnv +emptySAWNamingEnv = SAWNamingEnv mempty mempty mempty + +-- | Add a new name entry in a 'SAWNamingEnv'. Returns 'Left' if +-- there is already an entry under the same URI. +registerName :: VarIndex -> NameInfo -> SAWNamingEnv -> Either URI SAWNamingEnv +registerName i nmi env = + case Map.lookup uri (absoluteNames env) of + Just _ -> Left uri + Nothing -> + Right $ + SAWNamingEnv + { resolvedNames = Map.insert i nmi (resolvedNames env) + , absoluteNames = Map.insert uri i (absoluteNames env) + , aliasNames = foldr insertAlias (aliasNames env) aliases + } + where + uri = nameURI nmi + aliases = render uri : nameAliases nmi + + insertAlias :: Text -> Map Text (Set VarIndex) -> Map Text (Set VarIndex) + insertAlias x m = Map.insertWith Set.union x (Set.singleton i) m + +resolveURI :: SAWNamingEnv -> URI -> Maybe VarIndex +resolveURI env uri = Map.lookup uri (absoluteNames env) + +resolveName :: SAWNamingEnv -> Text -> [(VarIndex, NameInfo)] +resolveName env nm = + case Map.lookup nm (aliasNames env) of + Nothing -> [] + Just vs -> [ (v, findName v (resolvedNames env)) | v <- Set.toList vs ] + where + findName v m = + case Map.lookup v m of + Just nmi -> nmi + Nothing -> panic "resolveName" ["Unbound VarIndex when resolving name", show nm, show v] + +-- | Return the first alias (according to 'nameAliases') that is +-- unambiguous in the naming environment. If there is no unambiguous +-- alias, then return the URI. +bestAlias :: SAWNamingEnv -> NameInfo -> Either URI Text +bestAlias env nmi = go (nameAliases nmi) + where + go [] = Left (nameURI nmi) + go (x : xs) = + case Map.lookup x (aliasNames env) of + Nothing -> go xs + Just vs + | Set.size vs == 1 -> Right x + | otherwise -> go xs diff --git a/saw-core/src/Verifier/SAW/OpenTerm.hs b/saw-core/src/Verifier/SAW/OpenTerm.hs new file mode 100644 index 0000000000..d2883f850d --- /dev/null +++ b/saw-core/src/Verifier/SAW/OpenTerm.hs @@ -0,0 +1,290 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Verifier.SAW.OpenTerm +Copyright : Galois, Inc. 2018 +License : BSD3 +Stability : experimental +Portability : non-portable (language extensions) + +This module defines an interface to building SAW core terms in an incrementally +type-checked way, meaning that type-checking is performed as the terms are +built. +-} + +module Verifier.SAW.OpenTerm ( + -- * Open terms and converting to closed terms + OpenTerm(..), completeOpenTerm, completeOpenTermType, + -- * Basic operations for building open terms + closedOpenTerm, flatOpenTerm, sortOpenTerm, natOpenTerm, + unitOpenTerm, unitTypeOpenTerm, + stringLitOpenTerm, stringTypeOpenTerm, + pairOpenTerm, pairTypeOpenTerm, pairLeftOpenTerm, pairRightOpenTerm, + tupleOpenTerm, tupleTypeOpenTerm, projTupleOpenTerm, + ctorOpenTerm, dataTypeOpenTerm, globalOpenTerm, + applyOpenTerm, applyOpenTermMulti, + lambdaOpenTerm, lambdaOpenTermMulti, piOpenTerm, piOpenTermMulti, + arrowOpenTerm, + letOpenTerm, + -- * Monadic operations for building terms with binders + OpenTermM(..), completeOpenTermM, + dedupOpenTermM, lambdaOpenTermM, piOpenTermM, + lambdaOpenTermAuxM, piOpenTermAuxM + ) where + +import Control.Monad +import Control.Monad.IO.Class +import Data.Text (Text) +import Numeric.Natural + +import Verifier.SAW.Term.Functor +import Verifier.SAW.SharedTerm +import Verifier.SAW.SCTypeCheck +import Verifier.SAW.Module + +-- | An open term is represented as a type-checking computation that computes a +-- SAW core term and its type +newtype OpenTerm = OpenTerm { unOpenTerm :: TCM TypedTerm } + +-- | "Complete" an 'OpenTerm' to a closed term or 'fail' on type-checking error +completeOpenTerm :: SharedContext -> OpenTerm -> IO Term +completeOpenTerm sc (OpenTerm termM) = + either (fail . show) return =<< + runTCM (typedVal <$> termM) sc Nothing [] + +-- | "Complete" an 'OpenTerm' to a closed term for its type +completeOpenTermType :: SharedContext -> OpenTerm -> IO Term +completeOpenTermType sc (OpenTerm termM) = + either (fail . show) return =<< + runTCM (typedType <$> termM) sc Nothing [] + +-- | Embed a closed 'Term' into an 'OpenTerm' +closedOpenTerm :: Term -> OpenTerm +closedOpenTerm t = OpenTerm $ typeInferComplete t + +-- | Build an 'OpenTerm' from a 'FlatTermF' +flatOpenTerm :: FlatTermF OpenTerm -> OpenTerm +flatOpenTerm ftf = OpenTerm $ + (sequence (fmap unOpenTerm ftf) >>= typeInferComplete) + +-- | Build an 'OpenTerm' for a sort +sortOpenTerm :: Sort -> OpenTerm +sortOpenTerm s = flatOpenTerm (Sort s) + +-- | Build an 'OpenTerm' for a natural number literal +natOpenTerm :: Natural -> OpenTerm +natOpenTerm = flatOpenTerm . NatLit + +-- | The 'OpenTerm' for the unit value +unitOpenTerm :: OpenTerm +unitOpenTerm = flatOpenTerm UnitValue + +-- | The 'OpenTerm' for the unit type +unitTypeOpenTerm :: OpenTerm +unitTypeOpenTerm = flatOpenTerm UnitType + +-- | Build a SAW core string literal. +stringLitOpenTerm :: Text -> OpenTerm +stringLitOpenTerm = flatOpenTerm . StringLit + +-- | Return the SAW core type @String@ of strings. +stringTypeOpenTerm :: OpenTerm +stringTypeOpenTerm = globalOpenTerm "Prelude.String" + +-- | Build an 'OpenTerm' for a pair +pairOpenTerm :: OpenTerm -> OpenTerm -> OpenTerm +pairOpenTerm t1 t2 = flatOpenTerm $ PairValue t1 t2 + +-- | Build an 'OpenTerm' for a pair type +pairTypeOpenTerm :: OpenTerm -> OpenTerm -> OpenTerm +pairTypeOpenTerm t1 t2 = flatOpenTerm $ PairType t1 t2 + +-- | Build an 'OpenTerm' for the left projection of a pair +pairLeftOpenTerm :: OpenTerm -> OpenTerm +pairLeftOpenTerm t = flatOpenTerm $ PairLeft t + +-- | Build an 'OpenTerm' for the right projection of a pair +pairRightOpenTerm :: OpenTerm -> OpenTerm +pairRightOpenTerm t = flatOpenTerm $ PairRight t + +-- | Build a right-nested tuple as an 'OpenTerm' +tupleOpenTerm :: [OpenTerm] -> OpenTerm +tupleOpenTerm = foldr pairOpenTerm unitOpenTerm + +-- | Build a right-nested tuple type as an 'OpenTerm' +tupleTypeOpenTerm :: [OpenTerm] -> OpenTerm +tupleTypeOpenTerm = foldr pairTypeOpenTerm unitTypeOpenTerm + +-- | Project the @n@th element of a right-nested tuple type +projTupleOpenTerm :: Integer -> OpenTerm -> OpenTerm +projTupleOpenTerm 0 t = pairLeftOpenTerm t +projTupleOpenTerm i t = projTupleOpenTerm (i-1) (pairRightOpenTerm t) + +-- | Build an 'OpenTerm' for a constructor applied to its arguments +ctorOpenTerm :: Ident -> [OpenTerm] -> OpenTerm +ctorOpenTerm c all_args = OpenTerm $ do + maybe_ctor <- liftTCM scFindCtor c + (params, args) <- + case maybe_ctor of + Just ctor -> splitAt (ctorNumParams ctor) <$> mapM unOpenTerm all_args + Nothing -> throwTCError $ NoSuchCtor c + typeInferComplete $ CtorApp c params args + +-- | Build an 'OpenTerm' for a datatype applied to its arguments +dataTypeOpenTerm :: Ident -> [OpenTerm] -> OpenTerm +dataTypeOpenTerm d all_args = OpenTerm $ do + maybe_dt <- liftTCM scFindDataType d + (params, args) <- + case maybe_dt of + Just dt -> splitAt (dtNumParams dt) <$> mapM unOpenTerm all_args + Nothing -> throwTCError $ NoSuchDataType d + typeInferComplete $ DataTypeApp d params args + +-- | Build an 'OpenTerm' for a global name. +globalOpenTerm :: Ident -> OpenTerm +globalOpenTerm ident = + OpenTerm (liftTCM scGlobalDef ident >>= typeInferComplete) + +-- | Apply an 'OpenTerm' to another +applyOpenTerm :: OpenTerm -> OpenTerm -> OpenTerm +applyOpenTerm (OpenTerm f) (OpenTerm arg) = + OpenTerm ((App <$> f <*> arg) >>= typeInferComplete) + +-- | Apply an 'OpenTerm' to 0 or more arguments +applyOpenTermMulti :: OpenTerm -> [OpenTerm] -> OpenTerm +applyOpenTermMulti = foldl applyOpenTerm + +-- | Build an 'OpenTerm' for the top variable in the current context, by +-- building the 'TCM' computation which checks how much longer the context has +-- gotten since the variable was created and uses this to compute its deBruijn +-- index +openTermTopVar :: TCM OpenTerm +openTermTopVar = + do outer_ctx <- askCtx + return $ OpenTerm $ do + inner_ctx <- askCtx + typeInferComplete (LocalVar (length inner_ctx + - length outer_ctx) :: TermF Term) + +-- | Build an open term inside a binder of a variable with the given name and +-- type, where the binder is represented as a Haskell function on 'OpenTerm's +bindOpenTerm :: LocalName -> TypedTerm -> (OpenTerm -> OpenTerm) -> TCM TypedTerm +bindOpenTerm x tp body_f = + do tp_whnf <- typeCheckWHNF $ typedVal tp + withVar x tp_whnf (openTermTopVar >>= (unOpenTerm . body_f)) + +-- | Build a lambda abstraction as an 'OpenTerm' +lambdaOpenTerm :: LocalName -> OpenTerm -> (OpenTerm -> OpenTerm) -> OpenTerm +lambdaOpenTerm x (OpenTerm tpM) body_f = OpenTerm $ + do tp <- tpM + body <- bindOpenTerm x tp body_f + typeInferComplete $ Lambda x tp body + +-- | Build a nested sequence of lambda abstractions as an 'OpenTerm' +lambdaOpenTermMulti :: [(LocalName, OpenTerm)] -> ([OpenTerm] -> OpenTerm) -> + OpenTerm +lambdaOpenTermMulti xs_tps body_f = + foldr (\(x,tp) rest_f xs -> + lambdaOpenTerm x tp (rest_f . (:xs))) (body_f . reverse) xs_tps [] + +-- | Build a Pi abstraction as an 'OpenTerm' +piOpenTerm :: LocalName -> OpenTerm -> (OpenTerm -> OpenTerm) -> OpenTerm +piOpenTerm x (OpenTerm tpM) body_f = OpenTerm $ + do tp <- tpM + body <- bindOpenTerm x tp body_f + typeInferComplete $ Pi x tp body + +-- | Build a non-dependent function type. +arrowOpenTerm :: LocalName -> OpenTerm -> OpenTerm -> OpenTerm +arrowOpenTerm x tp body = piOpenTerm x tp (const body) + +-- | Build a nested sequence of Pi abstractions as an 'OpenTerm' +piOpenTermMulti :: [(LocalName, OpenTerm)] -> ([OpenTerm] -> OpenTerm) -> + OpenTerm +piOpenTermMulti xs_tps body_f = + foldr (\(x,tp) rest_f xs -> + piOpenTerm x tp (rest_f . (:xs))) (body_f . reverse) xs_tps [] + +-- | Build a let expression as an 'OpenTerm'. This is equivalent to +-- > 'applyOpenTerm' ('lambdaOpenTerm' x tp body) rhs +letOpenTerm :: LocalName -> OpenTerm -> OpenTerm -> (OpenTerm -> OpenTerm) -> + OpenTerm +letOpenTerm x tp rhs body_f = applyOpenTerm (lambdaOpenTerm x tp body_f) rhs + +-- | The monad for building 'OpenTerm's if you want to add in 'IO' actions. This +-- is just the type-checking monad, but we give it a new name to keep this +-- module self-contained. +newtype OpenTermM a = OpenTermM { unOpenTermM :: TCM a } + deriving (Functor, Applicative, Monad) + +instance MonadIO OpenTermM where + liftIO = OpenTermM . liftIO + +-- | "Complete" an 'OpenTerm' build in 'OpenTermM' to a closed term, or 'fail' +-- on a type-checking error +completeOpenTermM :: SharedContext -> OpenTermM OpenTerm -> IO Term +completeOpenTermM sc (OpenTermM termM) = + either (fail . show) return =<< + runTCM (typedVal <$> join (fmap unOpenTerm termM)) sc Nothing [] + +-- | "De-duplicate" an open term, so that duplicating the returned 'OpenTerm' +-- does not lead to duplicated WHNF work +dedupOpenTermM :: OpenTerm -> OpenTermM OpenTerm +dedupOpenTermM (OpenTerm trmM) = + OpenTermM $ do trm <- trmM + return $ OpenTerm $ return trm + +-- | Build an open term inside a binder of a variable with the given name and +-- type, where the binder is represented as a monadic Haskell function on +-- 'OpenTerm's that also returns an auxiliary value. Returns the normalized type +-- and the body, along with the auxiliary result returned by the body-generating +-- function. +bindOpenTermAuxM :: + LocalName -> OpenTerm -> + (OpenTerm -> OpenTermM (OpenTerm, a)) -> + OpenTermM (TypedTerm, TypedTerm, a) +bindOpenTermAuxM x (OpenTerm tpM) body_f = + OpenTermM $ + do TypedTerm tp tp_tp <- tpM + tp_whnf <- typeCheckWHNF tp + (OpenTerm bodyM, a) <- + withVar x tp_whnf (openTermTopVar >>= (unOpenTermM . body_f)) + body <- bodyM + return (TypedTerm tp_whnf tp_tp, body, a) + +-- | Build a lambda abstraction in the 'OpenTermM' monad +lambdaOpenTermM :: + LocalName -> OpenTerm -> (OpenTerm -> OpenTermM OpenTerm) -> + OpenTermM OpenTerm +lambdaOpenTermM x tp body_f = + fst <$> lambdaOpenTermAuxM x tp (body_f >=> (\t -> return (t, ()))) + +-- | Build a pi abstraction in the 'OpenTermM' monad +piOpenTermM :: + LocalName -> OpenTerm -> (OpenTerm -> OpenTermM OpenTerm) -> + OpenTermM OpenTerm +piOpenTermM x tp body_f = + fst <$> piOpenTermAuxM x tp (body_f >=> (\t -> return (t, ()))) + +-- | Build a lambda abstraction with an auxiliary return value in the +-- 'OpenTermM' monad +lambdaOpenTermAuxM :: + LocalName -> OpenTerm -> + (OpenTerm -> OpenTermM (OpenTerm, a)) -> + OpenTermM (OpenTerm, a) +lambdaOpenTermAuxM x tp body_f = + do (tp', body, a) <- bindOpenTermAuxM x tp body_f + return (OpenTerm (typeInferComplete $ Lambda x tp' body), a) + +-- | Build a pi abstraction with an auxiliary return value in the 'OpenTermM' +-- monad +piOpenTermAuxM :: + LocalName -> OpenTerm -> (OpenTerm -> OpenTermM (OpenTerm, a)) -> + OpenTermM (OpenTerm, a) +piOpenTermAuxM x tp body_f = + do (tp', body, a) <- bindOpenTermAuxM x tp body_f + return (OpenTerm (typeInferComplete $ Pi x tp' body), a) diff --git a/saw-core/src/Verifier/SAW/ParserUtils.hs b/saw-core/src/Verifier/SAW/ParserUtils.hs new file mode 100644 index 0000000000..f30eab06e9 --- /dev/null +++ b/saw-core/src/Verifier/SAW/ParserUtils.hs @@ -0,0 +1,218 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} + +{- | +Module : Verifier.SAW.ParserUtils +Copyright : Galois, Inc. 2012-2015 +License : BSD3 +Maintainer : jhendrix@galois.com +Stability : experimental +Portability : non-portable (language extensions) +-} + +module Verifier.SAW.ParserUtils + ( module Verifier.SAW.TypedAST + -- * Parser utilities. + , readModuleFromFile + -- * Template haskell utilities. + , DecWriter + , runDecWriter + , defineModuleFromFile + , declareSharedModuleFns + , defineModuleFromFileWithFns + , tcInsertModule -- re-exported for code using defineModuleFromFileWithFns + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif +import Control.Monad.State +import qualified Data.ByteString.Lazy as BL +#if !MIN_VERSION_template_haskell(2,8,0) +import qualified Data.ByteString.Lazy.UTF8 as UTF8 +#endif +import Data.Text (Text) +import qualified Data.Text as Text +import Language.Haskell.TH +#if MIN_VERSION_template_haskell(2,7,0) +import Language.Haskell.TH.Syntax (qAddDependentFile) +#endif +import System.Directory +import qualified Language.Haskell.TH.Syntax as TH (lift) + +import qualified Verifier.SAW.UntypedAST as Un +import qualified Verifier.SAW.Grammar as Un +import Verifier.SAW.SharedTerm +import Verifier.SAW.TypedAST +import Verifier.SAW.Typechecker (tcInsertModule) + +-- | Parse an untyped module declaration from a byte-string +readModule :: FilePath -> FilePath -> BL.ByteString -> Un.Module +readModule base path b = + case Un.parseSAW base path b of + Right m -> m + Left err -> error $ "Module parsing failed:\n" ++ show err + +-- | Parse an untyped module from file +readModuleFromFile :: FilePath -> IO Un.Module +readModuleFromFile path = do + base <- getCurrentDirectory + b <- BL.readFile path + return $ readModule base path b + + +-- | Monad for defining TH declarations +type DecWriter = StateT [Dec] Q + +-- | Run declaration writer returning list of TH declarations +runDecWriter :: DecWriter () -> Q [Dec] +runDecWriter m = execStateT m [] + +-- | Emit a list of TH declarations, adding them to the current list +addDecs :: [Dec] -> DecWriter () +addDecs decs = modify (++ decs) + +-- | Record @path@ as a dependency for this compilation +addDep :: FilePath -> DecWriter () +#if MIN_VERSION_template_haskell(2,7,0) +addDep path = lift $ qAddDependentFile path +#else +addDep path = return () +#endif + +-- | @defineModuleFromFile str file@ reads an untyped module from @file@, adds a +-- TH declaration of the name @str@ that is bound to that module at runtime, and +-- also returns the module at TH time +defineModuleFromFile :: String -> FilePath -> DecWriter Un.Module +defineModuleFromFile decNameStr path = do + addDep path + m <- lift $ runIO $ readModuleFromFile path + let decName = mkName decNameStr + moduleTp <- lift $ [t| Un.Module |] + body <- lift $ TH.lift m + addDecs [ SigD decName moduleTp + , FunD decName [ Clause [] (NormalB body) [] ]] + return m + + +-- | Return the type +-- +-- > 'SharedContext' -> 'Term' -> .. -> 'Term' -> 'IO' 'Term' +-- +-- that takes in @n@ 'Term's +termFunctionType :: Int -> Q Type +termFunctionType n = [t| SharedContext -> $(go n) |] + where + go 0 = [t| IO Term |] + go i = [t| Term -> $(go (i-1)) |] + +-- | @declareTermApplyFun nm t n@ declares a Haskell function +-- +-- > nm :: SharedContext -> Term -> ... -> Term -> IO Term +-- +-- that takes in @n@ 'Term's and applies (the 'Term' generated at runtime by the +-- expression) @t@ to them +declareTermApplyFun :: String -> Int -> (Name -> Q Exp -> Q Exp) -> DecWriter () +declareTermApplyFun nm n tf = + do let decName = mkName nm + sc <- lift $ newName "sc" + tp <- lift $ termFunctionType n + vars <- lift $ mapM newName (map (("t"++) . show) [1 .. n]) + body <- lift $ tf sc (listE $ map varE vars) + addDecs [ SigD decName tp + , FunD decName [ Clause (VarP sc : map VarP vars) (NormalB body) [] ] + ] + +-- | @declareTypedNameFun sc_fun mnm nm apply_p tp@ declares a Haskell function +-- +-- > scXXXmnm_nm :: SharedContext -> Term -> ... -> Term -> IO Term +-- +-- where @XXX@ is @"Apply"@ if @apply_p@ is 'True', and empty otherwise. This +-- function will fully apply the constructor, datatype, or declared name +-- specified by @nm@ in module @mnm@, using the shared term constructor function +-- @sc_fun@, which should have type +-- +-- > SharedContext -> Ident -> [Term] -> IO Term +-- +-- The number of 'Term's to take as arguments is given by the arity of @tp@, +-- i.e., the number of nested pi-abstractions it contains at top level. +declareTypedNameFun :: Q Exp -> ModuleName -> Text -> Bool -> Un.Term -> + DecWriter () +declareTypedNameFun sc_fun mnm nm apply_p tp = + let th_nm = (if apply_p then "scApply" else "sc") ++ show mnm ++ "_" ++ Text.unpack nm in + declareTermApplyFun th_nm (length $ fst $ Un.asPiList tp) $ \sc ts -> + [| $(sc_fun) $(varE sc) + (mkIdent mnm $(stringE (Text.unpack nm))) + $(ts) |] + +-- | Declare a Haskell function +-- +-- > scApplyMMM_d :: SharedContext -> Term -> ... -> Term -> IO Term +-- +-- for declared name (primitive, axiom, or definition) @d@ with type @tp@ in +-- module @MMM@ +declareDefFun :: ModuleName -> Text -> Un.Term -> DecWriter () +declareDefFun mnm d tp = + declareTypedNameFun [| scGlobalApply |] mnm d True tp + +-- | Declare a Haskell function +-- +-- > scMMM_d :: SharedContext -> Term -> ... -> Term -> IO Term +-- +-- for datatype @d@ with parameters @p_ctx@ and type @tp@ in module @MMM@ +declareDataTypeFun :: ModuleName -> Text -> Un.Term -> DecWriter () +declareDataTypeFun mnm d tp = + declareTypedNameFun [| scDataTypeApp |] mnm d False tp + +-- | Declare a Haskell function +-- +-- > scApplyMMM_c :: SharedContext -> Term -> ... -> Term -> IO Term +-- +-- for constructor @c@ with type (including parameters) @tp@ in module @MMM@ +declareCtorFun :: ModuleName -> Text -> Un.Term -> DecWriter () +declareCtorFun mnm c tp = + declareTypedNameFun [| scCtorApp |] mnm c True tp + + +-- | Declare Haskell functions, via 'declareTermApplyFun', that build shared +-- terms for each of the definitions, datatypes, and constructors in a +-- module. Each datatype @d@ gets a function +-- +-- > scMMM_d :: SharedContext -> Term -> ... -> Term -> IO Term +-- +-- where @MMM@ is the name of the module. Similarly, each constructor or +-- definition @d@ gets +-- +-- > scApplyMMM_d :: SharedContext -> Term -> ... -> Term -> IO Term +declareSharedModuleFns :: Un.Module -> DecWriter () +declareSharedModuleFns m = + do forM_ (Un.moduleTypedDecls m) $ \(d,tp) -> + declareDefFun (Un.moduleName m) d tp + forM_ (Un.moduleTypedDataDecls m) $ \(d,tp) -> + declareDataTypeFun (Un.moduleName m) d tp + forM_ (Un.moduleTypedCtorDecls m) $ \(c,tp) -> + declareCtorFun (Un.moduleName m) c tp + + +-- | @defineModuleFromFileWithFns str str2 file@ reads an untyped module from +-- @file@, adds a TH declaration of the name @str@ that is bound to that module +-- at runtime, and then calls 'declareSharedModuleFns' to add declarations of +-- Haskell term-building functions for each definition, constructor, and +-- datatype declared in the module that is loaded. It also defines the function +-- +-- > str2 :: SharedContext -> IO () +-- +-- that will load the module @str@ into the current 'SharedContext'. +defineModuleFromFileWithFns :: String -> String -> FilePath -> Q [Dec] +defineModuleFromFileWithFns mod_name mod_loader path = + runDecWriter $ + do m <- defineModuleFromFile mod_name path + declareSharedModuleFns m + let sc = mkName "sc" + load_tp <- lift $ [t| SharedContext -> IO () |] + load_body <- + lift $ [e| tcInsertModule $(varE sc) $(varE $ mkName mod_name) |] + addDecs [ SigD (mkName mod_loader) load_tp + , FunD (mkName mod_loader) [ Clause [VarP sc] (NormalB load_body) [] ] + ] diff --git a/saw-core/src/Verifier/SAW/Position.hs b/saw-core/src/Verifier/SAW/Position.hs new file mode 100644 index 0000000000..c459de2f39 --- /dev/null +++ b/saw-core/src/Verifier/SAW/Position.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveLift #-} + +{- | +Module : Verifier.SAW.Position +Copyright : Galois, Inc. 2012-2015 +License : BSD3 +Maintainer : jhendrix@galois.com +Stability : experimental +Portability : non-portable (language extensions) +-} + +module Verifier.SAW.Position + ( Pos(..) + , ppPos + , incLine + , incCol + , Positioned(..) + , PosPair(..) + ) where + +import qualified Language.Haskell.TH.Syntax as TH +import System.FilePath (makeRelative) + +data Pos = Pos { -- | Base directory to use for pretty printing purposes + posBase :: !FilePath + , posPath :: !FilePath + , posLine :: !Int + , posCol :: !Int + } + deriving (Show, TH.Lift) + +posTuple :: Pos -> (Int,Int,FilePath) +posTuple x = (posLine x, posCol x, posPath x) + +-- Eq instance overridden to compare positions in the same file more efficiently. +instance Eq Pos where + x == y = posTuple x == posTuple y + +-- Ord instance overridden to compare positions in the same file more efficiently. +instance Ord Pos where + compare x y = compare (posTuple x) (posTuple y) + +ppPos :: Pos -> String +ppPos p = rp ++ ':' : show (posLine p) ++ ':' : show (posCol p) ++ ":" + where rp = makeRelative (posBase p) (posPath p) + +incLine :: Pos -> Pos +incLine p = p { posLine = 1 + posLine p, posCol = 0 } + +incCol :: Pos -> Pos +incCol p = p { posCol = 1 + posCol p } + +class Positioned v where + pos :: v -> Pos + +data PosPair v = PosPair { _pos :: !Pos, val :: !v } + deriving (Eq, Ord, Functor, Show, TH.Lift) + +instance Positioned (PosPair v) where + pos (PosPair p _) = p + diff --git a/saw-core/src/Verifier/SAW/Prelude.hs b/saw-core/src/Verifier/SAW/Prelude.hs new file mode 100644 index 0000000000..ad66544f16 --- /dev/null +++ b/saw-core/src/Verifier/SAW/Prelude.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +{- | +Module : Verifier.SAW.Prelude +Copyright : Galois, Inc. 2012-2015 +License : BSD3 +Maintainer : jhendrix@galois.com +Stability : experimental +Portability : non-portable (language extensions) +-} + +module Verifier.SAW.Prelude + ( Module + , module Verifier.SAW.Prelude + , module Verifier.SAW.Prelude.Constants + ) where + +import qualified Data.Map as Map + +import Verifier.SAW.ParserUtils +import Verifier.SAW.Prelude.Constants +import Verifier.SAW.SharedTerm +import Verifier.SAW.FiniteValue + +import Verifier.SAW.Simulator.Concrete (evalSharedTerm) +import Verifier.SAW.Simulator.Value (asFirstOrderTypeValue) + + +$(defineModuleFromFileWithFns + "preludeModule" "scLoadPreludeModule" "prelude/Prelude.sawcore") + +-- | Given two terms, compute a term representing a decidable +-- equality test between them. The terms are assumed to +-- be of the same type, which must be a first-order type. +-- The returned term will be of type @Bool@. +scEq :: SharedContext -> Term -> Term -> IO Term +scEq sc x y = do + xty <- scTypeOf sc x + mmap <- scGetModuleMap sc + case asFirstOrderTypeValue (evalSharedTerm mmap mempty mempty xty) of + Just fot -> scDecEq sc fot (Just (x,y)) + Nothing -> fail ("scEq: expected first order type, but got: " ++ showTerm xty) + +-- | Given a first-order type, return the decidable equality +-- operation on that type. If arguments are provided, they +-- will be applied, returning a value of type @Bool@. If no +-- arguments are provided a function of type @tp -> tp -> Bool@ +-- will be returned. +scDecEq :: + SharedContext -> + FirstOrderType {- ^ Type of elements to test for equality -} -> + Maybe (Term,Term) {- ^ optional arguments to apply -} -> + IO Term +scDecEq sc fot args = case fot of + FOTBit -> + do fn <- scGlobalDef sc "Prelude.boolEq" + case args of + Nothing -> return fn + Just (x,y) -> scApplyAll sc fn [x,y] + + FOTInt -> + do fn <- scGlobalDef sc "Prelude.intEq" + case args of + Nothing -> return fn + Just (x,y) -> scApplyAll sc fn [x,y] + + FOTIntMod m -> + do fn <- scGlobalDef sc "Prelude.intModEq" + m' <- scNat sc m + case args of + Nothing -> scApply sc fn m' + Just (x,y) -> scApplyAll sc fn [m',x,y] + + FOTVec w FOTBit -> + do fn <- scGlobalDef sc "Prelude.bvEq" + w' <- scNat sc w + case args of + Nothing -> scApply sc fn w' + Just (x,y) -> scApplyAll sc fn [w',x,y] + + FOTVec w t -> + do fn <- scGlobalDef sc "Prelude.vecEq" + w' <- scNat sc w + t' <- scFirstOrderType sc t + subFn <- scDecEq sc t Nothing + case args of + Nothing -> scApplyAll sc fn [w',t',subFn] + Just (x,y) -> scApplyAll sc fn [w',t',subFn,x,y] + + FOTArray a b -> + do a' <- scFirstOrderType sc a + b' <- scFirstOrderType sc b + fn <- scGlobalDef sc "Prelude.arrayEq" + case args of + Nothing -> scApplyAll sc fn [a',b'] + Just (x,y) -> scApplyAll sc fn [a',b',x,y] + + FOTTuple [] -> + case args of + Nothing -> scGlobalDef sc "Prelude.unitEq" + Just _ -> scBool sc True + + FOTTuple [t] -> scDecEq sc t args + + FOTTuple (t:ts) -> + do fnLeft <- scDecEq sc t Nothing + fnRight <- scDecEq sc (FOTTuple ts) Nothing + fn <- scGlobalDef sc "Prelude.pairEq" + t' <- scFirstOrderType sc t + ts' <- scFirstOrderType sc (FOTTuple ts) + case args of + Nothing -> scApplyAll sc fn [t',ts',fnLeft,fnRight] + Just (x,y) -> scApplyAll sc fn [t',ts',fnLeft,fnRight,x,y] + + FOTRec fs -> + case args of + Just (x,y) -> + mkRecordEqBody (Map.toList fs) x y + + Nothing -> + do x <- scLocalVar sc 1 + y <- scLocalVar sc 0 + tp <- scFirstOrderType sc fot + body <- mkRecordEqBody (Map.toList fs) x y + scLambdaList sc [("x",tp),("y",tp)] body + + where + mkRecordEqBody [] _x _y = scBool sc True + mkRecordEqBody [(f,tp)] x y = + do xf <- scRecordSelect sc x f + yf <- scRecordSelect sc y f + scDecEq sc tp (Just (xf,yf)) + mkRecordEqBody ((f,tp):fs) x y = + do xf <- scRecordSelect sc x f + yf <- scRecordSelect sc y f + fp <- scDecEq sc tp (Just (xf,yf)) + fsp <- mkRecordEqBody fs x y + scAnd sc fp fsp + +-- | For backwards compatibility: @Bool@ used to be a datatype, and so its +-- creation function was called @scPrelude_Bool@ instead of +-- @scApplyPrelude_Bool@ +scPrelude_Bool :: SharedContext -> IO Term +scPrelude_Bool = scApplyPrelude_Bool diff --git a/saw-core/src/Verifier/SAW/Prelude/Constants.hs b/saw-core/src/Verifier/SAW/Prelude/Constants.hs new file mode 100644 index 0000000000..fbc4163683 --- /dev/null +++ b/saw-core/src/Verifier/SAW/Prelude/Constants.hs @@ -0,0 +1,45 @@ +{- | +Module : Verifier.SAW.Prelude.Constants +Copyright : Galois, Inc. 2012-2015 +License : BSD3 +Maintainer : jhendrix@galois.com +Stability : experimental +Portability : non-portable (language extensions) +-} + +module Verifier.SAW.Prelude.Constants where + +import Verifier.SAW.Term.Functor + +preludeModuleName :: ModuleName +preludeModuleName = mkModuleName ["Prelude"] + +preludeNatIdent :: Ident +preludeNatIdent = mkIdent preludeModuleName "Nat" + +preludeNatType :: FlatTermF e +preludeNatType = DataTypeApp preludeNatIdent [] [] + +preludeZeroIdent :: Ident +preludeZeroIdent = mkIdent preludeModuleName "Zero" + +preludeSuccIdent :: Ident +preludeSuccIdent = mkIdent preludeModuleName "Succ" + +preludeIntegerIdent :: Ident +preludeIntegerIdent = mkIdent preludeModuleName "Integer" + +preludeVecIdent :: Ident +preludeVecIdent = mkIdent preludeModuleName "Vec" + +preludeFloatIdent :: Ident +preludeFloatIdent = mkIdent preludeModuleName "Float" + +preludeDoubleIdent :: Ident +preludeDoubleIdent = mkIdent preludeModuleName "Double" + +preludeStringIdent :: Ident +preludeStringIdent = mkIdent preludeModuleName "String" + +preludeArrayIdent :: Ident +preludeArrayIdent = mkIdent preludeModuleName "Array" diff --git a/saw-core/src/Verifier/SAW/Prim.hs b/saw-core/src/Verifier/SAW/Prim.hs new file mode 100644 index 0000000000..cfb1572546 --- /dev/null +++ b/saw-core/src/Verifier/SAW/Prim.hs @@ -0,0 +1,313 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} + +{- | +Module : Verifier.SAW.Prim +Copyright : Galois, Inc. 2012-2015 +License : BSD3 +Maintainer : jhendrix@galois.com +Stability : experimental +Portability : non-portable (language extensions) +-} + +module Verifier.SAW.Prim where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif +import qualified Control.Exception as X +import Data.Bits +import Data.Typeable (Typeable) +import Data.Vector (Vector) +import qualified Data.Vector as V +import Numeric.Natural (Natural) + +------------------------------------------------------------ +-- Natural numbers + +-- | width(n) = 1 + floor(log_2(n)) +widthNat :: Natural -> Natural +widthNat 0 = 0 +widthNat n = 1 + widthNat (n `div` 2) + +-- data Vec :: (n :: Nat) -> sort 0 -> sort 0 +data Vec t a = Vec t !(Vector a) + +------------------------------------------------------------ +-- Unsigned, variable-width bit vectors + +data BitVector = BV { width :: !Int, unsigned :: !Integer } + deriving Show +-- ^ Invariant: BV w x requires that 0 <= x < 2^w. + +bitMask :: Int -> Integer +bitMask w = bit w - 1 + +-- | Smart constructor for bitvectors. +bv :: Int -> Integer -> BitVector +bv w x = BV w (x .&. bitMask w) + +signed :: BitVector -> Integer +signed (BV w x) + | w > 0 && testBit x (w - 1) = x - bit w + | otherwise = x + +bvAt :: BitVector -> Int -> Bool +bvAt (BV w x) i = testBit x (w - 1 - i) + +------------------------------------------------------------ +-- Primitive operations + +-- coerce :: (y x :: sort 0) -> Eq (sort 0) x y -> x -> y; +coerce :: () -> () -> () -> a -> a +coerce _ _ _ x = x + +-- ite :: ?(a :: sort 1) -> Bool -> a -> a -> a; +ite :: t -> Bool -> a -> a -> a +ite _ b x y = if b then x else y + +-- Succ :: Nat -> Nat; +succNat :: Integer -> Integer +succNat = succ + +-- addNat :: Nat -> Nat -> Nat; +addNat :: Integer -> Integer -> Integer +addNat = (+) + +-- get :: (n :: Nat) -> (e :: sort 0) -> Vec n e -> Fin n -> e; +--get :: Int -> t -> Vec t e -> Fin -> e +--get _ _ (Vec _ v) i = v ! fromEnum i + +-- append :: (m n :: Nat) -> (e :: sort 0) -> Vec m e -> Vec n e -> Vec (addNat m n) e; +append :: Int -> Int -> t -> Vec t e -> Vec t e -> Vec t e +append _ _ _ (Vec t xv) (Vec _ yv) = Vec t ((V.++) xv yv) + +-- at :: (n :: Nat) -> (a :: sort 0) -> Vec n a -> Nat -> a; +at :: Int -> t -> Vec t e -> Int -> e +at _ _ (Vec _ v) i = v ! i + +-- atWithDefault :: (n :: Nat) -> (a :: sort 0) -> a -> Vec n a -> Nat -> a; +atWithDefault :: Int -> t -> e -> Vec t e -> Int -> e +atWithDefault _ _ z (Vec _ v) i + | i < V.length v = v ! i + | otherwise = z + +-- upd :: (n :: Nat) -> (a :: sort 0) -> Vec n a -> Nat -> a -> Vec n a; +upd :: Int -> t -> Vec t e -> Int -> e -> Vec t e +upd _ _ (Vec t v) i e = Vec t (v V.// [(i, e)]) + +(!) :: Vector a -> Int -> a +(!) v i = case v V.!? i of + Just x -> x + Nothing -> invalidIndex (toInteger i) + +---------------------------------------- +-- Bitvector operations + +-- bvNat : (n : Nat) -> Nat -> Vec n Bool; +bvNat :: Int -> Integer -> BitVector +bvNat w x = bv w x + +-- bvAdd : (n : Nat) -> Vec n Bool -> Vec n Bool -> Vec n Bool; +bvAdd, bvSub, bvMul :: Natural -> BitVector -> BitVector -> BitVector +bvAdd _ (BV w x) (BV _ y) = bv w (x + y) +bvSub _ (BV w x) (BV _ y) = bv w (x - y) +bvMul _ (BV w x) (BV _ y) = bv w (x * y) + +bvNeg :: Natural -> BitVector -> BitVector +bvNeg _ x@(BV w _) = bv w $ negate $ signed x + +bvAnd, bvOr, bvXor :: Int -> BitVector -> BitVector -> BitVector +bvAnd _ (BV w x) (BV _ y) = BV w (x .&. y) +bvOr _ (BV w x) (BV _ y) = BV w (x .|. y) +bvXor _ (BV w x) (BV _ y) = BV w (x `xor` y) + +bvNot :: Int -> BitVector -> BitVector +bvNot _ (BV w x) = BV w (x `xor` bitMask w) + +bvEq, bvult, bvule, bvugt, bvuge, bvsgt, bvsge, bvslt, bvsle + :: Int -> BitVector -> BitVector -> Bool +bvEq _ x y = unsigned x == unsigned y +bvugt _ x y = unsigned x > unsigned y +bvuge _ x y = unsigned x >= unsigned y +bvult _ x y = unsigned x < unsigned y +bvule _ x y = unsigned x <= unsigned y +bvsgt _ x y = signed x > signed y +bvsge _ x y = signed x >= signed y +bvslt _ x y = signed x < signed y +bvsle _ x y = signed x <= signed y + +bvPopcount :: Int -> BitVector -> BitVector +bvPopcount _ (BV w x) = BV w (toInteger (popCount x)) + +bvCountLeadingZeros :: Int -> BitVector -> BitVector +bvCountLeadingZeros _ (BV w x) = BV w (toInteger (go 0)) + where + go !i + | i < w && testBit x (w - i - 1) == False = go (i+1) + | otherwise = i + +bvCountTrailingZeros :: Int -> BitVector -> BitVector +bvCountTrailingZeros _ (BV w x) = BV w (toInteger (go 0)) + where + go !i + | i < w && testBit x i == False = go (i+1) + | otherwise = i + +-- | @get@ specialized to BitVector (big-endian) +-- get :: (n :: Nat) -> (a :: sort 0) -> Vec n a -> Fin n -> a; +--get_bv :: Int -> () -> BitVector -> Fin -> Bool +--get_bv _ _ x i = testBit (unsigned x) (width x - 1 - fromEnum i) +-- little-endian version: +-- get_bv _ _ x i = testBit (unsigned x) (fromEnum i) + +-- | @at@ specialized to BitVector (big-endian) +-- at :: (n :: Nat) -> (a :: sort 0) -> Vec n a -> Nat -> a; +at_bv :: Int -> () -> BitVector -> Natural -> Bool +at_bv _ _ x i = testBit (unsigned x) (width x - 1 - fromIntegral i) + +-- | @set@ specialized to BitVector (big-endian) +-- set :: (n :: Nat) -> (a :: sort 0) -> Vec n a -> Fin n -> a -> Vec n a; +--set_bv :: Int -> () -> BitVector -> Fin -> Bool -> BitVector +--set_bv _ _ x i b = BV (width x) $ f (unsigned x) (width x - 1 - fromEnum i) +-- where f = if b then setBit else clearBit + +-- | @append@ specialized to BitVector (big-endian) +-- append :: (m n :: Nat) -> (a :: sort 0) -> Vec m a -> Vec n a -> Vec (addNat m n) a; +append_bv :: Int -> Int -> () -> BitVector -> BitVector -> BitVector +append_bv _ _ _ (BV m x) (BV n y) = BV (m + n) (shiftL x n .|. y) +-- little-endian version: +-- append_bv _ _ _ (BV m x) (BV n y) = BV (m + n) (x .|. shiftL y m) + +-- bvToNat : (n : Nat) -> Vec n Bool -> Nat; +bvToNat :: Int -> BitVector -> Integer +bvToNat _ (BV _ x) = x + +-- bvAddWithCarry : (n : Nat) -> Vec n Bool -> Vec n Bool -> Bool * Vec n Bool; +bvAddWithCarry :: Int -> BitVector -> BitVector -> (Bool, BitVector) +bvAddWithCarry _ (BV w x) (BV _ y) = (testBit z w, bv w z) + where z = x + y + +bvUDiv :: Int -> BitVector -> BitVector -> Maybe BitVector +bvUDiv _ (BV w x) (BV _ y) + | y == 0 = Nothing + | otherwise = Just (bv w (x `quot` y)) + +bvURem :: Int -> BitVector -> BitVector -> Maybe BitVector +bvURem _ (BV w x) (BV _ y) + | y == 0 = Nothing + | otherwise = Just (bv w (x `rem` y)) + +bvSDiv :: Int -> BitVector -> BitVector -> Maybe BitVector +bvSDiv _ x y + | unsigned y == 0 = Nothing + | otherwise = Just (bv (width x) (signed x `quot` signed y)) + +bvSRem :: Int -> BitVector -> BitVector -> Maybe BitVector +bvSRem _ x y + | unsigned y == 0 = Nothing + | otherwise = Just (bv (width x) (signed x `rem` signed y)) + +bvShl :: Int -> BitVector -> Int -> BitVector +bvShl _ (BV w x) i = bv w (x `shiftL` i) + +bvShr :: Int -> BitVector -> Int -> BitVector +bvShr _ (BV w x) i = bv w (x `shiftR` i) + +bvSShr :: Int -> BitVector -> Int -> BitVector +bvSShr _ x i = bv (width x) (signed x `shiftR` i) + +-- bvTrunc : (m n : Nat) -> Vec (addNat m n) Bool -> Vec n Bool; +bvTrunc :: Int -> Int -> BitVector -> BitVector +bvTrunc _ n (BV _ x) = bv n x + +-- bvUExt : (m n : Nat) -> Vec n Bool -> Vec (addNat m n) Bool; +bvUExt :: Int -> Int -> BitVector -> BitVector +bvUExt m n x = BV (m + n) (unsigned x) + +-- bvSExt : (m n : Nat) -> Vec (Succ n) Bool -> Vec (addNat m (Succ n)) Bool; +bvSExt :: Int -> Int -> BitVector -> BitVector +bvSExt m n x = bv (m + n + 1) (signed x) + +-- | @take@ specialized to BitVector (big-endian) +-- take :: (a :: sort 0) -> (m n :: Nat) -> Vec (addNat m n) a -> Vec m a; +take_bv :: () -> Int -> Int -> BitVector -> BitVector +take_bv _ m n (BV _ x) = bv m (x `shiftR` n) +-- little-endian version: +-- take_bv _ m _ (BV _ x) = bv m x + +-- | @vDrop@ specialized to BitVector (big-endian) +-- drop :: (a :: sort 0) -> (m n :: Nat) -> Vec (addNat m n) a -> Vec n a; +drop_bv :: () -> Int -> Int -> BitVector -> BitVector +drop_bv _ _ n (BV _ x) = bv n x +-- little-endian version: +-- drop_bv _ m n (BV _ x) = BV n (x `shiftR` m) + +-- | @slice@ specialized to BitVector +slice_bv :: () -> Int -> Int -> Int -> BitVector -> BitVector +slice_bv _ _ n o (BV _ x) = bv n (shiftR x o) +-- little-endian version: +-- slice_bv _ i n _ (BV _ x) = bv n (shiftR x i) + +------------------------------------------------------------ +-- Base 2 logarithm + +bvLg2 :: BitVector -> BitVector +bvLg2 (BV m x) = BV m (if d > 0 then k+1 else k) + where (k, d) = lg2rem x + +-- | lg2rem n = (k, d) <--> n = 2^k + d, with d < 2^k. +lg2rem :: Integer -> (Integer, Integer) +lg2rem 0 = (0, -1) +lg2rem 1 = (0, 0) +lg2rem n = (k+1, 2*d+r) + where (q, r) = n `divMod` 2 + (k, d) = lg2rem q + +---------------------------------------- +-- Errors + +data EvalError + = InvalidIndex Integer + | DivideByZero + | UnsupportedPrimitive String String + | UserError String + deriving (Eq, Typeable) + +instance X.Exception EvalError + +instance Show EvalError where + show e = case e of + InvalidIndex i -> "invalid sequence index: " ++ show i + DivideByZero -> "division by 0" + UnsupportedPrimitive b p -> "unsupported primitive " ++ p ++ " in " ++ b ++ " backend" + UserError msg -> "Run-time error: " ++ msg + +-- | A sequencing operation has gotten an invalid index. +invalidIndex :: Integer -> a +invalidIndex i = X.throw (InvalidIndex i) + +-- | For division by 0. +divideByZero :: a +divideByZero = X.throw DivideByZero + +-- | A backend with a unsupported primitive. +unsupportedPrimitive :: String -> String -> a +unsupportedPrimitive backend primitive = + X.throw $ UnsupportedPrimitive backend primitive + +-- | For `error` +userError :: String -> a +userError msg = X.throw (UserError msg) + +-- | Convert asynchronous EvalError exceptions into IO exceptions. +rethrowEvalError :: IO a -> IO a +rethrowEvalError m = run `X.catch` rethrow + where + run = do + a <- m + return $! a + + rethrow :: EvalError -> IO a + rethrow exn = fail (show exn) -- X.throwIO (EvalError exn) diff --git a/saw-core/src/Verifier/SAW/Recognizer.hs b/saw-core/src/Verifier/SAW/Recognizer.hs new file mode 100644 index 0000000000..28e9e9d6aa --- /dev/null +++ b/saw-core/src/Verifier/SAW/Recognizer.hs @@ -0,0 +1,390 @@ +{- | +Module : Verifier.SAW.Recognizer +Copyright : Galois, Inc. 2012-2015 +License : BSD3 +Maintainer : jhendrix@galois.com +Stability : experimental +Portability : non-portable (language extensions) + +Lightweight calculus for composing patterns as functions. +-} + +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} + +module Verifier.SAW.Recognizer + ( Recognizer + , (<:>), (<:), emptyl, endl + , (:*:)(..) + , asFTermF + + , asGlobalDef + , isGlobalDef + , asApp + , (<@>), (@>), (<@) + , asApplyAll + , asPairType + , asPairValue + , asPairSelector + , asTupleType + , asTupleValue + , asTupleSelector + , asRecordType + , asRecordValue + , asRecordSelector + , asCtorParams + , asCtor + , asCtorOrNat + , asDataType + , asDataTypeParams + , asRecursorApp + , isDataType + , asNat + , asBvNat + , asUnsignedConcreteBv + , asStringLit + , asLambda + , asLambdaList + , asPi + , asPiList + , asLocalVar + , asConstant + , asExtCns + , asSort + -- * Prelude recognizers. + , asBool + , asBoolType + , asIntegerType + , asIntModType + , asBitvectorType + , asVectorType + , asVecType + , isVecType + , asMux + , asEq + , asEqTrue + , asArrayType + ) where + +import Control.Applicative +import Control.Lens +import Control.Monad +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Text (Text) +import Numeric.Natural (Natural) + +import Verifier.SAW.Term.Functor +import Verifier.SAW.Prelude.Constants + +data a :*: b = (:*:) a b + deriving (Eq,Ord,Show) + +instance Field1 (a :*: b) (a' :*: b) a a' where + _1 k (a :*: b) = indexed k (0 :: Int) a <&> (:*: b) + +instance Field2 (a :*: b) (a :*: b') b b' where + _2 k (a :*: b) = (a :*:) <$> indexed k (1 :: Int) b + +type Recognizer t a = t -> Maybe a + +-- | Tries both recognizers. +orElse :: Recognizer t a -> Recognizer t a -> Recognizer t a +orElse f g t = f t <|> g t + +-- | Recognizes the head and tail of a list, and returns head. +(<:) :: Recognizer t a -> Recognizer [t] () -> Recognizer [t] a +(<:) f g (h:r) = do x <- f h; _ <- g r; return x +(<:) _ _ [] = Nothing + +-- | Recognizes the head and tail of a list, and returns both. +(<:>) :: Recognizer t a -> Recognizer [t] b -> Recognizer [t] (a :*: b) +(<:>) f g (h:r) = do x <- f h; y <- g r; return (x :*: y) +(<:>) _ _ [] = Nothing + +-- | Recognizes empty list +emptyl :: Recognizer [t] () +emptyl [] = return () +emptyl _ = Nothing + +-- | Recognizes singleton list +endl :: Recognizer t a -> Recognizer [t] a +endl f = f <: emptyl + +asFTermF :: Recognizer Term (FlatTermF Term) +asFTermF (unwrapTermF -> FTermF ftf) = return ftf +asFTermF _ = Nothing + +asModuleIdentifier :: Recognizer (ExtCns e) Ident +asModuleIdentifier (EC _ nmi _) = + case nmi of + ModuleIdentifier ident -> Just ident + _ -> Nothing + +asGlobalDef :: Recognizer Term Ident +asGlobalDef t = + case unwrapTermF t of + FTermF (Primitive ec) -> asModuleIdentifier ec + Constant ec _ -> asModuleIdentifier ec + _ -> Nothing + +isGlobalDef :: Ident -> Recognizer Term () +isGlobalDef i t = do + o <- asGlobalDef t + if i == o then Just () else Nothing + +asApp :: Recognizer Term (Term, Term) +asApp (unwrapTermF -> App x y) = return (x, y) +asApp _ = Nothing + +(<@>) :: Recognizer Term a -> Recognizer Term b -> Recognizer Term (a :*: b) +(<@>) f g t = do + (a,b) <- asApp t + liftM2 (:*:) (f a) (g b) + +-- | Recognizes a function application, and returns argument. +(@>) :: Recognizer Term () -> Recognizer Term b -> Recognizer Term b +(@>) f g t = do + (x, y) <- asApp t + liftM2 (const id) (f x) (g y) + +-- | Recognizes a function application, and returns the function +(<@) :: Recognizer Term a -> Recognizer Term () -> Recognizer Term a +(<@) f g t = do + (x, y) <- asApp t + liftM2 const (f x) (g y) + +asApplyAll :: Term -> (Term, [Term]) +asApplyAll = go [] + where go xs t = + case asApp t of + Nothing -> (t, xs) + Just (t', x) -> go (x : xs) t' + +asPairType :: Recognizer Term (Term, Term) +asPairType t = do + ftf <- asFTermF t + case ftf of + PairType x y -> return (x, y) + _ -> Nothing + +asPairValue :: Recognizer Term (Term, Term) +asPairValue t = do + ftf <- asFTermF t + case ftf of + PairValue x y -> return (x, y) + _ -> Nothing + +asPairSelector :: Recognizer Term (Term, Bool) +asPairSelector t = do + ftf <- asFTermF t + case ftf of + PairLeft x -> return (x, False) + PairRight x -> return (x, True) + _ -> Nothing + +destTupleType :: Term -> [Term] +destTupleType t = + case unwrapTermF t of + FTermF (PairType x y) -> x : destTupleType y + _ -> [t] + +destTupleValue :: Term -> [Term] +destTupleValue t = + case unwrapTermF t of + FTermF (PairValue x y) -> x : destTupleType y + _ -> [t] + +asTupleType :: Recognizer Term [Term] +asTupleType t = + do ftf <- asFTermF t + case ftf of + UnitType -> Just [] + PairType x y -> Just (x : destTupleType y) + _ -> Nothing + +asTupleValue :: Recognizer Term [Term] +asTupleValue t = + do ftf <- asFTermF t + case ftf of + UnitValue -> Just [] + PairValue x y -> Just (x : destTupleValue y) + _ -> Nothing + +asTupleSelector :: Recognizer Term (Term, Int) +asTupleSelector t = do + ftf <- asFTermF t + case ftf of + PairLeft x -> return (x, 1) + PairRight y -> do (x, i) <- asTupleSelector y; return (x, i+1) + _ -> Nothing + +asRecordType :: Recognizer Term (Map FieldName Term) +asRecordType t = do + ftf <- asFTermF t + case ftf of + RecordType elems -> return $ Map.fromList elems + _ -> Nothing + +asRecordValue :: Recognizer Term (Map FieldName Term) +asRecordValue t = do + ftf <- asFTermF t + case ftf of + RecordValue elems -> return $ Map.fromList elems + _ -> Nothing + +asRecordSelector :: Recognizer Term (Term, FieldName) +asRecordSelector t = do + RecordProj u s <- asFTermF t + return (u, s) + +-- | Test whether a term is an application of a constructor, and, if so, return +-- the constructor, its parameters, and its arguments +asCtorParams :: Recognizer Term (Ident, [Term], [Term]) +asCtorParams t = do CtorApp c ps args <- asFTermF t; return (c,ps,args) + +-- | Just like 'asCtorParams', but treat natural number literals as constructor +-- applications, i.e., @0@ becomes the constructor @Zero@, and any non-zero +-- literal @k@ becomes @Succ (k-1)@ +asCtorOrNat :: Recognizer Term (Ident, [Term], [Term]) +asCtorOrNat = asCtorParams `orElse` (asNatLit >=> helper) where + asNatLit (unwrapTermF -> FTermF (NatLit i)) = return i + asNatLit _ = Nothing + helper 0 = return (preludeZeroIdent, [], []) + helper k = + if k > 0 then + return (preludeSuccIdent, [], [Unshared (FTermF (NatLit $ k-1))]) + else error "asCtorOrNat: negative natural number literal!" + + +-- | A version of 'asCtorParams' that combines the parameters and normal args +asCtor :: Recognizer Term (Ident, [Term]) +asCtor t = do CtorApp c ps args <- asFTermF t; return (c,ps ++ args) + +-- | A version of 'asDataType' that returns the parameters separately +asDataTypeParams :: Recognizer Term (Ident, [Term], [Term]) +asDataTypeParams t = do DataTypeApp c ps args <- asFTermF t; return (c,ps,args) + +-- | A version of 'asDataTypeParams' that combines the params and normal args +asDataType :: Recognizer Term (Ident, [Term]) +asDataType t = do DataTypeApp c ps args <- asFTermF t; return (c,ps ++ args) + +asRecursorApp :: Recognizer Term (Ident,[Term],Term, + [(Ident,Term)],[Term],Term) +asRecursorApp t = + do RecursorApp d params p_ret cs_fs ixs arg <- asFTermF t; + return (d, params, p_ret, cs_fs, ixs, arg) + +isDataType :: Ident -> Recognizer [Term] a -> Recognizer Term a +isDataType i p t = do + (o,l) <- asDataType t + if i == o then p l else Nothing + +asNat :: Recognizer Term Natural +asNat (unwrapTermF -> FTermF (NatLit i)) = return i +asNat (asCtor -> Just (c, [])) | c == "Prelude.Zero" = return 0 +asNat (asCtor -> Just (c, [asNat -> Just i])) | c == "Prelude.Succ" = return (i+1) +asNat _ = Nothing + +asBvNat :: Recognizer Term (Natural :*: Natural) +asBvNat = (isGlobalDef "Prelude.bvNat" @> asNat) <@> asNat + +asUnsignedConcreteBv :: Recognizer Term Natural +asUnsignedConcreteBv term = do + (n :*: v) <- asBvNat term + return $ mod v (2 ^ n) + +asStringLit :: Recognizer Term Text +asStringLit t = do StringLit i <- asFTermF t; return i + +asLambda :: Recognizer Term (LocalName, Term, Term) +asLambda (unwrapTermF -> Lambda s ty body) = return (s, ty, body) +asLambda _ = Nothing + +asLambdaList :: Term -> ([(LocalName, Term)], Term) +asLambdaList = go [] + where go r (asLambda -> Just (nm,tp,rhs)) = go ((nm,tp):r) rhs + go r rhs = (reverse r, rhs) + +asPi :: Recognizer Term (LocalName, Term, Term) +asPi (unwrapTermF -> Pi nm tp body) = return (nm, tp, body) +asPi _ = Nothing + +-- | Decomposes a term into a list of pi bindings, followed by a right +-- term that is not a pi binding. +asPiList :: Term -> ([(LocalName, Term)], Term) +asPiList = go [] + where go r (asPi -> Just (nm,tp,rhs)) = go ((nm,tp):r) rhs + go r rhs = (reverse r, rhs) + +asLocalVar :: Recognizer Term DeBruijnIndex +asLocalVar (unwrapTermF -> LocalVar i) = return i +asLocalVar _ = Nothing + +asConstant :: Recognizer Term (ExtCns Term, Term) +asConstant (unwrapTermF -> Constant ec t) = return (ec, t) +asConstant _ = Nothing + +asExtCns :: Recognizer Term (ExtCns Term) +asExtCns t = do + ftf <- asFTermF t + case ftf of + ExtCns ec -> return ec + _ -> Nothing + +asSort :: Recognizer Term Sort +asSort t = do + ftf <- asFTermF t + case ftf of + Sort s -> return s + _ -> Nothing + +-- | Returns term as a constant Boolean if it is one. +asBool :: Recognizer Term Bool +asBool (isGlobalDef "Prelude.True" -> Just ()) = return True +asBool (isGlobalDef "Prelude.False" -> Just ()) = return False +asBool _ = Nothing + +asBoolType :: Recognizer Term () +asBoolType = isGlobalDef "Prelude.Bool" + +asIntegerType :: Recognizer Term () +asIntegerType = isGlobalDef "Prelude.Integer" + +asIntModType :: Recognizer Term Natural +asIntModType = isGlobalDef "Prelude.IntMod" @> asNat + +asVectorType :: Recognizer Term (Term, Term) +asVectorType = helper ((isGlobalDef "Prelude.Vec" @> return) <@> return) where + helper r t = + do (n :*: a) <- r t + return (n, a) + +isVecType :: Recognizer Term a -> Recognizer Term (Natural :*: a) +isVecType tp = (isGlobalDef "Prelude.Vec" @> asNat) <@> tp + +asVecType :: Recognizer Term (Natural :*: Term) +asVecType = isVecType return + +asBitvectorType :: Recognizer Term Natural +asBitvectorType = (isGlobalDef "Prelude.Vec" @> asNat) <@ asBoolType + +asMux :: Recognizer Term (Term :*: Term :*: Term :*: Term) +asMux = isGlobalDef "Prelude.ite" @> return <@> return <@> return <@> return + +asEq :: Recognizer Term (Term, Term, Term) +asEq t = + do (o, l) <- asDataType t + case l of + [a, x, y] | "Prelude.Eq" == o -> return (a, x, y) + _ -> Nothing + +asEqTrue :: Recognizer Term Term +asEqTrue = isGlobalDef "Prelude.EqTrue" @> return + +asArrayType :: Recognizer Term (Term :*: Term) +asArrayType = (isGlobalDef "Prelude.Array" @> return) <@> return diff --git a/saw-core/src/Verifier/SAW/Rewriter.hs b/saw-core/src/Verifier/SAW/Rewriter.hs new file mode 100644 index 0000000000..18d18a4fcf --- /dev/null +++ b/saw-core/src/Verifier/SAW/Rewriter.hs @@ -0,0 +1,893 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} + +{- | +Module : Verifier.SAW.Rewriter +Copyright : Galois, Inc. 2012-2015 +License : BSD3 +Maintainer : jhendrix@galois.com +Stability : experimental +Portability : non-portable (language extensions) +-} + +module Verifier.SAW.Rewriter + ( -- * Rewrite rules + RewriteRule + , ctxtRewriteRule + , lhsRewriteRule + , rhsRewriteRule + , ruleOfTerm + , ruleOfTerms + , ruleOfProp + , scDefRewriteRules + , scEqsRewriteRules + , scEqRewriteRule + -- * Simplification sets + , Simpset + , emptySimpset + , addRule + , delRule + , addRules + , addSimp + , delSimp + , addConv + , addConvs + , scSimpset + , listRules + -- * Term rewriting + , rewriteSharedTerm + , rewriteSharedTermTypeSafe + -- * Matching + , scMatch + -- * SharedContext + , rewritingSharedContext + + , replaceTerm + , hoistIfs + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>), pure, (<*>)) +import Data.Foldable (Foldable) +#endif +import Control.Monad.Identity +import Control.Monad.State +import Control.Monad.Trans.Maybe +import qualified Data.Foldable as Foldable +import Data.Map (Map) +import qualified Data.List as List +import qualified Data.Map as Map +import Data.Set (Set) +import qualified Data.Set as Set +import qualified Data.Text as Text +import Control.Monad.Trans.Writer.Strict +import Numeric.Natural + + +import Verifier.SAW.Cache +import Verifier.SAW.Conversion +import qualified Verifier.SAW.Recognizer as R +import Verifier.SAW.SharedTerm +import Verifier.SAW.Term.Functor +import Verifier.SAW.TypedAST +import qualified Verifier.SAW.TermNet as Net + +data RewriteRule + = RewriteRule { ctxt :: [Term], lhs :: Term, rhs :: Term, permutative :: Bool } + deriving (Eq, Show) +-- ^ Invariant: The set of loose variables in @lhs@ must be exactly +-- @[0 .. length ctxt - 1]@. The @rhs@ may contain a subset of these. + +ctxtRewriteRule :: RewriteRule -> [Term] +ctxtRewriteRule = ctxt + +lhsRewriteRule :: RewriteRule -> Term +lhsRewriteRule = lhs + +rhsRewriteRule :: RewriteRule -> Term +rhsRewriteRule = rhs + +instance Net.Pattern RewriteRule where + toPat (RewriteRule _ lhs _ _) = Net.toPat lhs + +---------------------------------------------------------------------- +-- Matching + +data MatchState = + MatchState + { substitution :: Map DeBruijnIndex Term + , constraints :: [(Term, Natural)] + } + +emptyMatchState :: MatchState +emptyMatchState = MatchState { substitution = Map.empty, constraints = [] } + + +-- First-order matching + +-- | Equivalent to @(lookup k t, insert k x t)@. +insertLookup :: Ord k => k -> a -> Map k a -> (Maybe a, Map k a) +insertLookup k x t = Map.insertLookupWithKey (\_ a _ -> a) k x t + +first_order_match :: Term -> Term -> Maybe (Map DeBruijnIndex Term) +first_order_match pat term = match pat term Map.empty + where + match x y m = + case (unwrapTermF x, unwrapTermF y) of + (LocalVar i, _) -> + case my' of + Nothing -> Just m' + Just y' -> if alphaEquiv y y' then Just m' else Nothing + where (my', m') = insertLookup i y m + (App x1 x2, App y1 y2) -> + match x1 y1 m >>= match x2 y2 + (FTermF xf, FTermF yf) -> + do zf <- zipWithFlatTermF match xf yf + Foldable.foldl (>=>) Just zf m + (_, _) -> + if alphaEquiv x y then Just m else Nothing +-- ^ Precondition: Every loose variable in the pattern @pat@ must +-- occur as the 2nd argument of an @App@ constructor. This ensures +-- that instantiations are well-typed. + +asConstantNat :: Term -> Maybe Natural +asConstantNat t = + case R.asCtor t of + Just (i, []) | i == "Prelude.Zero" -> Just 0 + Just (i, [x]) | i == "Prelude.Succ" -> (+ 1) <$> asConstantNat x + _ -> + do let (f, xs) = R.asApplyAll t + i <- R.asGlobalDef f + case xs of + [x, y] + | i == "Prelude.addNat" -> (+) <$> asConstantNat x <*> asConstantNat y + | i == "Prelude.mulNat" -> (*) <$> asConstantNat x <*> asConstantNat y + | i == "Prelude.expNat" -> (^) <$> asConstantNat x <*> asConstantNat y + | i == "Prelude.subNat" -> + do x' <- asConstantNat x + y' <- asConstantNat y + guard (x' >= y') + return (x' - y') + | i == "Prelude.divNat" -> + do x' <- asConstantNat x + y' <- asConstantNat y + guard (y' > 0) + return (x' `div` y') + | i == "Prelude.remNat" -> + do x' <- asConstantNat x + y' <- asConstantNat y + guard (y' > 0) + return (x' `rem` y') + _ -> Nothing + +-- | An enhanced matcher that can handle higher-order patterns. +scMatch :: + SharedContext -> + Term {- ^ pattern -} -> + Term {- ^ term -} -> + IO (Maybe (Map DeBruijnIndex Term)) +scMatch sc pat term = + runMaybeT $ + do --lift $ putStrLn $ "********** scMatch **********" + MatchState inst cs <- match 0 [] pat term emptyMatchState + mapM_ (check inst) cs + return inst + where + check :: Map DeBruijnIndex Term -> (Term, Natural) -> MaybeT IO () + check inst (t, n) = do + --lift $ putStrLn $ "checking: " ++ show (t, n) + -- apply substitution to the term + t' <- lift $ instantiateVarList sc 0 (Map.elems inst) t + --lift $ putStrLn $ "t': " ++ show t' + -- constant-fold nat operations + -- ensure that it evaluates to the same number + case asConstantNat t' of + Just i | i == n -> return () + _ -> mzero + + asVarPat :: Int -> Term -> Maybe (DeBruijnIndex, [DeBruijnIndex]) + asVarPat depth = go [] + where + go js x = + case unwrapTermF x of + LocalVar i + | i >= depth -> Just (i, js) + | otherwise -> Nothing + App t (unwrapTermF -> LocalVar j) + | j < depth -> go (j : js) t + _ -> Nothing + + match :: Int -> [(LocalName, Term)] -> Term -> Term -> MatchState -> MaybeT IO MatchState + match _ _ (STApp i fv _) (STApp j _ _) s + | fv == emptyBitSet && i == j = return s + match depth env x y s@(MatchState m cs) = + --do + --lift $ putStrLn $ "matching (lhs): " ++ scPrettyTerm defaultPPOpts x + --lift $ putStrLn $ "matching (rhs): " ++ scPrettyTerm defaultPPOpts y + case asVarPat depth x of + Just (i, js) -> + do -- ensure parameter variables are distinct + guard (Set.size (Set.fromList js) == length js) + -- ensure y mentions only variables that are in js + let fvj = foldl unionBitSets emptyBitSet (map singletonBitSet js) + let fvy = looseVars y `intersectBitSets` (completeBitSet depth) + guard (fvy `unionBitSets` fvj == fvj) + let fixVar t (nm, ty) = + do v <- scFreshGlobal sc (Text.unpack nm) ty + let Just ec = R.asExtCns v + t' <- instantiateVar sc 0 v t + return (t', ec) + let fixVars t [] = return (t, []) + fixVars t (ty : tys) = + do (t', ec) <- fixVar t ty + (t'', ecs) <- fixVars t' tys + return (t'', ec : ecs) + -- replace local bound variables with global ones + -- this also decrements loose variables in y by `depth` + (y1, ecs) <- lift $ fixVars y env + -- replace global variables with reindexed bound vars + -- y2 should have no more of the newly-created ExtCns vars + y2 <- lift $ scAbstractExts sc [ ecs !! j | j <- js ] y1 + let (my3, m') = insertLookup (i - depth) y2 m + case my3 of + Nothing -> return (MatchState m' cs) + Just y3 -> if y2 == y3 then return (MatchState m' cs) else mzero + Nothing -> + case (unwrapTermF x, unwrapTermF y) of + -- check that neither x nor y contains bound variables less than `depth` + (FTermF xf, FTermF yf) -> + case zipWithFlatTermF (match depth env) xf yf of + Nothing -> mzero + Just zf -> Foldable.foldl (>=>) return zf s + (App x1 x2, App y1 y2) -> + match depth env x1 y1 s >>= match depth env x2 y2 + (Lambda _ t1 x1, Lambda nm t2 x2) -> + match depth env t1 t2 s >>= match (depth + 1) ((nm, t2) : env) x1 x2 + (Pi _ t1 x1, Pi nm t2 x2) -> + match depth env t1 t2 s >>= match (depth + 1) ((nm, t2) : env) x1 x2 + (App _ _, FTermF (NatLit n)) -> + -- add deferred constraint + return (MatchState m ((x, n) : cs)) + (_, _) -> + -- other possible matches are local vars and constants + if x == y then return s else mzero + +---------------------------------------------------------------------- +-- Building rewrite rules + +eqIdent :: Ident +eqIdent = mkIdent (mkModuleName ["Prelude"]) "Eq" + +ecEqIdent :: Ident +ecEqIdent = mkIdent (mkModuleName ["Cryptol"]) "ecEq" + +bvEqIdent :: Ident +bvEqIdent = mkIdent (mkModuleName ["Prelude"]) "bvEq" + +boolEqIdent :: Ident +boolEqIdent = mkIdent (mkModuleName ["Prelude"]) "boolEq" + +vecEqIdent :: Ident +vecEqIdent = mkIdent (mkModuleName ["Prelude"]) "vecEq" + +equalNatIdent :: Ident +equalNatIdent = mkIdent (mkModuleName ["Prelude"]) "equalNat" + +-- | Converts a universally quantified equality proposition from a +-- Term representation to a RewriteRule. +ruleOfTerm :: Term -> RewriteRule +ruleOfTerm t = + case unwrapTermF t of + -- NOTE: this assumes the Coq-style equality type Eq X x y, where both X + -- (the type of x and y) and x are parameters, and y is an index + FTermF (DataTypeApp ident [_, x] [y]) + | ident == eqIdent -> mkRewriteRule [] x y + Pi _ ty body -> rule { ctxt = ty : ctxt rule } + where rule = ruleOfTerm body + _ -> error "ruleOfSharedTerm: Illegal argument" + +-- Test whether a rewrite rule is permutative +-- this is a rule that immediately loops whether used forwards or backwards. +rulePermutes :: Term -> Term -> Bool +rulePermutes lhs rhs = + case first_order_match lhs rhs of + Nothing -> False -- rhs is not an instance of lhs + Just _ -> + case first_order_match rhs lhs of + Nothing -> False -- but here we have a looping rule, not good! + Just _ -> True + +mkRewriteRule :: [Term] -> Term -> Term -> RewriteRule +mkRewriteRule c l r = + RewriteRule {ctxt = c, lhs = l, rhs = r , permutative = rulePermutes l r} + +-- | Converts a universally quantified equality proposition between the +-- two given terms to a RewriteRule. +ruleOfTerms :: Term -> Term -> RewriteRule +ruleOfTerms l r = mkRewriteRule [] l r + +-- | Converts a parameterized equality predicate to a RewriteRule, +-- returning 'Nothing' if the predicate is not an equation. +ruleOfProp :: Term -> Maybe RewriteRule +ruleOfProp (R.asPi -> Just (_, ty, body)) = + do rule <- ruleOfProp body + Just rule { ctxt = ty : ctxt rule } +ruleOfProp (R.asLambda -> Just (_, ty, body)) = + do rule <- ruleOfProp body + Just rule { ctxt = ty : ctxt rule } +ruleOfProp (R.asApplyAll -> (R.isGlobalDef ecEqIdent -> Just (), [_, _, x, y])) = + Just $ mkRewriteRule [] x y +ruleOfProp (R.asApplyAll -> (R.isGlobalDef bvEqIdent -> Just (), [_, x, y])) = + Just $ mkRewriteRule [] x y +ruleOfProp (R.asApplyAll -> (R.isGlobalDef equalNatIdent -> Just (), [x, y])) = + Just $ mkRewriteRule [] x y +ruleOfProp (R.asApplyAll -> (R.isGlobalDef boolEqIdent -> Just (), [x, y])) = + Just $ mkRewriteRule [] x y +ruleOfProp (R.asApplyAll -> (R.isGlobalDef vecEqIdent -> Just (), [_, _, _, x, y])) = + Just $ mkRewriteRule [] x y +ruleOfProp (unwrapTermF -> Constant _ body) = ruleOfProp body +ruleOfProp (R.asEq -> Just (_, x, y)) = + Just $ mkRewriteRule [] x y +ruleOfProp (R.asEqTrue -> Just body) = ruleOfProp body +ruleOfProp _ = Nothing + +-- | Generate a rewrite rule from the type of an identifier, using 'ruleOfTerm' +scEqRewriteRule :: SharedContext -> Ident -> IO RewriteRule +scEqRewriteRule sc i = ruleOfTerm <$> scTypeOfGlobal sc i + +-- | Collects rewrite rules from named constants, whose types must be equations. +scEqsRewriteRules :: SharedContext -> [Ident] -> IO [RewriteRule] +scEqsRewriteRules sc = mapM (scEqRewriteRule sc) + +-- | Transform the given rewrite rule to a set of one or more +-- equivalent rewrite rules, if possible. +-- +-- * If the rhs is a lambda, then add an argument to the lhs. +-- * If the rhs is a recursor, then split into a separate rule for each constructor. +-- * If the rhs is a record, then split into a separate rule for each accessor. +scExpandRewriteRule :: SharedContext -> RewriteRule -> IO (Maybe [RewriteRule]) +scExpandRewriteRule sc (RewriteRule ctxt lhs rhs _) = + case rhs of + (R.asLambda -> Just (_, ty, body)) -> + do let ctxt' = ctxt ++ [ty] + lhs1 <- incVars sc 0 1 lhs + var0 <- scLocalVar sc 0 + lhs' <- scApply sc lhs1 var0 + return $ Just [mkRewriteRule ctxt' lhs' body] + (R.asRecordValue -> Just m) -> + do let mkRule (k, x) = + do l <- scRecordSelect sc lhs k + return (mkRewriteRule ctxt l x) + Just <$> traverse mkRule (Map.assocs m) + (R.asApplyAll -> + (R.asRecursorApp -> Just (d, params, p_ret, cs_fs, _ixs, R.asLocalVar -> Just i), + more)) -> + do let ctxt1 = reverse (drop (i+1) (reverse ctxt)) + let ctxt2 = reverse (take i (reverse ctxt)) + -- The type @ti@ is in the de Bruijn context @ctxt1@. + ti <- scWhnf sc (reverse ctxt !! i) + -- The datatype parameters are also in context @ctxt1@. + (_d, params1, _ixs) <- maybe (fail "expected DataTypeApp") return (R.asDataTypeParams ti) + let ctorRule ctor = + do -- Compute the argument types @argTs@ in context @ctxt1@. + ctorT <- piAppType (ctorType ctor) params1 + let argTs = map snd (fst (R.asPiList ctorT)) + let nargs = length argTs + -- Build a fully-applied constructor @c@ in context @ctxt1 ++ argTs@. + params2 <- traverse (incVars sc 0 nargs) params1 + args <- traverse (scLocalVar sc) (reverse (take nargs [0..])) + c <- scCtorAppParams sc (ctorName ctor) params2 args + -- Build the list of types of the new context. + let ctxt' = ctxt1 ++ argTs ++ ctxt2 + -- Define function to adjust indices on a term from + -- context @ctxt@ into context @ctxt'@. We also + -- substitute the constructor @c@ in for the old + -- local variable @i@. + let adjust t = instantiateVar sc i c =<< incVars sc (i+1) nargs t + -- Adjust the indices and substitute the new + -- constructor value to make the new params, lhs, + -- and rhs in context @ctxt'@. + params' <- traverse adjust params + lhs' <- adjust lhs + p_ret' <- adjust p_ret + cs_fs' <- traverse (traverse adjust) cs_fs + args' <- traverse (incVars sc 0 i) args + more' <- traverse adjust more + let cn = ctorName ctor + rhs1 <- scReduceRecursor sc d params' p_ret' cs_fs' cn args' + rhs2 <- scApplyAll sc rhs1 more' + rhs3 <- betaReduce rhs2 + -- re-fold recursive occurrences of the original rhs + let ss = addRule (mkRewriteRule ctxt rhs lhs) emptySimpset + rhs' <- rewriteSharedTerm sc ss rhs3 + return (mkRewriteRule ctxt' lhs' rhs') + dt <- scRequireDataType sc d + rules <- traverse ctorRule (dtCtors dt) + return (Just rules) + _ -> return Nothing + where + piAppType :: Term -> [Term] -> IO Term + piAppType funtype [] = return funtype + piAppType funtype (arg : args) = + do (_, _, body) <- maybe (fail "expected Pi type") return (R.asPi funtype) + funtype' <- instantiateVar sc 0 arg body + piAppType funtype' args + + betaReduce :: Term -> IO Term + betaReduce t = + case R.asApp t of + Nothing -> return t + Just (f, arg) -> + do f' <- betaReduce f + case R.asLambda f' of + Nothing -> scApply sc f' arg + Just (_, _, body) -> instantiateVar sc 0 arg body + +-- | Repeatedly apply the rule transformations in 'scExpandRewriteRule'. +scExpandRewriteRules :: SharedContext -> [RewriteRule] -> IO [RewriteRule] +scExpandRewriteRules sc rs = + case rs of + [] -> return [] + r : rs2 -> + do m <- scExpandRewriteRule sc r + case m of + Nothing -> (r :) <$> scExpandRewriteRules sc rs2 + Just rs1 -> scExpandRewriteRules sc (rs1 ++ rs2) + +-- | Create a rewrite rule for a definition that expands the definition, if it +-- has a body to expand to, otherwise return the empty list +scDefRewriteRules :: SharedContext -> Def -> IO [RewriteRule] +scDefRewriteRules _ (Def { defBody = Nothing }) = return [] +scDefRewriteRules sc (Def { defIdent = ident, defBody = Just body }) = + do lhs <- scGlobalDef sc ident + rhs <- scSharedTerm sc body + scExpandRewriteRules sc [mkRewriteRule [] lhs rhs] + + +---------------------------------------------------------------------- +-- Simpsets + +-- | Invariant: 'Simpset's should not contain reflexive rules. We avoid +-- adding them in 'addRule' below. +type Simpset = Net.Net (Either RewriteRule Conversion) + +emptySimpset :: Simpset +emptySimpset = Net.empty + +addRule :: RewriteRule -> Simpset -> Simpset +addRule rule | lhs rule /= rhs rule = Net.insert_term (lhs rule, Left rule) + | otherwise = id + +delRule :: RewriteRule -> Simpset -> Simpset +delRule rule = Net.delete_term (lhs rule, Left rule) + +addRules :: [RewriteRule] -> Simpset -> Simpset +addRules rules ss = foldr addRule ss rules + +addSimp :: Term -> Simpset -> Simpset +addSimp prop = addRule (ruleOfTerm prop) + +delSimp :: Term -> Simpset -> Simpset +delSimp prop = delRule (ruleOfTerm prop) + +addConv :: Conversion -> Simpset -> Simpset +addConv conv = Net.insert_term (conv, Right conv) + +addConvs :: [Conversion] -> Simpset -> Simpset +addConvs convs ss = foldr addConv ss convs + +scSimpset :: SharedContext -> [Def] -> [Ident] -> [Conversion] -> IO Simpset +scSimpset sc defs eqIdents convs = do + defRules <- concat <$> traverse (scDefRewriteRules sc) defs + eqRules <- mapM (scEqRewriteRule sc) eqIdents + return $ addRules defRules $ addRules eqRules $ addConvs convs $ emptySimpset + +listRules :: Simpset -> [RewriteRule] +listRules ss = [ r | Left r <- Net.content ss ] + +---------------------------------------------------------------------- +-- Destructors for terms + +asBetaRedex :: R.Recognizer Term (LocalName, Term, Term, Term) +asBetaRedex t = + do (f, arg) <- R.asApp t + (s, ty, body) <- R.asLambda f + return (s, ty, body, arg) + +asPairRedex :: R.Recognizer Term Term +asPairRedex t = + do (u, b) <- R.asPairSelector t + (x, y) <- R.asPairValue u + return (if b then y else x) + +asRecordRedex :: R.Recognizer Term Term +asRecordRedex t = + do (x, i) <- R.asRecordSelector t + ts <- R.asRecordValue x + case Map.lookup i ts of + Just t' -> return t' + Nothing -> fail "Record field not found" + +-- | An iota redex is a recursor application whose main argument is a +-- constructor application; specifically, this function recognizes +-- +-- > RecursorApp d params p_ret cs_fs _ (CtorApp c _ args) +asIotaRedex :: R.Recognizer Term (Ident, [Term], Term, [(Ident, Term)], Ident, [Term]) +asIotaRedex t = + do (d, params, p_ret, cs_fs, _, arg) <- R.asRecursorApp t + (c, _, args) <- asCtorOrNat arg + return (d, params, p_ret, cs_fs, c, args) + + +---------------------------------------------------------------------- +-- Bottom-up rewriting + +-- | Term ordering +-- The existing "<" on terms is not adequate for deciding how to handle permutative rules, +-- as then associativity and commutativity can loop. +-- The following rather unsophisticated functions *might* prevent looping. +-- More analysis is needed! +-- +-- here we get the "fringe" of arguments in an application, looking at either curried or +-- tupled arguments. That is +-- for `f x y z`, return [x,y,z] +-- for `f (x,y)` return [x,y] +-- for `f (f x y) z`, return [x,y,z] +-- for `f (x, f (y,z))`, return [x,y,z] +appCollectedArgs :: Term -> [Term] +appCollectedArgs t = step0 (unshared t) [] + where + unshared (STApp{stAppIndex = _, stAppTermF = tf1}) = tf1 + unshared (Unshared tf1) = tf1 + -- step 0: accumulate curried args, find the function + step0 :: TermF Term -> [Term] -> [Term] + step0 (App f a) args = step0 (unshared f) (a:args) + step0 other args = step1 other args + -- step 1: analyse each arg, knowing the called function, append together + step1 :: TermF Term -> [Term] -> [Term] + step1 f args = foldl (++) [] (map (\ x -> step2 f $ unshared x) args) + -- step2: analyse an arg. look inside tuples, sequences (TBD), more calls to f + step2 :: TermF Term -> TermF Term -> [Term] + step2 f (FTermF (PairValue x y)) = (step2 f $ unshared x) ++ (step2 f $ unshared y) + step2 f (s@(App g a)) = possibly_curried_args s f (unshared g) (step2 f $ unshared a) + step2 _ a = [Unshared a] + -- + possibly_curried_args :: TermF Term -> TermF Term -> TermF Term -> [Term] -> [Term] + possibly_curried_args s f (App g a) args = possibly_curried_args s f (unshared g) ((step2 f $ unshared a) ++ args) + possibly_curried_args s f h args = if f == h then args else [Unshared s] + + +termWeightLt :: Term -> Term -> Bool +termWeightLt t t' = + (appCollectedArgs t) < (appCollectedArgs t') + +-- | Do a single reduction step (beta, record or tuple selector) at top +-- level, if possible. +reduceSharedTerm :: SharedContext -> Term -> Maybe (IO Term) +reduceSharedTerm sc (asBetaRedex -> Just (_, _, body, arg)) = Just (instantiateVar sc 0 arg body) +reduceSharedTerm _ (asPairRedex -> Just t) = Just (return t) +reduceSharedTerm _ (asRecordRedex -> Just t) = Just (return t) +reduceSharedTerm sc (asIotaRedex -> Just (d, params, p_ret, cs_fs, c, args)) = + Just $ scReduceRecursor sc d params p_ret cs_fs c args +reduceSharedTerm _ _ = Nothing + +-- | Rewriter for shared terms +rewriteSharedTerm :: SharedContext -> Simpset -> Term -> IO Term +rewriteSharedTerm sc ss t0 = + do cache <- newCache + let ?cache = cache in rewriteAll t0 + where + rewriteAll :: (?cache :: Cache IO TermIndex Term) => Term -> IO Term + rewriteAll (Unshared tf) = + traverseTF rewriteAll tf >>= scTermF sc >>= rewriteTop + rewriteAll STApp{ stAppIndex = tidx, stAppTermF = tf } = + useCache ?cache tidx (traverseTF rewriteAll tf >>= scTermF sc >>= rewriteTop) + traverseTF :: (a -> IO a) -> TermF a -> IO (TermF a) + traverseTF _ tf@(Constant {}) = pure tf + traverseTF f tf = traverse f tf + rewriteTop :: (?cache :: Cache IO TermIndex Term) => Term -> IO Term + rewriteTop t = + case reduceSharedTerm sc t of + Nothing -> apply (Net.unify_term ss t) t + Just io -> rewriteAll =<< io + apply :: (?cache :: Cache IO TermIndex Term) => + [Either RewriteRule Conversion] -> Term -> IO Term + apply [] t = return t + apply (Left (RewriteRule {ctxt, lhs, rhs, permutative}) : rules) t = do + result <- scMatch sc lhs t + case result of + Nothing -> apply rules t + Just inst + | lhs == rhs -> + -- This should never happen because we avoid inserting + -- reflexive rules into simp sets in the first place. + do putStrLn $ "rewriteSharedTerm: skipping reflexive rule " ++ + "(THE IMPOSSIBLE HAPPENED!): " ++ scPrettyTerm defaultPPOpts lhs + apply rules t + | Map.keys inst /= take (length ctxt) [0 ..] -> + do putStrLn $ "rewriteSharedTerm: invalid lhs does not contain all variables: " + ++ scPrettyTerm defaultPPOpts lhs + apply rules t + | permutative -> + do + t' <- instantiateVarList sc 0 (Map.elems inst) rhs + case termWeightLt t' t of + True -> rewriteAll t' -- keep the result only if it is "smaller" + False -> apply rules t + | otherwise -> + do -- putStrLn "REWRITING:" + -- print lhs + rewriteAll =<< instantiateVarList sc 0 (Map.elems inst) rhs + apply (Right conv : rules) t = + do -- putStrLn "REWRITING:" + -- print (Net.toPat conv) + case runConversion conv t of + Nothing -> apply rules t + Just tb -> rewriteAll =<< runTermBuilder tb (scGlobalDef sc) (scTermF sc) + +-- | Type-safe rewriter for shared terms +rewriteSharedTermTypeSafe + :: SharedContext -> Simpset -> Term -> IO Term +rewriteSharedTermTypeSafe sc ss t0 = + do cache <- newCache + let ?cache = cache in rewriteAll t0 + where + rewriteAll :: (?cache :: Cache IO TermIndex Term) => + Term -> IO Term + rewriteAll (Unshared tf) = + rewriteTermF tf >>= scTermF sc >>= rewriteTop + rewriteAll STApp{ stAppIndex = tidx, stAppTermF = tf } = + -- putStrLn "Rewriting term:" >> print t >> + useCache ?cache tidx (rewriteTermF tf >>= scTermF sc >>= rewriteTop) + rewriteTermF :: (?cache :: Cache IO TermIndex Term) => + TermF Term -> IO (TermF Term) + rewriteTermF tf = + case tf of + FTermF ftf -> FTermF <$> rewriteFTermF ftf + App e1 e2 -> + do t1 <- scTypeOf sc e1 + case unwrapTermF t1 of + -- We only rewrite e2 if type of e1 is not a dependent type. + -- This prevents rewriting e2 from changing type of @App e1 e2@. + Pi _ _ t | inBitSet 0 (looseVars t) -> App <$> rewriteAll e1 <*> rewriteAll e2 + _ -> App <$> rewriteAll e1 <*> pure e2 + Lambda pat t e -> Lambda pat t <$> rewriteAll e + Constant{} -> return tf + _ -> return tf -- traverse rewriteAll tf + rewriteFTermF :: (?cache :: Cache IO TermIndex Term) => + FlatTermF Term -> IO (FlatTermF Term) + rewriteFTermF ftf = + case ftf of + UnitValue -> return ftf + UnitType -> return ftf + PairValue{} -> traverse rewriteAll ftf + PairType{} -> return ftf -- doesn't matter + PairLeft{} -> traverse rewriteAll ftf + PairRight{} -> traverse rewriteAll ftf + + -- NOTE: we don't rewrite arguments of constructors, datatypes, or + -- recursors because of dependent types, as we could potentially cause + -- a term to become ill-typed + CtorApp{} -> return ftf + DataTypeApp{} -> return ftf -- could treat same as CtorApp + RecursorApp{} -> return ftf -- could treat same as CtorApp + + RecordType{} -> traverse rewriteAll ftf + RecordValue{} -> traverse rewriteAll ftf + RecordProj{} -> traverse rewriteAll ftf + Sort{} -> return ftf -- doesn't matter + NatLit{} -> return ftf -- doesn't matter + ArrayValue t es -> ArrayValue t <$> traverse rewriteAll es + Primitive{} -> return ftf + StringLit{} -> return ftf + ExtCns{} -> return ftf + rewriteTop :: (?cache :: Cache IO TermIndex Term) => + Term -> IO Term + rewriteTop t = apply (Net.match_term ss t) t + apply :: (?cache :: Cache IO TermIndex Term) => + [Either RewriteRule Conversion] -> + Term -> IO Term + apply [] t = return t + apply (Left rule : rules) t = + case first_order_match (lhs rule) t of + Nothing -> apply rules t + Just inst -> rewriteAll =<< instantiateVarList sc 0 (Map.elems inst) (rhs rule) + apply (Right conv : rules) t = + case runConversion conv t of + Nothing -> apply rules t + Just tb -> rewriteAll =<< runTermBuilder tb (scGlobalDef sc) (scTermF sc) + +-- | Generate a new SharedContext that normalizes terms as it builds them. +rewritingSharedContext :: SharedContext -> Simpset -> SharedContext +rewritingSharedContext sc ss = sc' + where + sc' = sc { scTermF = rewriteTop } + + rewriteTop :: TermF Term -> IO Term + rewriteTop tf = + case asPairRedex t of + Just t' -> return t' + Nothing -> + case asRecordRedex t of + Just t' -> return t' + Nothing -> apply (Net.match_term ss t) t + where t = Unshared tf + + apply :: [Either RewriteRule Conversion] -> + Term -> IO Term + apply [] (Unshared tf) = scTermF sc tf + apply [] STApp{ stAppTermF = tf } = scTermF sc tf + apply (Left (RewriteRule _ l r _) : rules) t = + case first_order_match l t of + Nothing -> apply rules t + Just inst + | l == r -> + do putStrLn $ "rewritingSharedContext: skipping reflexive rule: " ++ scPrettyTerm defaultPPOpts l + apply rules t + | otherwise -> instantiateVarList sc' 0 (Map.elems inst) r + apply (Right conv : rules) t = + case runConversion conv t of + Nothing -> apply rules t + Just tb -> runTermBuilder tb (scGlobalDef sc) (scTermF sc') + + +-- FIXME: is there some way to have sensable term replacement in the presence of loose variables +-- and/or under binders? +replaceTerm :: SharedContext + -> Simpset -- ^ A simpset of rewrite rules to apply along with the replacement + -> (Term, Term) -- ^ (pat,repl) is a tuple of a pattern term to replace and a replacement term + -> Term -- ^ the term in which to perform the replacement + -> IO Term +replaceTerm sc ss (pat, repl) t = do + let fvs = looseVars pat + unless (fvs == emptyBitSet) $ fail $ unwords + [ "replaceTerm: term to replace has free variables!", scPrettyTerm defaultPPOpts t ] + let rule = ruleOfTerms pat repl + let ss' = addRule rule ss + rewriteSharedTerm sc ss' t + + +------------------------------------------------------------------------------- +-- If/then/else hoisting + +-- | Find all instances of Prelude.ite in the given term and hoist them +-- higher. An if-then-else floats upward until it hits a binder that +-- binds one of its free variables, or until it bubbles to the top of +-- the term. When multiple if-then-else branches bubble to the same +-- place, they will be nested via a canonical term ordering. This transformation +-- also does rewrites by basic boolean identities. +hoistIfs :: SharedContext + -> Term + -> IO Term +hoistIfs sc t = do + cache <- newCache + + let app x y = join (scTermF sc <$> (pure App <*> x <*> y)) + itePat <- + (scGlobalDef sc "Prelude.ite") + `app` + (scLocalVar sc 0) + `app` + (scLocalVar sc 1) + `app` + (scLocalVar sc 2) + `app` + (scLocalVar sc 3) + + rules <- map ruleOfTerm <$> mapM (scTypeOfGlobal sc) + [ "Prelude.ite_true" + , "Prelude.ite_false" + , "Prelude.ite_not" + , "Prelude.ite_nest1" + , "Prelude.ite_nest2" + , "Prelude.ite_eq" + , "Prelude.ite_bit_false_1" + , "Prelude.ite_bit_true_1" + , "Prelude.ite_bit" + , "Prelude.not_not" + , "Prelude.and_True1" + , "Prelude.and_False1" + , "Prelude.and_True2" + , "Prelude.and_False2" + , "Prelude.and_idem" + , "Prelude.or_True1" + , "Prelude.or_False1" + , "Prelude.or_True2" + , "Prelude.or_False2" + , "Prelude.or_idem" + , "Prelude.not_or" + , "Prelude.not_and" + ] + let ss = addRules rules emptySimpset + + (t', conds) <- doHoistIfs sc ss cache itePat =<< rewriteSharedTerm sc ss t + splitConds sc ss (map fst conds) t' + + +splitConds :: SharedContext -> Simpset -> [Term] -> Term -> IO Term +splitConds _ _ [] = return +splitConds sc ss (c:cs) = splitCond sc ss c >=> splitConds sc ss cs + +splitCond :: SharedContext -> Simpset -> Term -> Term -> IO Term +splitCond sc ss c t = do + ty <- scTypeOf sc t + trueTerm <- scBool sc True + falseTerm <- scBool sc False + + then_branch <- replaceTerm sc ss (c, trueTerm) t + else_branch <- replaceTerm sc ss (c, falseTerm) t + scGlobalApply sc "Prelude.ite" [ty, c, then_branch, else_branch] + +type HoistIfs s = (Term, [(Term, Set (ExtCns Term))]) + + +orderTerms :: SharedContext -> [Term] -> IO [Term] +orderTerms _sc xs = return $ List.sort xs + +doHoistIfs :: SharedContext + -> Simpset + -> Cache IO TermIndex (HoistIfs s) + -> Term + -> Term + -> IO (HoistIfs s) +doHoistIfs sc ss hoistCache itePat = go + + where go :: Term -> IO (HoistIfs s) + go t@(STApp{ stAppIndex = idx, stAppTermF = tf}) = useCache hoistCache idx $ top t tf + go t@(Unshared tf) = top t tf + + top :: Term -> TermF Term -> IO (HoistIfs s) + top t tf + | Just inst <- first_order_match itePat t = do + let Just branch_tp = Map.lookup 0 inst + let Just cond = Map.lookup 1 inst + let Just then_branch = Map.lookup 2 inst + let Just else_branch = Map.lookup 3 inst + + (then_branch',conds1) <- go then_branch + (else_branch',conds2) <- go else_branch + + t' <- scGlobalApply sc "Prelude.ite" [branch_tp, cond, then_branch', else_branch'] + let ecs = getAllExtSet cond + return (t', (cond, ecs) : conds1 ++ conds2) + + | otherwise = goF t tf + + goF :: Term -> TermF Term -> IO (HoistIfs s) + + goF t (LocalVar _) = return (t, []) + goF t (Constant {}) = return (t, []) + + goF _ (FTermF ftf) = do + (ftf', conds) <- runWriterT $ traverse WriterT $ (fmap go ftf) + t' <- scFlatTermF sc ftf' + return (t', conds) + + goF _ (App f x) = do + (f', conds1) <- go f + (x', conds2) <- go x + t' <- scApply sc f' x' + return (t', conds1 ++ conds2) + + goF _ (Lambda nm tp body) = goBinder scLambda nm tp body + goF _ (Pi nm tp body) = goBinder scPi nm tp body + + goBinder close nm tp body = do + (ec, body') <- scOpenTerm sc (Text.unpack nm) tp 0 body + (body'', conds) <- go body' + let (stuck, float) = List.partition (\(_,ecs) -> Set.member ec ecs) conds + + stuck' <- orderTerms sc (map fst stuck) + body''' <- splitConds sc ss stuck' body'' + + t' <- scCloseTerm close sc ec body''' + return (t', float) diff --git a/saw-core/src/Verifier/SAW/SATQuery.hs b/saw-core/src/Verifier/SAW/SATQuery.hs new file mode 100644 index 0000000000..dea328a621 --- /dev/null +++ b/saw-core/src/Verifier/SAW/SATQuery.hs @@ -0,0 +1,68 @@ +module Verifier.SAW.SATQuery +( SATQuery(..) +, SATResult(..) +, satQueryAsTerm +) where + +import Control.Monad (foldM) +import Data.Map (Map) +import Data.Set (Set) + +import Verifier.SAW.Name +import Verifier.SAW.FiniteValue +import Verifier.SAW.SharedTerm + +-- | This datatype represents a satisfiability query that might +-- be dispatched to a solver. It carries a series of assertions +-- to be made to a solver, together with a collection of +-- variables we expect the solver to report models over, +-- and a collection of @VarIndex@ values identifying +-- subterms that should be considered uninterpreted. +-- +-- All the @ExtCns@ values in the query should +-- appear either in @satVariables@ or @satUninterp@. +-- Constant values for which definitions are provided +-- may also appear in @satUninterp@, in which case +-- they will be treated as uninterpreted. Otherwise, +-- their definitions will be unfolded. +-- +-- Solve solvers do not support uninterpreted values +-- and will fail if presented a query that requests them. +data SATQuery = + SATQuery + { satVariables :: Map (ExtCns Term) FirstOrderType + -- ^ The variables in the query, for which we + -- expect the solver to find values in satisfiable + -- cases. INVARIANT: The type of the @ExtCns@ keys + -- should correspond to the @FirstOrderType@ values. + + , satUninterp :: Set VarIndex + -- ^ A set indicating which variables and constant + -- values should be considered uninterpreted by + -- the solver. Models will not report values + -- for uninterpreted values. + + , satAsserts :: [Term] + -- ^ A collection of assertions. These should + -- all be terms of type @Bool@. The overall + -- query should be understood as the conjunction + -- of these terms. + } +-- TODO, allow first-order propositions in addition to Boolean terms. + +-- | The result of a sat query. In the event a model is found, +-- return a mapping from the @ExtCns@ variables to values. +data SATResult + = Unsatisfiable + | Satisfiable (ExtCns Term -> IO FirstOrderValue) + | Unknown + +-- | Compute the conjunction of all the assertions +-- in this SAT query as a single term of type Bool. +satQueryAsTerm :: SharedContext -> SATQuery -> IO Term +satQueryAsTerm sc satq = + case satAsserts satq of + [] -> scBool sc True + (x:xs) -> foldM (scAnd sc) x xs +-- TODO, we may have to rethink this function +-- once we allow first-order statements. diff --git a/saw-core/src/Verifier/SAW/SCTypeCheck.hs b/saw-core/src/Verifier/SAW/SCTypeCheck.hs new file mode 100644 index 0000000000..029e5eca68 --- /dev/null +++ b/saw-core/src/Verifier/SAW/SCTypeCheck.hs @@ -0,0 +1,619 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE FlexibleContexts, FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} + +{- | +Module : Verifier.SAW.SCTypeCheck +Copyright : Galois, Inc. 2012-2015 +License : BSD3 +Maintainer : jhendrix@galois.com +Stability : experimental +Portability : non-portable (language extensions) +-} + +module Verifier.SAW.SCTypeCheck + ( scTypeCheck + , scTypeCheckError + , scTypeCheckComplete + , scTypeCheckCompleteError + , scTypeCheckWHNF + , scConvertible + , scCheckSubtype + , TCError(..) + , prettyTCError + , throwTCError + , TCM + , runTCM + , askCtx + , askModName + , withVar + , withCtx + , atPos + , LiftTCM(..) + , TypedTerm(..) + , TypeInfer(..) + , typeCheckWHNF + , typeInferCompleteWHNF + , TypeInferCtx(..) + , typeInferCompleteInCtx + , checkSubtype + , ensureSort + , applyPiTyped + ) where + +import Control.Applicative +import Control.Monad.Except +import Control.Monad.State.Strict +import Control.Monad.Reader + +import Data.List ( (\\) ) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Text (Text) +#if !MIN_VERSION_base(4,8,0) +import Data.Traversable (Traversable(..)) +#endif +import qualified Data.Vector as V +import Prelude hiding (mapM, maximum) + +import Verifier.SAW.Conversion (natConversions) +import Verifier.SAW.Recognizer +import Verifier.SAW.Rewriter +import Verifier.SAW.SharedTerm +import Verifier.SAW.TypedAST +import Verifier.SAW.Module +import Verifier.SAW.Position + +-- | The state for a type-checking computation = a memoization table +type TCState = Map TermIndex Term + +-- | The monad for type checking and inference, which: +-- +-- * Maintains a 'SharedContext', the name of the current module, and a variable +-- context, where the latter assigns types to the deBruijn indices in scope; +-- +-- * Memoizes the most general type inferred for each expression; AND +-- +-- * Can throw 'TCError's +type TCM a = + ReaderT (SharedContext, Maybe ModuleName, [(LocalName, Term)]) + (StateT TCState (ExceptT TCError IO)) a + +-- | Run a type-checking computation in a given context, starting from the empty +-- memoization table +runTCM :: + TCM a -> SharedContext -> Maybe ModuleName -> [(LocalName, Term)] -> + IO (Either TCError a) +runTCM m sc mnm ctx = + runExceptT $ evalStateT (runReaderT m (sc, mnm, ctx)) Map.empty + +-- | Read the current typing context +askCtx :: TCM [(LocalName, Term)] +askCtx = (\(_,_,ctx) -> ctx) <$> ask + +-- | Read the current module name +askModName :: TCM (Maybe ModuleName) +askModName = (\(_,mnm,_) -> mnm) <$> ask + +-- | Run a type-checking computation in a typing context extended with a new +-- variable with the given type. This throws away the memoization table while +-- running the sub-computation, as memoization tables are tied to specific sets +-- of bindings. +-- +-- NOTE: the type given for the variable should be in WHNF, so that we do not +-- have to normalize the types of variables each time we see them. +withVar :: LocalName -> Term -> TCM a -> TCM a +withVar x tp m = + flip catchError (throwError . ErrorCtx x tp) $ + do saved_table <- get + put Map.empty + a <- local (\(sc,mnm,ctx) -> (sc, mnm, (x,tp):ctx)) m + put saved_table + return a + +-- | Run a type-checking computation in a typing context extended by a list of +-- variables and their types. See 'withVar'. +withCtx :: [(LocalName, Term)] -> TCM a -> TCM a +withCtx = flip (foldr (\(x,tp) -> withVar x tp)) + + +-- | Run a type-checking computation @m@ and tag any error it throws with the +-- given position, using the 'ErrorPos' constructor, unless that error is +-- already tagged with a position +atPos :: Pos -> TCM a -> TCM a +atPos p m = catchError m (throwError . ErrorPos p) + +-- | Typeclass for lifting 'IO' computations that take a 'SharedContext' to +-- 'TCM' computations +class LiftTCM a where + type TCMLifted a + liftTCM :: (SharedContext -> a) -> TCMLifted a + +instance LiftTCM (IO a) where + type TCMLifted (IO a) = TCM a + liftTCM f = + do sc <- (\(sc,_,_) -> sc) <$> ask + liftIO (f sc) + +instance LiftTCM b => LiftTCM (a -> b) where + type TCMLifted (a -> b) = a -> TCMLifted b + liftTCM f a = liftTCM (\sc -> f sc a) + +-- | Errors that can occur during type-checking +data TCError + = NotSort Term + | NotFuncType Term + | NotTupleType Term + | BadTupleIndex Int Term + | NotStringLit Term + | NotRecordType TypedTerm + | BadRecordField FieldName Term + | DanglingVar Int + | UnboundName Text + | SubtypeFailure TypedTerm Term + | EmptyVectorLit + | NoSuchDataType Ident + | NoSuchCtor Ident + | NotFullyAppliedRec Ident + | BadParamsOrArgsLength Bool Ident [Term] [Term] + | BadConstType NameInfo Term Term + | MalformedRecursor Term String + | DeclError Text String + | ErrorPos Pos TCError + | ErrorCtx LocalName Term TCError + +-- | Throw a type-checking error +throwTCError :: TCError -> TCM a +throwTCError = throwError + +type PPErrM = Reader ([LocalName], Maybe Pos) + +-- | Pretty-print a type-checking error +prettyTCError :: TCError -> [String] +prettyTCError e = runReader (helper e) ([], Nothing) where + + ppWithPos :: [PPErrM String] -> PPErrM [String] + ppWithPos str_ms = + do strs <- mapM id str_ms + (_, maybe_p) <- ask + case maybe_p of + Just p -> return (ppPos p : strs) + Nothing -> return strs + + helper :: TCError -> PPErrM [String] + helper (NotSort ty) = ppWithPos [ return "Not a sort" , ishow ty ] + helper (NotFuncType ty) = + ppWithPos [ return "Function application with non-function type" , + ishow ty ] + helper (NotTupleType ty) = + ppWithPos [ return "Tuple field projection with non-tuple type" , + ishow ty ] + helper (BadTupleIndex n ty) = + ppWithPos [ return ("Bad tuple index (" ++ show n ++ ") for type") + , ishow ty ] + helper (NotStringLit trm) = + ppWithPos [ return "Record selector is not a string literal", ishow trm ] + helper (NotRecordType (TypedTerm trm tp)) = + ppWithPos [ return "Record field projection with non-record type" + , ishow tp + , return "In term:" + , ishow trm ] + helper (BadRecordField n ty) = + ppWithPos [ return ("Bad record field (" ++ show n ++ ") for type") + , ishow ty ] + helper (DanglingVar n) = + ppWithPos [ return ("Dangling bound variable index: " ++ show n)] + helper (UnboundName str) = ppWithPos [ return ("Unbound name: " ++ show str)] + helper (SubtypeFailure trm tp2) = + ppWithPos [ return "Inferred type", ishow (typedType trm), + return "Not a subtype of expected type", ishow tp2, + return "For term", ishow (typedVal trm) ] + helper EmptyVectorLit = ppWithPos [ return "Empty vector literal"] + helper (NoSuchDataType d) = + ppWithPos [ return ("No such data type: " ++ show d)] + helper (NoSuchCtor c) = + ppWithPos [ return ("No such constructor: " ++ show c) ] + helper (NotFullyAppliedRec i) = + ppWithPos [ return ("Recursor not fully applied: " ++ show i) ] + helper (BadParamsOrArgsLength is_dt ident params args) = + ppWithPos + [ return ("Wrong number of parameters or arguments to " + ++ (if is_dt then "datatype" else "constructor") ++ ": "), + ishow (Unshared $ FTermF $ + (if is_dt then DataTypeApp else CtorApp) ident params args) + ] + helper (BadConstType n rty ty) = + ppWithPos [ return ("Type of constant " ++ show n), ishow rty + , return "doesn't match declared type", ishow ty ] + helper (MalformedRecursor trm reason) = + ppWithPos [ return "Malformed recursor application", + ishow trm, return reason ] + helper (DeclError nm reason) = + ppWithPos [ return ("Malformed declaration for " ++ show nm), return reason ] + helper (ErrorPos p err) = + local (\(ctx,_) -> (ctx, Just p)) $ helper err + helper (ErrorCtx x _ err) = + local (\(ctx,p) -> (x:ctx, p)) $ helper err + + ishow :: Term -> PPErrM String + ishow tm = + -- return $ show tm + (\(ctx,_) -> " " ++ scPrettyTermInCtx defaultPPOpts ctx tm) <$> ask + +instance Show TCError where + show = unlines . prettyTCError + +-- | Infer the type of a term using 'scTypeCheck', calling 'fail' on failure +scTypeCheckError :: TypeInfer a => SharedContext -> a -> IO Term +scTypeCheckError sc t0 = + either (fail . unlines . prettyTCError) return =<< scTypeCheck sc Nothing t0 + +-- | Infer the type of a 'Term', ensuring in the process that the entire term is +-- well-formed and that all internal type annotations are correct. Types are +-- evaluated to WHNF as necessary, and the returned type is in WHNF. +scTypeCheck :: TypeInfer a => SharedContext -> Maybe ModuleName -> a -> + IO (Either TCError Term) +scTypeCheck sc mnm = scTypeCheckInCtx sc mnm [] + +-- | Like 'scTypeCheck', but type-check the term relative to a typing context, +-- which assigns types to free variables in the term +scTypeCheckInCtx :: + TypeInfer a => SharedContext -> Maybe ModuleName -> + [(LocalName, Term)] -> a -> IO (Either TCError Term) +scTypeCheckInCtx sc mnm ctx t0 = runTCM (typeInfer t0) sc mnm ctx + +-- | Infer the type of an @a@ and complete it to a term using +-- 'scTypeCheckComplete', calling 'fail' on failure +scTypeCheckCompleteError :: TypeInfer a => SharedContext -> + Maybe ModuleName -> a -> IO TypedTerm +scTypeCheckCompleteError sc mnm t0 = + either (fail . unlines . prettyTCError) return =<< + scTypeCheckComplete sc mnm t0 + +-- | Infer the type of an @a@ and complete it to a term, ensuring in the +-- process that the entire term is well-formed and that all internal type +-- annotations are correct. Types are evaluated to WHNF as necessary, and the +-- returned type is in WHNF, though the returned term may not be. +scTypeCheckComplete :: TypeInfer a => SharedContext -> Maybe ModuleName -> + a -> IO (Either TCError TypedTerm) +scTypeCheckComplete sc mnm = scTypeCheckCompleteInCtx sc mnm [] + +-- | Like 'scTypeCheckComplete', but type-check the term relative to a typing +-- context, which assigns types to free variables in the term +scTypeCheckCompleteInCtx :: TypeInfer a => SharedContext -> + Maybe ModuleName -> [(LocalName, Term)] -> a -> + IO (Either TCError TypedTerm) +scTypeCheckCompleteInCtx sc mnm ctx t0 = + runTCM (typeInferComplete t0) sc mnm ctx + +-- | Check that one type is a subtype of another using 'checkSubtype', calling +-- 'fail' on failure +scCheckSubtype :: SharedContext -> Maybe ModuleName -> + TypedTerm -> Term -> IO () +scCheckSubtype sc mnm arg req_tp = + either (fail . unlines . prettyTCError) return =<< + runTCM (checkSubtype arg req_tp) sc mnm [] + +-- | A pair of a 'Term' and its type +data TypedTerm = TypedTerm { typedVal :: Term, typedType :: Term } + +-- | The class of things that we can infer types of. The 'typeInfer' method +-- returns the most general (with respect to subtyping) type of its input. +class TypeInfer a where + -- | Infer the type of an @a@ + typeInfer :: a -> TCM Term + -- | Infer the type of an @a@ and complete it to a 'Term' + typeInferComplete :: a -> TCM TypedTerm + +-- | Infer the type of an @a@ and complete it to a 'Term', and then evaluate the +-- resulting term to WHNF +typeInferCompleteWHNF :: TypeInfer a => a -> TCM TypedTerm +typeInferCompleteWHNF a = + do TypedTerm a_trm a_tp <- typeInferComplete a + a_whnf <- typeCheckWHNF a_trm + return $ TypedTerm a_whnf a_tp + + +-- | Perform type inference on a context, i.e., a list of variable names and +-- their associated types. The type @var@ gives the type of variable names, +-- while @a@ is the type of types. This will give us 'Term's for each type, as +-- well as their 'Sort's, since the type of any type is a 'Sort'. +class TypeInferCtx var a where + typeInferCompleteCtx :: [(var,a)] -> TCM [(LocalName, Term, Sort)] + +instance TypeInfer a => TypeInferCtx LocalName a where + typeInferCompleteCtx [] = return [] + typeInferCompleteCtx ((x,tp):ctx) = + do typed_tp <- typeInferComplete tp + s <- ensureSort (typedType typed_tp) + ((x,typedVal typed_tp,s):) <$> + withVar x (typedVal typed_tp) (typeInferCompleteCtx ctx) + +-- | Perform type inference on a context via 'typeInferCompleteCtx', and then +-- run a computation in that context via 'withCtx', also passing in that context +-- to the computation +typeInferCompleteInCtx :: + TypeInferCtx var tp => [(var, tp)] -> + ([(LocalName, Term, Sort)] -> TCM a) -> TCM a +typeInferCompleteInCtx ctx f = + do typed_ctx <- typeInferCompleteCtx ctx + withCtx (map (\(x,tp,_) -> (x,tp)) typed_ctx) (f typed_ctx) + + +-- Type inference for Term dispatches to type inference on TermF Term, but uses +-- memoization to avoid repeated work +instance TypeInfer Term where + typeInfer (Unshared tf) = typeInfer tf + typeInfer (STApp{ stAppIndex = i, stAppTermF = tf}) = + do table <- get + case Map.lookup i table of + Just x -> return x + Nothing -> + do x <- typeInfer tf + x' <- typeCheckWHNF x + modify (Map.insert i x') + return x' + typeInferComplete trm = TypedTerm trm <$> typeInfer trm + +-- Type inference for TermF Term dispatches to that for TermF TypedTerm by +-- calling inference on all the sub-components and extending the context inside +-- of the binding forms +instance TypeInfer (TermF Term) where + typeInfer (Lambda x a rhs) = + do a_tptrm <- typeInferCompleteWHNF a + -- NOTE: before adding a type to the context, we want to be sure it is in + -- WHNF, so we don't have to normalize each time we look up a var type + rhs_tptrm <- withVar x (typedVal a_tptrm) $ typeInferComplete rhs + typeInfer (Lambda x a_tptrm rhs_tptrm) + typeInfer (Pi x a rhs) = + do a_tptrm <- typeInferCompleteWHNF a + -- NOTE: before adding a type to the context, we want to be sure it is in + -- WHNF, so we don't have to normalize each time we look up a var type + rhs_tptrm <- withVar x (typedVal a_tptrm) $ typeInferComplete rhs + typeInfer (Pi x a_tptrm rhs_tptrm) + typeInfer t = typeInfer =<< mapM typeInferComplete t + typeInferComplete tf = + TypedTerm <$> liftTCM scTermF tf <*> typeInfer tf + +-- Type inference for FlatTermF Term dispatches to that for FlatTermF TypedTerm +instance TypeInfer (FlatTermF Term) where + typeInfer t = typeInfer =<< mapM typeInferComplete t + typeInferComplete ftf = + TypedTerm <$> liftTCM scFlatTermF ftf <*> typeInfer ftf + + +-- Type inference for TermF TypedTerm is the main workhorse. Intuitively, this +-- represents the case where each immediate subterm of a term is labeled with +-- its (most general) type. +instance TypeInfer (TermF TypedTerm) where + typeInfer (FTermF ftf) = typeInfer ftf + typeInfer (App (TypedTerm _ x_tp) y) = applyPiTyped x_tp y + typeInfer (Lambda x (TypedTerm a a_tp) (TypedTerm _ b)) = + void (ensureSort a_tp) >> liftTCM scTermF (Pi x a b) + typeInfer (Pi _ (TypedTerm _ a_tp) (TypedTerm _ b_tp)) = + do s1 <- ensureSort a_tp + s2 <- ensureSort b_tp + -- NOTE: the rule for type-checking Pi types is that (Pi x a b) is a Prop + -- when b is a Prop (this is a forall proposition), otherwise it is a + -- (Type (max (sortOf a) (sortOf b))) + liftTCM scSort $ if s2 == propSort then propSort else max s1 s2 + typeInfer (LocalVar i) = + do ctx <- askCtx + if i < length ctx then + -- The ith type in the current variable typing context is well-typed + -- relative to the suffix of the context after it, so we have to lift it + -- (i.e., call incVars) to make it well-typed relative to all of ctx + liftTCM incVars 0 (i+1) (snd (ctx !! i)) + else + error ("Context = " ++ show ctx) + -- throwTCError (DanglingVar (i - length ctx)) + typeInfer (Constant (EC _ n (TypedTerm req_tp req_tp_sort)) (TypedTerm _ tp)) = + do void (ensureSort req_tp_sort) + -- NOTE: we do the subtype check here, rather than call checkSubtype, so + -- that we can throw the custom BadConstType error on failure + ok <- isSubtype tp req_tp + if ok then return tp else + throwTCError $ BadConstType n tp req_tp + typeInferComplete tf = + TypedTerm <$> liftTCM scTermF (fmap typedVal tf) <*> typeInfer tf + + +-- Type inference for FlatTermF TypedTerm is the main workhorse for flat +-- terms. Intuitively, this represents the case where each immediate subterm of +-- a term has already been labeled with its (most general) type. +instance TypeInfer (FlatTermF TypedTerm) where + typeInfer (Primitive ec) = + typeCheckWHNF $ typedVal $ ecType ec + typeInfer UnitValue = liftTCM scUnitType + typeInfer UnitType = liftTCM scSort (mkSort 0) + typeInfer (PairValue (TypedTerm _ tx) (TypedTerm _ ty)) = + liftTCM scPairType tx ty + typeInfer (PairType (TypedTerm _ tx) (TypedTerm _ ty)) = + do sx <- ensureSort tx + sy <- ensureSort ty + liftTCM scSort (max sx sy) + typeInfer (PairLeft (TypedTerm _ tp)) = + case asPairType tp of + Just (t1, _) -> typeCheckWHNF t1 + _ -> throwTCError (NotTupleType tp) + typeInfer (PairRight (TypedTerm _ tp)) = + case asPairType tp of + Just (_, t2) -> typeCheckWHNF t2 + _ -> throwTCError (NotTupleType tp) + + typeInfer (DataTypeApp d params args) = + -- Look up the DataType structure, check the length of the params and args, + -- and then apply the cached Pi type of dt to params and args + do maybe_dt <- liftTCM scFindDataType d + dt <- case maybe_dt of + Just dt -> return dt + Nothing -> throwTCError $ NoSuchDataType d + if length params == length (dtParams dt) && + length args == length (dtIndices dt) then return () else + throwTCError $ + BadParamsOrArgsLength True d (map typedVal params) (map typedVal args) + -- NOTE: we assume dtType is already well-typed and in WHNF + -- _ <- inferSort t + -- t' <- typeCheckWHNF t + foldM applyPiTyped (dtType dt) (params ++ args) + + typeInfer (CtorApp c params args) = + -- Look up the Ctor structure, check the length of the params and args, and + -- then apply the cached Pi type of ctor to params and args + do maybe_ctor <- liftTCM scFindCtor c + ctor <- case maybe_ctor of + Just ctor -> return ctor + Nothing -> throwTCError $ NoSuchCtor c + if length params == ctorNumParams ctor && + length args == ctorNumArgs ctor then return () else + throwTCError $ + BadParamsOrArgsLength False c (map typedVal params) (map typedVal args) + -- NOTE: we assume ctorType is already well-typed and in WHNF + -- _ <- inferSort t + -- t' <- typeCheckWHNF t + foldM applyPiTyped (ctorType ctor) (params ++ args) + + typeInfer (RecursorApp d params p_ret cs_fs ixs arg) = + inferRecursorApp d params p_ret cs_fs ixs arg + typeInfer (RecordType elems) = + -- NOTE: record types are always predicative, i.e., non-Propositional, so we + -- ensure below that we return at least sort 0 + do sorts <- mapM (ensureSort . typedType . snd) elems + liftTCM scSort (maxSort $ mkSort 0 : sorts) + typeInfer (RecordValue elems) = + liftTCM scFlatTermF $ RecordType $ + map (\(f,TypedTerm _ tp) -> (f,tp)) elems + typeInfer (RecordProj t@(TypedTerm _ t_tp) fld) = + case asRecordType t_tp of + Just (Map.lookup fld -> Just tp) -> return tp + Just _ -> throwTCError $ BadRecordField fld t_tp + Nothing -> throwTCError $ NotRecordType t + typeInfer (Sort s) = liftTCM scSort (sortOf s) + typeInfer (NatLit _) = liftTCM scNatType + typeInfer (ArrayValue (TypedTerm tp tp_tp) vs) = + do n <- liftTCM scNat (fromIntegral (V.length vs)) + _ <- ensureSort tp_tp -- TODO: do we care about the level? + tp' <- typeCheckWHNF tp + forM_ vs $ \v_elem -> checkSubtype v_elem tp' + liftTCM scVecType n tp' + typeInfer (StringLit{}) = liftTCM scStringType + typeInfer (ExtCns ec) = + -- FIXME: should we check that the type of ecType is a sort? + typeCheckWHNF $ typedVal $ ecType ec + + typeInferComplete ftf = + TypedTerm <$> liftTCM scFlatTermF (fmap typedVal ftf) <*> typeInfer ftf + +-- | Check that @fun_tp=Pi x a b@ and that @arg@ has type @a@, and return the +-- result of substituting @arg@ for @x@ in the result type @b@, i.e., +-- @[arg/x]b@. This substitution could create redexes, so we call the evaluator. +applyPiTyped :: Term -> TypedTerm -> TCM Term +applyPiTyped fun_tp arg = + case asPi fun_tp of + Just (_, arg_tp, ret_tp) -> do + -- _ <- ensureSort aty -- NOTE: we assume tx is well-formed and WHNF + -- aty' <- scTypeCheckWHNF aty + checkSubtype arg arg_tp + liftTCM instantiateVar 0 (typedVal arg) ret_tp >>= typeCheckWHNF + _ -> throwTCError (NotFuncType fun_tp) + +-- | Ensure that a 'Term' is a sort, and return that sort +ensureSort :: Term -> TCM Sort +ensureSort (asSort -> Just s) = return s +ensureSort tp = throwTCError $ NotSort tp + +-- | Reduce a type to WHNF (using 'scWhnf'), also adding in some conversions for +-- operations on Nat literals that are useful in type-checking +typeCheckWHNF :: Term -> TCM Term +typeCheckWHNF = liftTCM scTypeCheckWHNF + +-- | The 'IO' version of 'typeCheckWHNF' +scTypeCheckWHNF :: SharedContext -> Term -> IO Term +scTypeCheckWHNF sc t = + do t' <- rewriteSharedTerm sc (addConvs natConversions emptySimpset) t + scWhnf sc t' + +-- | Check that one type is a subtype of another, assuming both arguments are +-- types, i.e., that both have type Sort s for some s, and that they are both +-- already in WHNF +checkSubtype :: TypedTerm -> Term -> TCM () +checkSubtype arg req_tp = + do ok <- isSubtype (typedType arg) req_tp + if ok then return () else throwTCError $ SubtypeFailure arg req_tp + +-- | Check if one type is a subtype of another, assuming both arguments are +-- types, i.e., that both have type Sort s for some s, and that they are both +-- already in WHNF +isSubtype :: Term -> Term -> TCM Bool +isSubtype (unwrapTermF -> Pi x1 a1 b1) (unwrapTermF -> Pi _ a2 b2) = + (&&) <$> areConvertible a1 a2 <*> withVar x1 a1 (isSubtype b1 b2) +isSubtype (asSort -> Just s1) (asSort -> Just s2) | s1 <= s2 = return True +isSubtype t1' t2' = areConvertible t1' t2' + +-- | Check if two terms are "convertible for type-checking", meaning that they +-- are convertible up to 'natConversions' +areConvertible :: Term -> Term -> TCM Bool +areConvertible t1 t2 = liftTCM scConvertibleEval scTypeCheckWHNF True t1 t2 + +-- | Infer the type of a recursor application +inferRecursorApp :: Ident -> [TypedTerm] -> TypedTerm -> + [(Ident,TypedTerm)] -> [TypedTerm] -> TypedTerm -> + TCM Term +inferRecursorApp d params p_ret cs_fs ixs arg = + do let mk_err str = + MalformedRecursor + (Unshared $ fmap typedVal $ FTermF $ + RecursorApp d params p_ret cs_fs ixs arg) str + maybe_dt <- liftTCM scFindDataType d + dt <- case maybe_dt of + Just dt -> return dt + Nothing -> throwTCError $ NoSuchDataType d + + -- Check that the params and ixs have the correct types by making sure + -- they correspond to the input types of dt + if length params == length (dtParams dt) && + length ixs == length (dtIndices dt) then return () else + throwTCError $ mk_err "Incorrect number of params or indices" + _ <- foldM applyPiTyped (dtType dt) (params ++ ixs) + + -- Get the type of p_ret and make sure that it is of the form + -- + -- (ix1::Ix1) -> .. -> (ixn::Ixn) -> d params ixs -> s + -- + -- for some allowed sort s, where the Ix are the indices of of dt + p_ret_s <- + case asPiList (typedType p_ret) of + (_, (asSort -> Just s)) -> return s + _ -> throwTCError $ mk_err "Motive function should return a sort" + p_ret_tp_req <- + liftTCM scRecursorRetTypeType dt (map typedVal params) p_ret_s + -- Technically this is an equality test, not a subtype test, but we + -- use the precise sort used in p_ret, so they are the same, and + -- checkSubtype is handy... + checkSubtype p_ret p_ret_tp_req + if allowedElimSort dt p_ret_s then return () + else throwTCError $ mk_err "Disallowed propositional elimination" + + -- Check that the elimination functions each have the right types, and + -- that we have exactly one for each constructor of dt + cs_fs_tps <- + liftTCM scRecursorElimTypes d (map typedVal params) (typedVal p_ret) + case map fst cs_fs \\ map fst cs_fs_tps of + [] -> return () + cs -> throwTCError $ mk_err ("Extra constructors: " ++ show cs) + forM_ cs_fs_tps $ \(c,req_tp) -> + case lookup c cs_fs of + Nothing -> + throwTCError $ mk_err ("Missing constructor: " ++ show c) + Just f -> checkSubtype f req_tp + + -- Finally, check that arg has type (d params ixs), and return the + -- type (p_ret ixs arg) + arg_req_tp <- + liftTCM scFlatTermF $ fmap typedVal $ DataTypeApp d params ixs + checkSubtype arg arg_req_tp + liftTCM scApplyAll (typedVal p_ret) (map typedVal (ixs ++ [arg])) >>= + liftTCM scTypeCheckWHNF diff --git a/saw-core/src/Verifier/SAW/SharedTerm.hs b/saw-core/src/Verifier/SAW/SharedTerm.hs new file mode 100644 index 0000000000..1680dc138e --- /dev/null +++ b/saw-core/src/Verifier/SAW/SharedTerm.hs @@ -0,0 +1,2362 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ParallelListComp #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE LambdaCase #-} + +{- | +Module : Verifier.SAW.SharedTerm +Copyright : Galois, Inc. 2012-2015 +License : BSD3 +Maintainer : jhendrix@galois.com +Stability : experimental +Portability : non-portable (language extensions) +-} + +module Verifier.SAW.SharedTerm + ( TermF(..) + , Uninterp(..) + , Ident, mkIdent + , VarIndex + , ExtCns(..) + , NameInfo(..) + , ppName + -- * Shared terms + , Term(..) + , TermIndex + , looseVars + , smallestFreeVar + , scSharedTerm + , unshare + , scImport + , alphaEquiv + , alistAllFields + , scRegisterName + , scResolveName + , scResolveNameByURI + , scResolveUnambiguous + , scFindBestName + , scShowTerm + , DuplicateNameException(..) + -- * Re-exported pretty-printing functions + , PPOpts(..) + , defaultPPOpts + , ppTerm + , ppTermDepth + , showTerm + , scPrettyTerm + , scPrettyTermInCtx + -- * SharedContext interface for building shared terms + , SharedContext + , mkSharedContext + , scGetModuleMap + -- ** Low-level generic term constructors + , scTermF + , scFlatTermF + -- ** Implicit versions of functions. + , scDefTerm + , scFreshGlobalVar + , scFreshGlobal + , scFreshEC + , scExtCns + , scGlobalDef + , scRegisterGlobal + -- ** Recursors and datatypes + , scRecursorElimTypes + , scRecursorRetTypeType + , scReduceRecursor + , allowedElimSort + , scBuildCtor + -- ** Modules + , scLoadModule + , scUnloadModule + , scModifyModule + , scModuleIsLoaded + , scFindModule + , scFindDef + , scFindDataType + , scFindCtor + , scRequireDef + , scRequireDataType + , scRequireCtor + -- ** Term construction + -- *** Datatypes and constructors + , scDataTypeAppParams + , scDataTypeApp + , scCtorAppParams + , scCtorApp + , scApplyCtor + , scSort + -- *** Variables and constants + , scLocalVar + , scConstant + , scConstant' + , scLookupDef + -- *** Functions and function application + , scApply + , scApplyAll + , scGlobalApply + , scFun + , scFunAll + , scLambda + , scLambdaList + , scPi + , scPiList + -- *** Strings + , scString + , scStringType + -- *** Booleans + , scEqTrue + , scBool + , scBoolType + -- *** Unit, pairs, and tuples + , scUnitValue + , scUnitType + , scPairValue + , scPairType + , scPairLeft + , scPairRight + , scPairValueReduced + , scTuple + , scTupleType + , scTupleSelector + , scTupleReduced + -- *** Records + , scRecord + , scRecordSelect + , scRecordType + -- *** Vectors + , scVector + , scVecType + , scVectorReduced + -- ** Normalization + , asCtorOrNat + , scWhnf + , scConvertibleEval + , scConvertible + -- ** Type checking + , scTypeOf + , scTypeOf' + , asSort + , reducePi + , scTypeOfCtor + , scTypeOfDataType + , scTypeOfGlobal + -- ** Prelude operations + -- *** Booleans + , scNot + , scAnd + , scOr + , scImplies + , scXor + , scBoolEq + , scIte + -- *** Natural numbers + , scNat + , scNatType + , scAddNat + , scSubNat + , scMulNat + , scDivNat + , scModNat + , scDivModNat + , scEqualNat + , scLtNat + , scMinNat + , scMaxNat + , scUpdNatFun + -- *** Integers + , scIntegerType + , scIntegerConst + , scIntAdd, scIntSub, scIntMul + , scIntDiv, scIntMod, scIntNeg + , scIntAbs, scIntMin, scIntMax + , scIntEq, scIntLe, scIntLt + , scIntToNat, scNatToInt + , scIntToBv, scBvToInt, scSbvToInt + -- *** IntMod + , scIntModType + , scToIntMod + -- *** Vectors + , scAppend + , scJoin + , scSplit + , scGet + , scAtWithDefault + , scAt + , scSingle + , scSlice + -- *** Bitvectors + , scBitvector + , scBvNat + , scBvToNat + , scBvAt + , scBvConst + , scFinVal + , scBvForall + , scUpdBvFun + , scBvNonzero, scBvBool + , scBvAdd, scBvSub, scBvMul, scBvNeg + , scBvURem, scBvUDiv, scBvSRem, scBvSDiv + , scBvOr, scBvAnd, scBvXor + , scBvNot + , scBvEq, scBvUGe, scBvUGt, scBvULe, scBvULt + , scBvSGt, scBvSGe, scBvSLt, scBvSLe + , scBvShl, scBvShr, scBvSShr + , scBvUExt, scBvSExt + , scBvTrunc + , scBvPopcount + , scBvCountLeadingZeros + , scBvCountTrailingZeros + , scLsb, scMsb + -- *** Arrays + , scArrayType + , scArrayConstant + , scArrayLookup + , scArrayUpdate + -- ** Utilities +-- , scTrue +-- , scFalse + , scOpenTerm + , scCloseTerm + -- ** Variable substitution + , instantiateVar + , instantiateVarList + , betaNormalize + , getAllExts + , getAllExtSet + , getConstantSet + , scInstantiateExt + , scAbstractExts + , scGeneralizeExts + , incVars + , scUnfoldConstants + , scUnfoldConstants' + , scUnfoldConstantSet + , scUnfoldConstantSet' + , scSharedSize + , scTreeSize + ) where + +import Control.Applicative +-- ((<$>), pure, (<*>)) +import Control.Concurrent.MVar +import Control.Exception +import Control.Lens +import Control.Monad.State.Strict as State +import Control.Monad.Reader +import Data.Bits +import Data.Maybe +import qualified Data.Foldable as Fold +import Data.Foldable (foldl', foldlM, foldrM, maximum) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HMap +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import qualified Data.IntSet as IntSet +import Data.IORef (IORef,newIORef,readIORef,modifyIORef',atomicModifyIORef') +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Ref ( C ) +import Data.Set (Set) +import Data.Text (Text) +import qualified Data.Set as Set +import qualified Data.Text as Text +import qualified Data.Vector as V +import Numeric.Natural (Natural) +import Prelude hiding (mapM, maximum) +import Text.URI + +import Verifier.SAW.Cache +import Verifier.SAW.Change +import Verifier.SAW.Name +import Verifier.SAW.Prelude.Constants +import Verifier.SAW.Recognizer +import Verifier.SAW.Term.Functor +import Verifier.SAW.Term.CtxTerm +import Verifier.SAW.Term.Pretty +import Verifier.SAW.TypedAST +import Verifier.SAW.Unique + +#if !MIN_VERSION_base(4,8,0) +countTrailingZeros :: (FiniteBits b) => b -> Int +countTrailingZeros x = go 0 + where + go i | i >= w = i + | testBit x i = i + | otherwise = go (i+1) + w = finiteBitSize x +#endif + +newtype Uninterp = Uninterp { getUninterp :: (String, Term) } deriving Show + +------------------------------------------------------------ +-- TermFMaps + +-- | A TermFMap is a data structure used for hash-consing of terms. +data TermFMap a + = TermFMap + { appMapTFM :: !(IntMap (IntMap a)) + , hashMapTFM :: !(HashMap (TermF Term) a) + } + +emptyTFM :: TermFMap a +emptyTFM = TermFMap IntMap.empty HMap.empty + +lookupTFM :: TermF Term -> TermFMap a -> Maybe a +lookupTFM tf tfm = + case tf of + App (STApp{ stAppIndex = i }) (STApp{ stAppIndex = j}) -> + IntMap.lookup i (appMapTFM tfm) >>= IntMap.lookup j + _ -> HMap.lookup tf (hashMapTFM tfm) + +insertTFM :: TermF Term -> a -> TermFMap a -> TermFMap a +insertTFM tf x tfm = + case tf of + App (STApp{ stAppIndex = i }) (STApp{ stAppIndex = j}) -> + let f Nothing = Just (IntMap.singleton j x) + f (Just m) = Just (IntMap.insert j x m) + in tfm { appMapTFM = IntMap.alter f i (appMapTFM tfm) } + _ -> tfm { hashMapTFM = HMap.insert tf x (hashMapTFM tfm) } + +---------------------------------------------------------------------- +-- SharedContext: a high-level interface for building Terms. + +data SharedContext = SharedContext + { scModuleMap :: IORef ModuleMap + , scTermF :: TermF Term -> IO Term + , scNamingEnv :: IORef SAWNamingEnv + , scGlobalEnv :: IORef (HashMap Ident Term) + , scFreshGlobalVar :: IO VarIndex + } + +-- | Create a new term from a lower-level 'FlatTermF' term. +scFlatTermF :: SharedContext -> FlatTermF Term -> IO Term +scFlatTermF sc ftf = scTermF sc (FTermF ftf) + +-- | Create a 'Term' from an 'ExtCns'. +scExtCns :: SharedContext -> ExtCns Term -> IO Term +scExtCns sc ec = scFlatTermF sc (ExtCns ec) + +data DuplicateNameException = DuplicateNameException URI +instance Exception DuplicateNameException +instance Show DuplicateNameException where + show (DuplicateNameException uri) = + "Attempted to register the following name twice: " ++ Text.unpack (render uri) + +scRegisterName :: SharedContext -> VarIndex -> NameInfo -> IO () +scRegisterName sc i nmi = atomicModifyIORef' (scNamingEnv sc) (\env -> (f env, ())) + where + f env = + case registerName i nmi env of + Left uri -> throw (DuplicateNameException uri) + Right env' -> env' + +scResolveUnambiguous :: SharedContext -> Text -> IO (VarIndex, NameInfo) +scResolveUnambiguous sc nm = + scResolveName sc nm >>= \case + [] -> fail ("Could not resolve name: " ++ show nm) + [x] -> pure x + xs -> + do nms <- mapM (scFindBestName sc . snd) xs + fail $ unlines (("Ambiguous name " ++ show nm ++ " might refer to any of the following:") : map show nms) + +scFindBestName :: SharedContext -> NameInfo -> IO Text +scFindBestName sc nmi = + do env <- readIORef (scNamingEnv sc) + case bestAlias env nmi of + Left uri -> pure (render uri) + Right nm -> pure nm + +scResolveNameByURI :: SharedContext -> URI -> IO (Maybe VarIndex) +scResolveNameByURI sc uri = + do env <- readIORef (scNamingEnv sc) + pure $! resolveURI env uri + +scResolveName :: SharedContext -> Text -> IO [(VarIndex, NameInfo)] +scResolveName sc nm = + do env <- readIORef (scNamingEnv sc) + pure (resolveName env nm) + +scShowTerm :: SharedContext -> PPOpts -> Term -> IO String +scShowTerm sc opts t = + do env <- readIORef (scNamingEnv sc) + pure (showTermWithNames opts env t) + +-- | Create a global variable with the given identifier (which may be "_") and type. +scFreshEC :: SharedContext -> String -> a -> IO (ExtCns a) +scFreshEC sc x tp = do + i <- scFreshGlobalVar sc + let x' = Text.pack x + let uri = scFreshNameURI x' i + let nmi = ImportedName uri [x',Text.pack (x <> "#" <> show i)] + scRegisterName sc i nmi + pure (EC i nmi tp) + +-- | Create a global variable with the given identifier (which may be "_") and type. +scFreshGlobal :: SharedContext -> String -> Term -> IO Term +scFreshGlobal sc x tp = scExtCns sc =<< scFreshEC sc x tp + +-- | Returns shared term associated with ident. +-- Does not check module namespace. +scGlobalDef :: SharedContext -> Ident -> IO Term +scGlobalDef sc ident = + do m <- readIORef (scGlobalEnv sc) + case HMap.lookup ident m of + Nothing -> fail ("Could not find global: " ++ show ident) + Just t -> pure t + +scRegisterGlobal :: SharedContext -> Ident -> Term -> IO () +scRegisterGlobal sc ident t = + do dup <- atomicModifyIORef' (scGlobalEnv sc) f + when dup $ fail ("Global identifier already registered: " ++ show ident) + where + f m = + case HMap.lookup ident m of + Just _ -> (m, True) + Nothing -> (HMap.insert ident t m, False) + +-- | Create a function application term. +scApply :: SharedContext + -> Term -- ^ The function to apply + -> Term -- ^ The argument to apply to + -> IO Term +scApply sc f = scTermF sc . App f + +-- | Applies the constructor with the given name to the list of parameters and +-- arguments. This version does no checking against the module. +scDataTypeAppParams :: SharedContext + -> Ident -- ^ The constructor name + -> [Term] -- ^ The parameters + -> [Term] -- ^ The arguments + -> IO Term +scDataTypeAppParams sc ident params args = + scFlatTermF sc (DataTypeApp ident params args) + +-- | Applies the constructor with the given name to the list of +-- arguments. This version does no checking against the module. +scDataTypeApp :: SharedContext -> Ident -> [Term] -> IO Term +scDataTypeApp sc d_id args = + do d <- scRequireDataType sc d_id + let (params,args') = splitAt (length (dtParams d)) args + scDataTypeAppParams sc d_id params args' + +-- | Applies the constructor with the given name to the list of parameters and +-- arguments. This version does no checking against the module. +scCtorAppParams :: SharedContext + -> Ident -- ^ The constructor name + -> [Term] -- ^ The parameters + -> [Term] -- ^ The arguments + -> IO Term +scCtorAppParams sc ident params args = + scFlatTermF sc (CtorApp ident params args) + +-- | Applies the constructor with the given name to the list of +-- arguments. This version does no checking against the module. +scCtorApp :: SharedContext -> Ident -> [Term] -> IO Term +scCtorApp sc c_id args = + do ctor <- scRequireCtor sc c_id + let (params,args') = splitAt (ctorNumParams ctor) args + scCtorAppParams sc c_id params args' + +-- | Get the current 'ModuleMap' +scGetModuleMap :: SharedContext -> IO ModuleMap +scGetModuleMap sc = readIORef (scModuleMap sc) + +-- | Test if a module is loaded in the current shared context +scModuleIsLoaded :: SharedContext -> ModuleName -> IO Bool +scModuleIsLoaded sc name = + HMap.member name <$> scGetModuleMap sc + +-- | Load a module into the current shared context, raising an error if a module +-- of the same name is already loaded +scLoadModule :: SharedContext -> Module -> IO () +scLoadModule sc m = + modifyIORef' (scModuleMap sc) $ + HMap.insertWith (error $ "scLoadModule: module " + ++ show (moduleName m) ++ " already loaded!") + (moduleName m) m + +-- | Remove a module from the current shared context, or do nothing if it does +-- not exist +scUnloadModule :: SharedContext -> ModuleName -> IO () +scUnloadModule sc mnm = + modifyIORef' (scModuleMap sc) $ HMap.delete mnm + +-- | Modify an already loaded module, raising an error if it is not loaded +scModifyModule :: SharedContext -> ModuleName -> (Module -> Module) -> IO () +scModifyModule sc mnm f = + let err_msg = "scModifyModule: module " ++ show mnm ++ " not found!" in + modifyIORef' (scModuleMap sc) $ + HMap.alter (\case { Just m -> Just (f m); _ -> error err_msg }) mnm + +-- | Look up a module by name, raising an error if it is not loaded +scFindModule :: SharedContext -> ModuleName -> IO Module +scFindModule sc name = + do maybe_mod <- HMap.lookup name <$> scGetModuleMap sc + case maybe_mod of + Just m -> return m + Nothing -> + error ("scFindModule: module " ++ show name ++ " not found!") + +-- | Look up a definition by its identifier +scFindDef :: SharedContext -> Ident -> IO (Maybe Def) +scFindDef sc i = + findDef <$> scFindModule sc (identModule i) <*> pure (identBaseName i) + +-- | Look up a 'Def' by its identifier, throwing an error if it is not found +scRequireDef :: SharedContext -> Ident -> IO Def +scRequireDef sc i = + scFindDef sc i >>= \maybe_d -> + case maybe_d of + Just d -> return d + Nothing -> fail ("Could not find definition: " ++ show i) + +-- | Look up a datatype by its identifier +scFindDataType :: SharedContext -> Ident -> IO (Maybe DataType) +scFindDataType sc i = + findDataType <$> scFindModule sc (identModule i) <*> pure (identBaseName i) + +-- | Look up a datatype by its identifier, throwing an error if it is not found +scRequireDataType :: SharedContext -> Ident -> IO DataType +scRequireDataType sc i = + scFindDataType sc i >>= \maybe_d -> + case maybe_d of + Just d -> return d + Nothing -> fail ("Could not find datatype: " ++ show i) + +-- | Look up a constructor by its identifier +scFindCtor :: SharedContext -> Ident -> IO (Maybe Ctor) +scFindCtor sc i = + findCtor <$> scFindModule sc (identModule i) <*> pure (identBaseName i) + +-- | Look up a constructor by its identifier, throwing an error if not found +scRequireCtor :: SharedContext -> Ident -> IO Ctor +scRequireCtor sc i = + scFindCtor sc i >>= \maybe_ctor -> + case maybe_ctor of + Just ctor -> return ctor + Nothing -> fail ("Could not find constructor: " ++ show i) + + +-- SharedContext implementation. + +type AppCache = TermFMap Term + +type AppCacheRef = MVar AppCache + +emptyAppCache :: AppCache +emptyAppCache = emptyTFM + +-- | Return term for application using existing term in cache if it is available. +getTerm :: AppCacheRef -> TermF Term -> IO Term +getTerm r a = + modifyMVar r $ \s -> do + case lookupTFM a s of + Just t -> return (s, t) + Nothing -> do + i <- getUniqueInt + let t = STApp { stAppIndex = i + , stAppFreeVars = freesTermF (fmap looseVars a) + , stAppTermF = a + } + let s' = insertTFM a t s + seq s' $ return (s', t) + + +-------------------------------------------------------------------------------- +-- Recursors + +-- | Helper monad for building terms relative to a 'SharedContext' +newtype ShCtxM a = ShCtxM (ReaderT SharedContext IO a) + deriving (Functor, Applicative, Monad) + +scShCtxM :: SharedContext -> ShCtxM a -> IO a +scShCtxM sc (ShCtxM m) = runReaderT m sc + +instance MonadReader SharedContext ShCtxM where + ask = ShCtxM ask + local f (ShCtxM m) = ShCtxM $ local f m + +instance MonadIO ShCtxM where + liftIO m = ShCtxM $ liftIO m + +instance MonadTerm ShCtxM where + mkTermF tf = ask >>= \sc -> liftIO $ scTermF sc tf + liftTerm n i t = ask >>= \sc -> liftIO $ incVars sc n i t + substTerm n subst t = ask >>= \sc -> liftIO $ instantiateVarList sc n subst t + +-- | Test whether a 'DataType' can be eliminated to the given sort. The rules +-- are that you can only eliminate propositional datatypes to the proposition +-- sort, unless your propositional data type is the empty type. This differs +-- slightly from the Coq rules, which allow elimination of propositional +-- datatypes with a single constructor that has only propositional arguments, +-- but this Coq behavior can be simulated with the behavior we are using here. +allowedElimSort :: DataType -> Sort -> Bool +allowedElimSort dt s = + if dtSort dt == propSort && s /= propSort then + length (dtCtors dt) == 1 + else True + + +-- | Build a 'Ctor' from a 'CtorArgStruct' and a list of the other constructor +-- names of the 'DataType'. Note that we cannot look up the latter information, +-- as 'scBuildCtor' is called during construction of the 'DataType'. +scBuildCtor :: SharedContext -> Ident -> Ident -> [Ident] -> + CtorArgStruct d params ixs -> + IO Ctor +scBuildCtor sc d c ctor_names arg_struct = + do + -- Step 1: build the types for the constructor and its eliminator + tp <- scShCtxM sc $ ctxCtorType d arg_struct + elim_tp_fun <- scShCtxM sc $ mkCtorElimTypeFun d c arg_struct + + -- Step 2: build free variables for params, p_ret, the elims, and the ctor + -- arguments + let num_params = bindingsLength $ ctorParams arg_struct + let num_args = + case arg_struct of + CtorArgStruct {..} -> bindingsLength ctorArgs + let total_vars_minus_1 = num_params + length ctor_names + num_args + vars <- reverse <$> mapM (scLocalVar sc) [0 .. total_vars_minus_1] + -- Step 3: pass these variables to ctxReduceRecursor to build the + -- ctorIotaReduction field + iota_red <- + scShCtxM sc $ + ctxReduceRecursor d (take num_params vars) (vars !! num_params) + (zip ctor_names (drop (num_params + 1) vars)) c + (drop (num_params + 1 + length ctor_names) vars) arg_struct + -- Finally, return the required Ctor record + return $ Ctor { ctorName = c, ctorArgStruct = arg_struct, + ctorDataTypeName = d, ctorType = tp, + ctorElimTypeFun = + (\ps p_ret -> scShCtxM sc $ elim_tp_fun ps p_ret), + ctorIotaReduction = iota_red } + +-- | Given a datatype @d@, parameters @p1,..,pn@ for @d@, and a "motive" +-- function @p_ret@ of type +-- +-- > (x1::ix1) -> .. -> (xm::ixm) -> d p1 .. pn x1 .. xm -> Type i +-- +-- that computes a return type from type indices for @d@ and an element of @d@ +-- for those indices, return the requires types of elimination functions for +-- each constructor of @d@. See the documentation of the 'Ctor' type and/or the +-- 'ctxCtorElimType' function for more details. +scRecursorElimTypes :: SharedContext -> Ident -> [Term] -> Term -> + IO [(Ident, Term)] +scRecursorElimTypes sc d_id params p_ret = + do d <- scRequireDataType sc d_id + forM (dtCtors d) $ \ctor -> + do elim_type <- ctorElimTypeFun ctor params p_ret >>= scWhnf sc + return (ctorName ctor, elim_type) + + +-- | Generate the type @(ix1::Ix1) -> .. -> (ixn::Ixn) -> d params ixs -> s@ +-- given @d@, @params@, and the sort @s@ +scRecursorRetTypeType :: SharedContext -> DataType -> [Term] -> Sort -> IO Term +scRecursorRetTypeType sc dt params s = + scShCtxM sc $ mkPRetTp (dtName dt) (dtParams dt) (dtIndices dt) params s + +-- | Reduce an application of a recursor. This is known in the Coq literature as +-- an iota reduction. More specifically, the call +-- +-- > scReduceRecursor sc d [p1, .., pn] P [(c1,f1), .., (cm,fm)] ci [x1, .., xk] +-- +-- reduces the term @(RecursorApp d ps P cs_fs ixs (CtorApp ci ps xs))@ to +-- +-- > fi x1 (maybe rec_tm_1) .. xk (maybe rec_tm_k) +-- +-- where @maybe rec_tm_i@ indicates an optional recursive call of the recursor +-- on one of the @xi@. These recursive calls only exist for those arguments +-- @xi@. See the documentation for 'ctxReduceRecursor' and the +-- 'ctorIotaReduction' field for more details. +scReduceRecursor :: SharedContext -> Ident -> [Term] -> Term -> + [(Ident,Term)] -> Ident -> [Term] -> IO Term +scReduceRecursor sc d params p_ret cs_fs c args = + do dt <- scRequireDataType sc d + -- This is to sort the eliminators by DataType order + elims <- + mapM (\c' -> case lookup (ctorName c') cs_fs of + Just elim -> return elim + Nothing -> + fail ("scReduceRecursor: no eliminator for constructor: " + ++ show c')) $ + dtCtors dt + ctor <- scRequireCtor sc c + -- The ctorIotaReduction field caches the result of iota reduction, which + -- we just substitute into to perform the reduction + instantiateVarList sc 0 (reverse $ params ++ [p_ret] ++ elims ++ args) + (ctorIotaReduction ctor) + + +-------------------------------------------------------------------------------- +-- Reduction to head-normal form + +-- | An elimination for 'scWhnf' +data WHNFElim + = ElimApp Term + | ElimProj FieldName + | ElimPair Bool + | ElimRecursor Ident [Term] Term [(Ident,Term)] [Term] + +-- | Test if a term is a constructor application that should be converted to a +-- natural number literal. Specifically, test if a term is not already a natural +-- number literal, but is 0 or more applications of the @Succ@ constructor to +-- either the @Zero@ constructor or a natural number literal +convertsToNat :: Term -> Maybe Natural +convertsToNat (asFTermF -> Just (NatLit _)) = Nothing +convertsToNat t = helper t where + helper (asFTermF -> Just (NatLit k)) = return k + helper (asCtor -> Just (z, [])) | z == preludeZeroIdent = return 0 + helper (asCtor -> Just (s, [t'])) | s == preludeSuccIdent = (1+) <$> helper t' + helper _ = Nothing + + +-- | Reduces beta-redexes, tuple/record selectors, recursor applications, and +-- definitions at the top level of a term, and evaluates all arguments to type +-- constructors (including function, record, and tuple types). +-- +-- NOTE: this notion of weak head normal form differs from the standard type +-- theory definition, in that it normalizes the arguments of type-forming +-- constructs like pi types, pair types, etc. The idea is that these constructs +-- are being treated as strict constructors in the Haskell sense. +scWhnf :: SharedContext -> Term -> IO Term +scWhnf sc t0 = + do cache <- newCacheIntMap + let ?cache = cache in memo t0 + where + memo :: (?cache :: Cache IO TermIndex Term) => Term -> IO Term + memo t = + case t of + Unshared _ -> go [] t + STApp { stAppIndex = i } -> useCache ?cache i (go [] t) + + go :: (?cache :: Cache IO TermIndex Term) => [WHNFElim] -> Term -> IO Term + go xs (convertsToNat -> Just k) = scFlatTermF sc (NatLit k) >>= go xs + go xs (asApp -> Just (t, x)) = go (ElimApp x : xs) t + go xs (asRecordSelector -> Just (t, n)) = go (ElimProj n : xs) t + go xs (asPairSelector -> Just (t, i)) = go (ElimPair i : xs) t + go (ElimApp x : xs) (asLambda -> Just (_, _, body)) = instantiateVar sc 0 x body >>= go xs + go (ElimPair i : xs) (asPairValue -> Just (a, b)) = go xs (if i then b else a) + go (ElimProj fld : xs) (asRecordValue -> Just elems) = case Map.lookup fld elems of + Just t -> go xs t + Nothing -> + error "scWhnf: field missing in record" + go (ElimRecursor d ps + p_ret cs_fs _ : xs) (asCtorOrNat -> + Just (c, _, args)) = (scReduceRecursor sc d ps + p_ret cs_fs c args) >>= go xs + + go xs (asGlobalDef -> Just c) = scRequireDef sc c >>= tryDef c xs + go xs (asRecursorApp -> + Just (d, params, p_ret, cs_fs, ixs, + arg)) = go (ElimRecursor d params p_ret + cs_fs ixs : xs) arg + go xs (asPairValue -> Just (a, b)) = do b' <- memo b + t' <- scPairValue sc a b' + foldM reapply t' xs + go xs (asPairType -> Just (a, b)) = do a' <- memo a + b' <- memo b + t' <- scPairType sc a' b' + foldM reapply t' xs + go xs (asRecordType -> Just elems) = do elems' <- + mapM (\(i,t) -> (i,) <$> memo t) (Map.assocs elems) + t' <- scRecordType sc elems' + foldM reapply t' xs + go xs (asPi -> Just (x,aty,rty)) = do aty' <- memo aty + rty' <- memo rty + t' <- scPi sc x aty' rty' + foldM reapply t' xs + go xs (asDataType -> Just (c,args)) = do args' <- mapM memo args + t' <- scDataTypeApp sc c args' + foldM reapply t' xs + go xs (asConstant -> Just (_,body)) = do go xs body + go xs t = foldM reapply t xs + + reapply :: Term -> WHNFElim -> IO Term + reapply t (ElimApp x) = scApply sc t x + reapply t (ElimProj i) = scRecordSelect sc t i + reapply t (ElimPair i) = scPairSelector sc t i + reapply t (ElimRecursor d ps p_ret cs_fs ixs) = + scFlatTermF sc (RecursorApp d ps p_ret cs_fs ixs t) + + tryDef :: (?cache :: Cache IO TermIndex Term) => + Ident -> [WHNFElim] -> Def -> IO Term + tryDef _ xs (Def {defBody = Just t}) = go xs t + tryDef ident xs _ = scGlobalDef sc ident >>= flip (foldM reapply) xs + + +-- | Test if two terms are convertible up to a given evaluation procedure. In +-- practice, this procedure is usually 'scWhnf', possibly combined with some +-- rewriting. +scConvertibleEval :: SharedContext + -> (SharedContext -> Term -> IO Term) + -> Bool -- ^ Should constants be unfolded during this check? + -> Term + -> Term + -> IO Bool +scConvertibleEval sc eval unfoldConst tm1 tm2 = do + c <- newCache + go c tm1 tm2 + + where whnf :: Cache IO TermIndex Term -> Term -> IO (TermF Term) + whnf _c t@(Unshared _) = unwrapTermF <$> eval sc t + whnf c t@(STApp{ stAppIndex = idx}) = + unwrapTermF <$> useCache c idx (eval sc t) + + go :: Cache IO TermIndex Term -> Term -> Term -> IO Bool + go _c (STApp{ stAppIndex = idx1}) (STApp{ stAppIndex = idx2}) + | idx1 == idx2 = return True -- succeed early case + go c t1 t2 = join (goF c <$> whnf c t1 <*> whnf c t2) + + goF :: Cache IO TermIndex Term -> TermF Term -> TermF Term -> IO Bool + + goF c (Constant _ x) y | unfoldConst = join (goF c <$> whnf c x <*> return y) + goF c x (Constant _ y) | unfoldConst = join (goF c <$> return x <*> whnf c y) + + goF c (FTermF ftf1) (FTermF ftf2) = + case zipWithFlatTermF (go c) ftf1 ftf2 of + Nothing -> return False + Just zipped -> Fold.and <$> traverse id zipped + + goF _c (LocalVar i) (LocalVar j) = return (i == j) + + goF c (App f1 x1) (App f2 x2) = + pure (&&) <*> go c f1 f2 <*> go c x1 x2 + + goF c (Lambda _ ty1 body1) (Lambda _ ty2 body2) = + pure (&&) <*> go c ty1 ty2 <*> go c body1 body2 + + goF c (Pi _ ty1 body1) (Pi _ ty2 body2) = + pure (&&) <*> go c ty1 ty2 <*> go c body1 body2 + + -- final catch-all case + goF _c x y = return $ alphaEquiv (Unshared x) (Unshared y) + + +-- | Test if two terms are convertible using 'scWhnf' for evaluation +scConvertible :: SharedContext + -> Bool -- ^ Should constants be unfolded during this check? + -> Term + -> Term + -> IO Bool +scConvertible sc = scConvertibleEval sc scWhnf + + +-------------------------------------------------------------------------------- +-- Type checking + +-- | @reducePi sc (Pi x tp body) t@ returns @[t/x]body@, and otherwise fails +reducePi :: SharedContext -> Term -> Term -> IO Term +reducePi sc t arg = do + t' <- scWhnf sc t + case asPi t' of + Just (_, _, body) -> instantiateVar sc 0 arg body + _ -> + fail $ unlines ["reducePi: not a Pi term", showTerm t'] + +-- | Compute the type of a global variable. +scTypeOfGlobal :: SharedContext -> Ident -> IO Term +scTypeOfGlobal sc ident = + defType <$> scRequireDef sc ident + +-- | Compute the type of a datatype given its name as an 'Ident'. +scTypeOfDataType :: SharedContext -> Ident -> IO Term +scTypeOfDataType sc ident = + dtType <$> scRequireDataType sc ident + +-- | Compute the type of a data constructor given its name as an 'Ident'. +scTypeOfCtor :: SharedContext -> Ident -> IO Term +scTypeOfCtor sc ident = + ctorType <$> scRequireCtor sc ident + +-- | Computes the type of a term as quickly as possible, assuming that +-- the term is well-typed. +scTypeOf :: SharedContext -> Term -> IO Term +scTypeOf sc t0 = scTypeOf' sc [] t0 + +-- | A version for open terms; the list argument encodes the type environment. +scTypeOf' :: SharedContext -> [Term] -> Term -> IO Term +scTypeOf' sc env t0 = State.evalStateT (memo t0) Map.empty + where + memo :: Term -> State.StateT (Map TermIndex Term) IO Term + memo (Unshared t) = termf t + memo STApp{ stAppIndex = i, stAppTermF = t} = do + table <- State.get + case Map.lookup i table of + Just x -> return x + Nothing -> do + x <- termf t + State.modify (Map.insert i x) + return x + toSort :: Term -> State.StateT (Map TermIndex Term) IO Sort + toSort t = + do t' <- liftIO (scWhnf sc t) + case asSort t' of + Just s -> return s + Nothing -> fail "scTypeOf: type error: expected sort" + sort :: Term -> State.StateT (Map TermIndex Term) IO Sort + sort t = toSort =<< memo t + termf :: TermF Term -> State.StateT (Map TermIndex Term) IO Term + termf tf = + case tf of + FTermF ftf -> ftermf ftf + App x y -> do + tx <- memo x + lift $ reducePi sc tx y + Lambda name tp rhs -> do + rtp <- lift $ scTypeOf' sc (tp : env) rhs + lift $ scTermF sc (Pi name tp rtp) + Pi _ tp rhs -> do + ltp <- sort tp + rtp <- toSort =<< lift (scTypeOf' sc (tp : env) rhs) + + -- NOTE: the rule for type-checking Pi types is that (Pi x a b) is a Prop + -- when b is a Prop (this is a forall proposition), otherwise it is a + -- (Type (max (sortOf a) (sortOf b))) + let srt = if rtp == propSort then propSort else max ltp rtp + + lift $ scSort sc srt + LocalVar i + | i < length env -> lift $ incVars sc 0 (i + 1) (env !! i) + | otherwise -> fail $ "Dangling bound variable: " ++ show (i - length env) + Constant ec _ -> return (ecType ec) + ftermf :: FlatTermF Term + -> State.StateT (Map TermIndex Term) IO Term + ftermf tf = + case tf of + Primitive ec -> return $ ecType ec + UnitValue -> lift $ scUnitType sc + UnitType -> lift $ scSort sc (mkSort 0) + PairValue x y -> do + tx <- memo x + ty <- memo y + lift $ scPairType sc tx ty + PairType x y -> do + sx <- sort x + sy <- sort y + lift $ scSort sc (max sx sy) + PairLeft t -> do + tp <- (liftIO . scWhnf sc) =<< memo t + case asPairType tp of + Just (t1, _) -> return t1 + Nothing -> fail "scTypeOf: type error: expected pair type" + PairRight t -> do + tp <- (liftIO . scWhnf sc) =<< memo t + case asPairType tp of + Just (_, t2) -> return t2 + Nothing -> fail "scTypeOf: type error: expected pair type" + CtorApp c params args -> do + t <- lift $ scTypeOfCtor sc c + lift $ foldM (reducePi sc) t (params ++ args) + DataTypeApp dt params args -> do + t <- lift $ scTypeOfDataType sc dt + lift $ foldM (reducePi sc) t (params ++ args) + RecursorApp _ _ p_ret _ ixs arg -> + lift $ scApplyAll sc p_ret (ixs ++ [arg]) + RecordType elems -> + do max_s <- maximum <$> mapM (sort . snd) elems + lift $ scSort sc max_s + RecordValue elems -> + do elem_tps <- mapM (\(fld,t) -> (fld,) <$> memo t) elems + lift $ scRecordType sc elem_tps + RecordProj t fld -> + do tp <- (liftIO . scWhnf sc) =<< memo t + case asRecordType tp of + Just (Map.lookup fld -> Just f_tp) -> return f_tp + Just _ -> fail "Record field not in record type" + Nothing -> fail "Record project of non-record type" + Sort s -> lift $ scSort sc (sortOf s) + NatLit _ -> lift $ scNatType sc + ArrayValue tp vs -> lift $ do + n <- scNat sc (fromIntegral (V.length vs)) + scVecType sc n tp + StringLit{} -> lift $ scStringType sc + ExtCns ec -> return $ ecType ec + +-------------------------------------------------------------------------------- + +-- | The inverse function to @scSharedTerm@. +unshare :: Term -> Term +unshare t0 = State.evalState (go t0) Map.empty + where + go :: Term -> State.State (Map TermIndex Term) Term + go (Unshared t) = Unshared <$> traverse go t + go (STApp{ stAppIndex = i, stAppTermF = t}) = do + memo <- State.get + case Map.lookup i memo of + Just x -> return x + Nothing -> do + x <- Unshared <$> traverse go t + State.modify (Map.insert i x) + return x + +-- | Perform hash-consing at every AST node to obtain maximal sharing. +-- +-- FIXME: this should no longer be needed, since it was added to deal with the +-- fact that SAWCore files used to build all their terms as 'Unshared' terms, +-- but that is no longer how we are doing things... +scSharedTerm :: SharedContext -> Term -> IO Term +scSharedTerm sc = go + where go t = scTermF sc =<< traverse go (unwrapTermF t) + +-- | Imports a term built in a different shared context into the given +-- shared context. The caller must ensure that all the global constants +-- appearing in the term are valid in the new context. +scImport :: SharedContext -> Term -> IO Term +scImport sc t0 = + do cache <- newCache + go cache t0 + where + go :: Cache IO TermIndex Term -> Term -> IO Term + go cache (Unshared tf) = + Unshared <$> traverse (go cache) tf + go cache (STApp{ stAppIndex = idx, stAppTermF = tf}) = + useCache cache idx (scTermF sc =<< traverse (go cache) tf) + +-------------------------------------------------------------------------------- +-- Instantiating variables + +-- | The second argument is a function that takes the number of +-- enclosing lambdas and the de Bruijn index of the variable, +-- returning the new term to replace it with. +instantiateLocalVars :: + SharedContext -> + (DeBruijnIndex -> DeBruijnIndex -> IO Term) -> + DeBruijnIndex -> Term -> IO Term +instantiateLocalVars sc f initialLevel t0 = + do cache <- newCache + let ?cache = cache in go initialLevel t0 + where + go :: (?cache :: Cache IO (TermIndex, DeBruijnIndex) Term) => + DeBruijnIndex -> Term -> IO Term + go l t = + case t of + Unshared tf -> go' l tf + STApp{ stAppIndex = tidx, stAppFreeVars = fv, stAppTermF = tf} + | fv == emptyBitSet -> return t -- closed terms map to themselves + | otherwise -> useCache ?cache (tidx, l) (go' l tf) + + go' :: (?cache :: Cache IO (TermIndex, DeBruijnIndex) Term) => + DeBruijnIndex -> TermF Term -> IO Term + go' _ (FTermF tf@(ExtCns _)) = scFlatTermF sc tf + go' l (FTermF tf) = scFlatTermF sc =<< (traverse (go l) tf) + go' l (App x y) = scTermF sc =<< (App <$> go l x <*> go l y) + go' l (Lambda i tp rhs) = scTermF sc =<< (Lambda i <$> go l tp <*> go (l+1) rhs) + go' l (Pi i lhs rhs) = scTermF sc =<< (Pi i <$> go l lhs <*> go (l+1) rhs) + go' l (LocalVar i) + | i < l = scTermF sc (LocalVar i) + | otherwise = f l i + go' _ tf@(Constant {}) = scTermF sc tf + +instantiateVars :: SharedContext + -> (DeBruijnIndex -> Either (ExtCns Term) DeBruijnIndex -> IO Term) + -> DeBruijnIndex -> Term -> IO Term +instantiateVars sc f initialLevel t0 = + do cache <- newCache + let ?cache = cache in go initialLevel t0 + where + go :: (?cache :: Cache IO (TermIndex, DeBruijnIndex) Term) => + DeBruijnIndex -> Term -> IO Term + go l (Unshared tf) = + go' l tf + go l (STApp{ stAppIndex = tidx, stAppTermF = tf}) = + useCache ?cache (tidx, l) (go' l tf) + + go' :: (?cache :: Cache IO (TermIndex, DeBruijnIndex) Term) => + DeBruijnIndex -> TermF Term -> IO Term + go' l (FTermF (ExtCns ec)) = f l (Left ec) + go' l (FTermF tf) = scFlatTermF sc =<< (traverse (go l) tf) + go' l (App x y) = scTermF sc =<< (App <$> go l x <*> go l y) + go' l (Lambda i tp rhs) = scTermF sc =<< (Lambda i <$> go l tp <*> go (l+1) rhs) + go' l (Pi i lhs rhs) = scTermF sc =<< (Pi i <$> go l lhs <*> go (l+1) rhs) + go' l (LocalVar i) + | i < l = scTermF sc (LocalVar i) + | otherwise = f l (Right i) + go' _ tf@(Constant {}) = scTermF sc tf + +-- | @incVars k j t@ increments free variables at least @k@ by @j@. +-- e.g., incVars 1 2 (C ?0 ?1) = C ?0 ?3 +incVars :: SharedContext + -> DeBruijnIndex -> DeBruijnIndex -> Term -> IO Term +incVars sc initialLevel j + | j == 0 = return + | otherwise = instantiateLocalVars sc fn initialLevel + where + fn _ i = scTermF sc (LocalVar (i+j)) + +-- | Substitute @t0@ for variable @k@ in @t@ and decrement all higher +-- dangling variables. +instantiateVar :: SharedContext + -> DeBruijnIndex -> Term -> Term -> IO Term +instantiateVar sc k t0 t = + do cache <- newCache + let ?cache = cache in instantiateLocalVars sc fn k t + where -- Use map reference to memoize instantiated versions of t. + term :: (?cache :: Cache IO DeBruijnIndex Term) => + DeBruijnIndex -> IO Term + term i = useCache ?cache i (incVars sc 0 i t0) + -- Instantiate variable 0. + fn :: (?cache :: Cache IO DeBruijnIndex Term) => + DeBruijnIndex -> DeBruijnIndex -> IO Term + fn i j | j > i = scTermF sc (LocalVar (j - 1)) + | j == i = term i + | otherwise = scTermF sc (LocalVar j) + +-- | Substitute @ts@ for variables @[k .. k + length ts - 1]@ and decrement all +-- higher deBruijn indices by @length ts@. Assume that deBruijn index 0 in @ts@ +-- refers to deBruijn index @k + length ts@ in the current term; i.e., this +-- substitution lifts terms in @ts@ by @k@ (plus any additional binders). +-- +-- For example, @instantiateVarList 0 [x,y,z] t@ is the beta-reduced form of +-- +-- > Lam (Lam (Lam t)) `App` z `App` y `App` x +-- +-- Note that the first element of the @ts@ list corresponds to @x@, which is the +-- outermost, or last, application. In terms of 'instantiateVar', we can write +-- this as: +-- +-- > instantiateVarList 0 [x,y,z] t == +-- > instantiateVar 0 x (instantiateVar 1 (incVars 0 1 y) +-- > (instantiateVar 2 (incVars 0 2 z) t)) +instantiateVarList :: SharedContext + -> DeBruijnIndex -> [Term] -> Term -> IO Term +instantiateVarList _ _ [] t = return t +instantiateVarList sc k ts t = + do caches <- mapM (const newCache) ts + instantiateLocalVars sc (fn (zip caches ts)) k t + where + l = length ts + -- Memoize instantiated versions of ts. + term :: (Cache IO DeBruijnIndex Term, Term) + -> DeBruijnIndex -> IO Term + term (cache, x) i = useCache cache i (incVars sc 0 (i-k) x) + -- Instantiate variables [k .. k+l-1]. + fn :: [(Cache IO DeBruijnIndex Term, Term)] + -> DeBruijnIndex -> DeBruijnIndex -> IO Term + fn rs i j | j >= i + l = scTermF sc (LocalVar (j - l)) + | j >= i = term (rs !! (j - i)) i + | otherwise = scTermF sc (LocalVar j) + + +-------------------------------------------------------------------------------- +-- Beta Normalization + +-- | Beta-reduce a term to normal form. +betaNormalize :: SharedContext -> Term -> IO Term +betaNormalize sc t0 = + do cache <- newCache + let ?cache = cache in go t0 + where + go :: (?cache :: Cache IO TermIndex Term) => Term -> IO Term + go t = case t of + Unshared _ -> go' t + STApp{ stAppIndex = i } -> useCache ?cache i (go' t) + + go' :: (?cache :: Cache IO TermIndex Term) => Term -> IO Term + go' t = do + let (f, args) = asApplyAll t + let (params, body) = asLambdaList f + let n = length (zip args params) + if n == 0 then go3 t else do + body' <- go body + f' <- scLambdaList sc (drop n params) body' + args' <- mapM go args + f'' <- instantiateVarList sc 0 (reverse (take n args')) f' + scApplyAll sc f'' (drop n args') + + go3 :: (?cache :: Cache IO TermIndex Term) => Term -> IO Term + go3 (Unshared tf) = Unshared <$> traverseTF go tf + go3 (STApp{ stAppTermF = tf }) = scTermF sc =<< traverseTF go tf + + traverseTF :: (a -> IO a) -> TermF a -> IO (TermF a) + traverseTF _ tf@(Constant {}) = pure tf + traverseTF f tf = traverse f tf + + +-------------------------------------------------------------------------------- +-- Building shared terms + +-- | Apply a function 'Term' to zero or more argument 'Term's. +scApplyAll :: SharedContext -> Term -> [Term] -> IO Term +scApplyAll sc = foldlM (scApply sc) + +-- | Returns the defined constant with the given 'Ident'. Fails if no +-- such constant exists in the module. +scLookupDef :: SharedContext -> Ident -> IO Term +scLookupDef sc ident = scGlobalDef sc ident --FIXME: implement module check. + +-- | Deprecated. Use scGlobalDef or scLookupDef instead. +scDefTerm :: SharedContext -> Def -> IO Term +scDefTerm sc d = scGlobalDef sc (defIdent d) + +-- TODO: implement version of scCtorApp that looks up the arity of the +-- constructor identifier in the module. + +-- | Deprecated. Use scCtorApp instead. +scApplyCtor :: SharedContext -> Ctor -> [Term] -> IO Term +scApplyCtor sc c args = scCtorApp sc (ctorName c) args + +-- | Create a term from a 'Sort'. +scSort :: SharedContext -> Sort -> IO Term +scSort sc s = scFlatTermF sc (Sort s) + +-- | Create a literal term from a 'Natural'. +scNat :: SharedContext -> Natural -> IO Term +scNat sc n = scFlatTermF sc (NatLit n) + +-- | Create a literal term (of saw-core type @String@) from a 'String'. +scString :: SharedContext -> Text -> IO Term +scString sc s = scFlatTermF sc (StringLit s) + +-- | Create a term representing the primitive saw-core type @String@. +scStringType :: SharedContext -> IO Term +scStringType sc = scGlobalDef sc preludeStringIdent + +-- | Create a vector term from a type (as a 'Term') and a list of 'Term's of +-- that type. +scVector :: SharedContext -> Term -> [Term] -> IO Term +scVector sc e xs = scFlatTermF sc (ArrayValue e (V.fromList xs)) + +-- | Create a record term from a 'Map' from 'FieldName's to 'Term's. +scRecord :: SharedContext -> Map FieldName Term -> IO Term +scRecord sc m = scFlatTermF sc (RecordValue $ Map.assocs m) + +-- | Create a record field access term from a 'Term' representing a record and +-- a 'FieldName'. +scRecordSelect :: SharedContext -> Term -> FieldName -> IO Term +scRecordSelect sc t fname = scFlatTermF sc (RecordProj t fname) + +-- | Create a term representing the type of a record from a list associating +-- field names (as 'FieldName's) and types (as 'Term's). Note that the order of +-- the given list is irrelevant, as record fields are not ordered. +scRecordType :: SharedContext -> [(FieldName, Term)] -> IO Term +scRecordType sc elem_tps = scFlatTermF sc (RecordType elem_tps) + +-- | Create a unit-valued term. +scUnitValue :: SharedContext -> IO Term +scUnitValue sc = scFlatTermF sc UnitValue + +-- | Create a term representing the unit type. +scUnitType :: SharedContext -> IO Term +scUnitType sc = scFlatTermF sc UnitType + +-- | Create a pair term from two terms. +scPairValue :: SharedContext + -> Term -- ^ The left projection + -> Term -- ^ The right projection + -> IO Term +scPairValue sc x y = scFlatTermF sc (PairValue x y) + +-- | Create a term representing a pair type from two other terms, each +-- representing a type. +scPairType :: SharedContext + -> Term -- ^ Left projection type + -> Term -- ^ Right projection type + -> IO Term +scPairType sc x y = scFlatTermF sc (PairType x y) + +-- | Create an n-place tuple from a list (of length n) of 'Term's. +-- Note that tuples are nested pairs, associating to the right e.g. +-- @(a, (b, (c, d)))@. +scTuple :: SharedContext -> [Term] -> IO Term +scTuple sc [] = scUnitValue sc +scTuple _ [t] = return t +scTuple sc (t : ts) = scPairValue sc t =<< scTuple sc ts + +-- | Create a term representing the type of an n-place tuple, from a list +-- (of length n) of 'Term's, each representing a type. +scTupleType :: SharedContext -> [Term] -> IO Term +scTupleType sc [] = scUnitType sc +scTupleType _ [t] = return t +scTupleType sc (t : ts) = scPairType sc t =<< scTupleType sc ts + +-- | Create a term giving the left projection of a 'Term' representing a pair. +scPairLeft :: SharedContext -> Term -> IO Term +scPairLeft sc t = scFlatTermF sc (PairLeft t) + +-- | Create a term giving the right projection of a 'Term' representing a pair. +scPairRight :: SharedContext -> Term -> IO Term +scPairRight sc t = scFlatTermF sc (PairRight t) + +-- | Create a term representing either the left or right projection of the +-- given 'Term', depending on the given 'Bool': left if @False@, right if @True@. +scPairSelector :: SharedContext -> Term -> Bool -> IO Term +scPairSelector sc t False = scPairLeft sc t +scPairSelector sc t True = scPairRight sc t + +-- | @scTupleSelector sc t i n@ returns a term selecting the @i@th component of +-- an @n@-place tuple 'Term', @t@. +scTupleSelector :: + SharedContext -> Term -> + Int {- ^ 1-based index -} -> + Int {- ^ tuple size -} -> + IO Term +scTupleSelector sc t i n + | n == 1 = return t + | i == 1 = scPairLeft sc t + | i > 1 = do t' <- scPairRight sc t + scTupleSelector sc t' (i - 1) (n - 1) + | otherwise = fail "scTupleSelector: non-positive index" + +-- | Create a term representing the type of a non-dependent function, given a +-- parameter and result type (as 'Term's). +scFun :: SharedContext + -> Term -- ^ The parameter type + -> Term -- ^ The result type + -> IO Term +scFun sc a b = do b' <- incVars sc 0 1 b + scTermF sc (Pi "_" a b') + +-- | Create a term representing the type of a non-dependent n-ary function, +-- given a list of parameter types and a result type (as terms). +scFunAll :: SharedContext + -> [Term] -- ^ The parameter types + -> Term -- ^ The result type + -> IO Term +scFunAll sc argTypes resultType = foldrM (scFun sc) resultType argTypes + +-- | Create a lambda term from a parameter name (as a 'String'), parameter type +-- (as a 'Term'), and a body. Regarding deBruijn indices, in the body of the +-- function, an index of 0 refers to the bound parameter. +scLambda :: SharedContext + -> LocalName -- ^ The parameter name + -> Term -- ^ The parameter type + -> Term -- ^ The body + -> IO Term +scLambda sc varname ty body = scTermF sc (Lambda varname ty body) + +-- | Create a lambda term of multiple arguments (curried) from a list +-- associating parameter names to types (as 'Term's) and a body. As for +-- 'scLambda', there is a convention for deBruijn indices: 0 refers to the last +-- parameter in the list, and n-1 (where n is the list length) refers to the +-- first. +scLambdaList :: SharedContext + -> [(LocalName, Term)] -- ^ List of parameter / parameter type pairs + -> Term -- ^ The body + -> IO Term +scLambdaList _ [] rhs = return rhs +scLambdaList sc ((nm,tp):r) rhs = + scLambda sc nm tp =<< scLambdaList sc r rhs + +-- | Create a (possibly dependent) function given a parameter name, parameter +-- type (as a 'Term'), and a body. This function follows the same deBruijn +-- index convention as 'scLambda'. +scPi :: SharedContext + -> LocalName -- ^ The parameter name + -> Term -- ^ The parameter type + -> Term -- ^ The body + -> IO Term +scPi sc nm tp body = scTermF sc (Pi nm tp body) + +-- | Create a (possibly dependent) function of multiple arguments (curried) +-- from a list associating parameter names to types (as 'Term's) and a body. +-- This function follows the same deBruijn index convention as 'scLambdaList'. +scPiList :: SharedContext + -> [(LocalName, Term)] -- ^ List of parameter / parameter type pairs + -> Term -- ^ The body + -> IO Term +scPiList _ [] rhs = return rhs +scPiList sc ((nm,tp):r) rhs = scPi sc nm tp =<< scPiList sc r rhs + +-- | Create a local variable term from a 'DeBruijnIndex'. +scLocalVar :: SharedContext + -> DeBruijnIndex + -> IO Term +scLocalVar sc i = scTermF sc (LocalVar i) + +-- | Create an abstract constant with the specified name, body, and +-- type. The term for the body must not have any loose de Bruijn +-- indices. If the body contains any ExtCns variables, they will be +-- abstracted over and reapplied to the resulting constant. +scConstant :: SharedContext + -> String -- ^ The name + -> Term -- ^ The body + -> Term -- ^ The type + -> IO Term +scConstant sc name rhs ty = + do unless (looseVars rhs == emptyBitSet) $ + fail "scConstant: term contains loose variables" + let ecs = getAllExts rhs + rhs' <- scAbstractExts sc ecs rhs + ty' <- scFunAll sc (map ecType ecs) ty + ec <- scFreshEC sc name ty' + t <- scTermF sc (Constant ec rhs') + args <- mapM (scFlatTermF sc . ExtCns) ecs + scApplyAll sc t args + + +-- | Create an abstract constant with the specified name, body, and +-- type. The term for the body must not have any loose de Bruijn +-- indices. If the body contains any ExtCns variables, they will be +-- abstracted over and reapplied to the resulting constant. +scConstant' :: SharedContext + -> NameInfo -- ^ The name + -> Term -- ^ The body + -> Term -- ^ The type + -> IO Term +scConstant' sc nmi rhs ty = + do unless (looseVars rhs == emptyBitSet) $ + fail "scConstant: term contains loose variables" + let ecs = getAllExts rhs + rhs' <- scAbstractExts sc ecs rhs + ty' <- scFunAll sc (map ecType ecs) ty + i <- scFreshGlobalVar sc + scRegisterName sc i nmi + let ec = EC i nmi ty' + t <- scTermF sc (Constant ec rhs') + args <- mapM (scFlatTermF sc . ExtCns) ecs + scApplyAll sc t args + + +-- | Create a function application term from a global identifier and a list of +-- arguments (as 'Term's). +scGlobalApply :: SharedContext -> Ident -> [Term] -> IO Term +scGlobalApply sc i ts = + do c <- scGlobalDef sc i + scApplyAll sc c ts + +-- | An optimized variant of 'scPairValue' that will reduce pairs of +-- the form @(x.L, x.R)@ to @x@. +scPairValueReduced :: SharedContext -> Term -> Term -> IO Term +scPairValueReduced sc x y = + case (unwrapTermF x, unwrapTermF y) of + (FTermF (PairLeft a), FTermF (PairRight b)) | a == b -> return a + _ -> scPairValue sc x y + +-- | An optimized variant of 'scPairTuple' that will reduce tuples of +-- the form @(x.1, x.2, x.3)@ to @x@. +scTupleReduced :: SharedContext -> [Term] -> IO Term +scTupleReduced sc [] = scUnitValue sc +scTupleReduced _ [t] = return t +scTupleReduced sc (t : ts) = scPairValueReduced sc t =<< scTupleReduced sc ts + +-- | An optimized variant of 'scVector' that will reduce vectors of +-- the form @[at x 0, at x 1, at x 2, at x 3]@ to just @x@. +scVectorReduced :: SharedContext -> Term {- ^ element type -} -> [Term] {- ^ elements -} -> IO Term +scVectorReduced sc ety xs + | (hd : _) <- xs + , Just ((arr_sz :*: arr_tm) :*: 0) <- asAtOrBvAt hd + , fromIntegral (length xs) == arr_sz + , iall (\i x -> asAtOrBvAt x == Just ((arr_sz :*: arr_tm) :*: fromIntegral i)) xs = + return arr_tm + | otherwise = scVector sc ety xs + where + asAny :: Term -> Maybe () + asAny _ = Just () + + asAt :: Term -> Maybe ((Natural :*: Term) :*: Natural) + asAt = (((isGlobalDef "Prelude.at" @> asNat) <@ asAny) <@> return) <@> asNat + + asBvAt :: Term -> Maybe ((Natural :*: Term) :*: Natural) + asBvAt = ((((isGlobalDef "Prelude.bvAt" @> asNat) <@ asAny) <@ asAny) <@> return) <@> asUnsignedConcreteBv + + asAtOrBvAt :: Term -> Maybe ((Natural :*: Term) :*: Natural) + asAtOrBvAt term + | res@Just{} <- asAt term = res + | res@Just{} <- asBvAt term = res + | otherwise = Nothing + +------------------------------------------------------------ +-- Building terms using prelude functions + +-- | Create a term applying @Prelude.EqTrue@ to the given term. +-- +-- > EqTrue : Bool -> sort 1; +scEqTrue :: SharedContext -> Term -> IO Term +scEqTrue sc t = scGlobalApply sc "Prelude.EqTrue" [t] + +-- | Create a @Prelude.Bool@-typed term from the given Boolean: @Prelude.True@ +-- for @True@, @Prelude.False@ for @False@. +scBool :: SharedContext -> Bool -> IO Term +scBool sc True = scGlobalDef sc "Prelude.True" +scBool sc False = scGlobalDef sc "Prelude.False" + +-- | Create a term representing the prelude Boolean type, @Prelude.Bool@. +scBoolType :: SharedContext -> IO Term +scBoolType sc = scGlobalDef sc "Prelude.Bool" + +-- | Create a term representing the prelude Natural type. +scNatType :: SharedContext -> IO Term +scNatType sc = scFlatTermF sc preludeNatType + +-- | Create a term representing a vector type, from a term giving the length +-- and a term giving the element type. +scVecType :: SharedContext + -> Term -- ^ The length of the vector + -> Term -- ^ The element type + -> IO Term +scVecType sc n e = scGlobalApply sc preludeVecIdent [n, e] + +-- | Create a term applying @Prelude.not@ to the given term. +-- +-- > not : Bool -> Bool; +scNot :: SharedContext -> Term -> IO Term +scNot sc t = scGlobalApply sc "Prelude.not" [t] + +-- | Create a term applying @Prelude.and@ to the two given terms. +-- +-- > and : Bool -> Bool -> Bool; +scAnd :: SharedContext -> Term -> Term -> IO Term +scAnd sc x y = scGlobalApply sc "Prelude.and" [x,y] + +-- | Create a term applying @Prelude.or@ to the two given terms. +-- +-- > or : Bool -> Bool -> Bool; +scOr :: SharedContext -> Term -> Term -> IO Term +scOr sc x y = scGlobalApply sc "Prelude.or" [x,y] + +-- | Create a term applying @Prelude.implies@ to the two given terms. +-- +-- > implies : Bool -> Bool -> Bool; +scImplies :: SharedContext -> Term -> Term + -> IO Term +scImplies sc x y = scGlobalApply sc "Prelude.implies" [x,y] + +-- | Create a term applying @Prelude.xor@ to the two given terms. +-- +-- > xor : Bool -> Bool -> Bool; +scXor :: SharedContext -> Term -> Term -> IO Term +scXor sc x y = scGlobalApply sc "Prelude.xor" [x,y] + +-- | Create a term applying @Prelude.boolEq@ to the two given terms. +-- +-- > boolEq : Bool -> Bool -> Bool; +scBoolEq :: SharedContext -> Term -> Term -> IO Term +scBoolEq sc x y = scGlobalApply sc "Prelude.boolEq" [x,y] + +-- | Create a universally quantified bitvector term. +-- +-- > bvForall : (n : Nat) -> (Vec n Bool -> Bool) -> Bool; +scBvForall :: SharedContext -> Term -> Term -> IO Term +scBvForall sc w f = scGlobalApply sc "Prelude.bvForall" [w, f] + +-- | Create a non-dependent if-then-else term. +-- +-- > ite : (a : sort 1) -> Bool -> a -> a -> a; +scIte :: SharedContext -> Term -> Term -> + Term -> Term -> IO Term +scIte sc t b x y = scGlobalApply sc "Prelude.ite" [t, b, x, y] + +-- | Create a term applying @Prelude.append@ to two vectors. +-- +-- > append : (m n : Nat) -> (e : sort 0) -> Vec m e -> Vec n e -> Vec (addNat m n) e; +scAppend :: SharedContext -> Term -> Term -> Term -> + Term -> Term -> IO Term +scAppend sc t m n x y = scGlobalApply sc "Prelude.append" [m, n, t, x, y] + +-- | Create a term applying @Prelude.join@ to a vector of vectors. +-- +-- > join : (m n : Nat) -> (a : sort 0) -> Vec m (Vec n a) -> Vec (mulNat m n) a; +scJoin :: SharedContext -> Term -> Term -> Term -> Term -> IO Term +scJoin sc m n a v = scGlobalApply sc "Prelude.join" [m, n, a, v] + +-- | Create a term splitting a vector with @Prelude.split@. +-- +-- > split : (m n : Nat) -> (a : sort 0) -> Vec (mulNat m n) a -> Vec m (Vec n a); +scSplit :: SharedContext -> Term -> Term -> Term -> Term -> IO Term +scSplit sc m n a v = scGlobalApply sc "Prelude.split" [m, n, a, v] + +-- | Create a term selecting a range of values from a vector with @Prelude.slice@. +-- +-- > slice : (e : sort 1) -> (i n o : Nat) -> Vec (addNat (addNat i n) o) e -> Vec n e; +scSlice :: SharedContext -> Term -> Term -> + Term -> Term -> Term -> IO Term +scSlice sc e i n o a = scGlobalApply sc "Prelude.slice" [e, i, n, o, a] + +-- | Create a term accessing a particular element of a vector with @get@. +-- +-- > get : (n : Nat) -> (e : sort 0) -> Vec n e -> Fin n -> e; +scGet :: SharedContext -> Term -> Term -> + Term -> Term -> IO Term +scGet sc n e v i = scGlobalApply sc (mkIdent preludeName "get") [n, e, v, i] + +-- | Create a term accessing a particular element of a vector with @bvAt@, +-- which uses a bitvector for indexing. +-- +-- > bvAt : (n : Nat) -> (a : sort 0) -> (w : Nat) -> Vec n a -> Vec w Bool -> a; +scBvAt :: SharedContext -> Term -> Term -> + Term -> Term -> Term -> IO Term +scBvAt sc n a i xs idx = scGlobalApply sc (mkIdent preludeName "bvAt") [n, a, i, xs, idx] + +-- | Create a term accessing a particular element of a vector, with a default +-- to return if the index is out of bounds. +-- +-- > atWithDefault : (n : Nat) -> (a : sort 0) -> a -> Vec n a -> Nat -> a; +scAtWithDefault :: SharedContext -> Term -> Term -> Term -> Term -> Term -> IO Term +scAtWithDefault sc n a v xs idx = scGlobalApply sc (mkIdent preludeName "atWithDefault") [n, a, v, xs, idx] + +-- | Create a term accessing a particular element of a vector, failing if the +-- index is out of bounds. +-- +-- > at : (n : Nat) -> (a : sort 0) -> Vec n a -> Nat -> a; +scAt :: SharedContext -> Term -> Term -> + Term -> Term -> IO Term +scAt sc n a xs idx = scGlobalApply sc (mkIdent preludeName "at") [n, a, xs, idx] + +-- | Create a term evaluating to a vector containing a single element. +-- +-- > single : (e : sort 1) -> e -> Vec 1 e; +scSingle :: SharedContext -> Term -> Term -> IO Term +scSingle sc e x = scGlobalApply sc (mkIdent preludeName "single") [e, x] + +-- | Create a term computing the least significant bit of a bitvector, given a +-- length and bitvector. +-- +-- > lsb : (n : Nat) -> Vec (Succ n) Bool -> Bool; +scLsb :: SharedContext -> Term -> Term -> IO Term +scLsb sc n x = scGlobalApply sc (mkIdent preludeName "lsb") [n, x] + +-- | Create a term computing the most significant bit of a bitvector, given a +-- length and bitvector. +-- +-- > msb : (n : Nat) -> Vec (Succ n) Bool -> Bool; +scMsb :: SharedContext -> Term -> Term -> IO Term +scMsb sc n x = scGlobalApply sc (mkIdent preludeName "lsb") [n, x] + +-- Primitive operations on nats + +-- | Create a term computing the sum of the two given (natural number) terms. +-- +-- > addNat : Nat -> Nat -> Nat; +scAddNat :: SharedContext -> Term -> Term -> IO Term +scAddNat sc x y = scGlobalApply sc "Prelude.addNat" [x,y] + +-- | Create a term computing the difference between the two given +-- (natural number) terms. +-- +-- > subNat : Nat -> Nat -> Nat +scSubNat :: SharedContext -> Term -> Term -> IO Term +scSubNat sc x y = scGlobalApply sc "Prelude.subNat" [x,y] + +-- | Create a term computing the product of the two given (natural number) +-- terms. +-- +-- > mulNat : Nat -> Nat -> Nat; +scMulNat :: SharedContext -> Term -> Term -> IO Term +scMulNat sc x y = scGlobalApply sc "Prelude.mulNat" [x,y] + +-- | Create a term computing the quotient of the two given (natural number) +-- terms. +-- +-- > divNat : Nat -> Nat -> Nat; +scDivNat :: SharedContext -> Term -> Term -> IO Term +scDivNat sc x y = scGlobalApply sc "Prelude.divNat" [x,y] + +-- | Create a term computing the remainder upon division of the two given +-- (natural number) terms. +-- +-- > modNat : Nat -> Nat -> Nat; +scModNat :: SharedContext -> Term -> Term -> IO Term +scModNat sc x y = scGlobalApply sc "Prelude.modNat" [x,y] + +-- | Create a term computing the quotient and remainder upon division of the +-- two given (natural number) terms, giving the result as a pair. +-- +-- > divModNat : Nat -> Nat -> Nat * Nat; +scDivModNat :: SharedContext -> Term -> Term -> IO Term +scDivModNat sc x y = scGlobalApply sc "Prelude.divModNat" [x,y] + +-- | Create a term computing whether the two given (natural number) terms are +-- equal. +-- +-- > equalNat : Nat -> Nat -> Bool; +scEqualNat :: SharedContext -> Term -> Term -> IO Term +scEqualNat sc x y = scGlobalApply sc "Prelude.equalNat" [x,y] + +-- | Create a term computing whether the first term (a natural number) is less +-- than the second term (also a natural number). +-- +-- > ltNat : Nat -> Nat -> Bool; +scLtNat :: SharedContext -> Term -> Term -> IO Term +scLtNat sc x y = scGlobalApply sc "Prelude.ltNat" [x,y] + +-- | Create a term computing the minimum of the two given (natural number) +-- terms. +-- +-- > minNat : Nat -> Nat -> Nat +scMinNat :: SharedContext -> Term -> Term -> IO Term +scMinNat sc x y = scGlobalApply sc "Prelude.minNat" [x,y] + +-- | Create a term computing the maximum of the two given (natural number) +-- terms. +-- +-- > maxNat : Nat -> Nat -> Nat; +scMaxNat :: SharedContext -> Term -> Term -> IO Term +scMaxNat sc x y = scGlobalApply sc "Prelude.maxNat" [x,y] + +-- Primitive operations on Integer + +-- | Create a term representing the prelude Integer type. +scIntegerType :: SharedContext -> IO Term +scIntegerType sc = scGlobalDef sc preludeIntegerIdent + +-- | Create an integer constant term from an 'Integer'. +scIntegerConst :: SharedContext -> Integer -> IO Term +scIntegerConst sc i + | i >= 0 = scNatToInt sc =<< scNat sc (fromInteger i) + | otherwise = scIntNeg sc =<< scNatToInt sc =<< scNat sc (fromInteger (- i)) + +-- | Create a term applying the integer addition primitive. +-- +-- > intAdd : Integer -> Integer -> Integer +scIntAdd :: SharedContext -> Term -> Term -> IO Term +scIntAdd sc x y = scGlobalApply sc "Prelude.intAdd" [x, y] + +-- | Create a term applying the integer subtraction primitive. +-- +-- > intSub : Integer -> Integer -> Integer +scIntSub :: SharedContext -> Term -> Term -> IO Term +scIntSub sc x y = scGlobalApply sc "Prelude.intSub" [x, y] + +-- | Create a term applying the integer multiplication primitive. +-- +-- > intMul : Integer -> Integer -> Integer +scIntMul :: SharedContext -> Term -> Term -> IO Term +scIntMul sc x y = scGlobalApply sc "Prelude.intMul" [x, y] + +-- | Create a term applying the integer division primitive. +-- +-- > intDiv : Integer -> Integer -> Integer +scIntDiv :: SharedContext -> Term -> Term -> IO Term +scIntDiv sc x y = scGlobalApply sc "Prelude.intDiv" [x, y] + +-- | Create a term applying the integer modulus primitive. +-- +-- > intMod : Integer -> Integer -> Integer +scIntMod :: SharedContext -> Term -> Term -> IO Term +scIntMod sc x y = scGlobalApply sc "Prelude.intMod" [x, y] + +-- | Create a term applying the integer min primitive. +-- +-- > intMin : Integer -> Integer -> Integer +scIntMin :: SharedContext -> Term -> Term -> IO Term +scIntMin sc x y = scGlobalApply sc "Prelude.intMin" [x, y] + +-- | Create a term applying the integer max primitive. +-- +-- > intMax : Integer -> Integer -> Integer +scIntMax :: SharedContext -> Term -> Term -> IO Term +scIntMax sc x y = scGlobalApply sc "Prelude.intMax" [x, y] + +-- | Create a term applying the negation integer primitive. +-- +-- > intNeg : Integer -> Integer; +scIntNeg :: SharedContext -> Term -> IO Term +scIntNeg sc x = scGlobalApply sc "Prelude.intNeg" [x] + +-- | Create a term applying the absolute value integer primitive. +-- +-- > intAbs : Integer -> Integer; +scIntAbs :: SharedContext -> Term -> IO Term +scIntAbs sc x = scGlobalApply sc "Prelude.intAbs" [x] + +-- | Create a term applying the integer equality testing primitive. +-- +-- > intEq : Integer -> Integer -> Bool; +scIntEq :: SharedContext -> Term -> Term -> IO Term +scIntEq sc x y = scGlobalApply sc "Prelude.intEq" [x, y] + +-- | Create a term applying the integer less-than-or-equal primitive. +-- +-- > intLe : Integer -> Integer -> Bool; +scIntLe :: SharedContext -> Term -> Term -> IO Term +scIntLe sc x y = scGlobalApply sc "Prelude.intLe" [x, y] + +-- | Create a term applying the integer less-than primitive. +-- +-- > intLt : Integer -> Integer -> Bool; +scIntLt :: SharedContext -> Term -> Term -> IO Term +scIntLt sc x y = scGlobalApply sc "Prelude.intLt" [x, y] + +-- | Create a term computing a @Nat@ from an @Integer@, if possible. +-- +-- > intToNat : Integer -> Nat; +scIntToNat + :: SharedContext -> Term -> IO Term +scIntToNat sc x = scGlobalApply sc "Prelude.intToNat" [x] + +-- | Create a term computing an @Integer@ from a @Nat@. +-- +-- > natToInt : Nat -> Integer; +scNatToInt + :: SharedContext -> Term -> IO Term +scNatToInt sc x = scGlobalApply sc "Prelude.natToInt" [x] + +-- | Create a term computing a bitvector of length n from an @Integer@, if +-- possible. +-- +-- > intToBv : (n::Nat) -> Integer -> Vec n Bool; +scIntToBv + :: SharedContext -> Term -> Term -> IO Term +scIntToBv sc n x = scGlobalApply sc "Prelude.intToBv" [n,x] + +-- | Create a term computing an @Integer@ from a bitvector of length n. +-- This produces the unsigned value of the bitvector. +-- +-- > bvToInt : (n : Nat) -> Vec n Bool -> Integer; +scBvToInt + :: SharedContext -> Term -> Term -> IO Term +scBvToInt sc n x = scGlobalApply sc "Prelude.bvToInt" [n,x] + +-- | Create a term computing an @Integer@ from a bitvector of length n. +-- This produces the 2's complement signed value of the bitvector. +-- +-- > sbvToInt : (n : Nat) -> Vec n Bool -> Integer; +scSbvToInt + :: SharedContext -> Term -> Term -> IO Term +scSbvToInt sc n x = scGlobalApply sc "Prelude.sbvToInt" [n,x] + + +-- Primitive operations on IntMod + +-- | Create a term representing the prelude @IntMod@ type. +-- +-- > IntMod : Nat -> sort 0; +scIntModType :: SharedContext -> Term -> IO Term +scIntModType sc n = scGlobalApply sc "Prelude.IntMod" [n] + +-- | Convert an integer to an integer mod n. +-- +-- > toIntMod : (n : Nat) -> Integer -> IntMod n; +scToIntMod :: SharedContext -> Term -> Term -> IO Term +scToIntMod sc n x = scGlobalApply sc "Prelude.toIntMod" [n, x] + + +-- Primitive operations on bitvectors + +-- | Create a term computing the type of a length-n bitvector. +-- +-- > bitvector : (n : Nat) -> sort 1 +scBitvector :: SharedContext -> Natural -> IO Term +scBitvector sc size = + do s <- scNat sc size + t <- scBoolType sc + scVecType sc s t + +-- | Create a term computing a bitvector of length x from a @Nat@, if possible. +-- +-- > bvNat : (n : Nat) -> Nat -> Vec n Bool; +scBvNat :: SharedContext -> Term -> Term -> IO Term +scBvNat sc x y = scGlobalApply sc "Prelude.bvNat" [x, y] + +-- | Create a term computing a @Nat@ from a bitvector of length n. +-- +-- > bvToNat : (n : Nat) -> Vec n Bool -> Nat; +scBvToNat :: SharedContext -> Natural -> Term -> IO Term +scBvToNat sc n x = do + n' <- scNat sc n + scGlobalApply sc "Prelude.bvToNat" [n',x] + +-- | Create a term computing a bitvector of the given length representing the +-- given 'Integer' value (if possible). +scBvConst :: SharedContext -> Natural -> Integer -> IO Term +scBvConst sc w v = assert (w <= fromIntegral (maxBound :: Int)) $ do + x <- scNat sc w + y <- scNat sc $ fromInteger $ v .&. (1 `shiftL` fromIntegral w - 1) + scGlobalApply sc "Prelude.bvNat" [x, y] + +-- TODO: This doesn't appear to be used anywhere, and "FinVal" doesn't appear +-- in Prelude.sawcore... can this be deleted? +-- | FinVal :: (x r :: Nat) -> Fin (Succ (addNat r x)); +scFinVal :: SharedContext -> Term -> Term -> IO Term +scFinVal sc a b = scCtorApp sc "Prelude.FinVal" [a, b] + +-- | Create a term computing the bitvector of given length representing 0 if +-- the other given term evaluates to @False@ and representing 1 if the other +-- given term evaluates to @True@. +-- +-- > bvBool : (n : Nat) -> Bool -> Vec n Bool; +scBvBool :: SharedContext -> Term -> Term -> IO Term +scBvBool sc n x = scGlobalApply sc "Prelude.bvBool" [n, x] + +-- | Create a term returning true if and only if the given bitvector represents +-- a nonzero value. +-- +-- > bvNonzero : (n : Nat) -> Vec n Bool -> Bool; +scBvNonzero :: SharedContext -> Term -> Term -> IO Term +scBvNonzero sc n x = scGlobalApply sc "Prelude.bvNonzero" [n, x] + +-- | Create a term computing the 2's complement negation of the given +-- bitvector. +-- > bvNeg : (n : Nat) -> Vec n Bool -> Vec n Bool; +scBvNeg :: SharedContext -> Term -> Term -> IO Term +scBvNeg sc n x = scGlobalApply sc "Prelude.bvNeg" [n, x] + +-- | Create a term applying the bitvector addition primitive. +-- +-- > bvAdd : (n : Nat) -> Vec n Bool -> Vec n Bool -> Vec n Bool; +scBvAdd :: SharedContext -> Term -> Term -> Term -> IO Term +scBvAdd sc n x y = scGlobalApply sc "Prelude.bvAdd" [n, x, y] + +-- | Create a term applying the bitvector subtraction primitive. +-- +-- > bvSub : (n : Nat) -> Vec n Bool -> Vec n Bool -> Vec n Bool; +scBvSub :: SharedContext -> Term -> Term -> Term -> IO Term +scBvSub sc n x y = scGlobalApply sc "Prelude.bvSub" [n, x, y] + +-- | Create a term applying the bitvector multiplication primitive. +-- +-- > bvMul : (n : Nat) -> Vec n Bool -> Vec n Bool -> Vec n Bool; +scBvMul :: SharedContext -> Term -> Term -> Term -> IO Term +scBvMul sc n x y = scGlobalApply sc "Prelude.bvMul" [n, x, y] + +-- | Create a term applying the bitvector (unsigned) modulus primitive. +-- +-- > bvURem : (n : Nat) -> Vec n Bool -> Vec n Bool -> Vec n Bool; +scBvURem :: SharedContext -> Term -> Term -> Term -> IO Term +scBvURem sc n x y = scGlobalApply sc "Prelude.bvURem" [n, x, y] + +-- | Create a term applying the bitvector (unsigned) division primitive. +-- +-- > bvUDiv : (n : Nat) -> Vec n Bool -> Vec n Bool -> Vec n Bool; +scBvUDiv :: SharedContext -> Term -> Term -> Term -> IO Term +scBvUDiv sc n x y = scGlobalApply sc "Prelude.bvUDiv" [n, x, y] + +-- | Create a term applying the bitvector (signed) modulus primitive. +-- +-- > bvSRem : (n : Nat) -> Vec n Bool -> Vec n Bool -> Vec n Bool; +scBvSRem :: SharedContext -> Term -> Term -> Term -> IO Term +scBvSRem sc n x y = scGlobalApply sc "Prelude.bvSRem" [n, x, y] + +-- | Create a term applying the bitvector (signed) division primitive. +-- +-- > bvSDiv : (n : Nat) -> Vec n Bool -> Vec n Bool -> Vec n Bool; +scBvSDiv :: SharedContext -> Term -> Term -> Term -> IO Term +scBvSDiv sc n x y = scGlobalApply sc "Prelude.bvSDiv" [n, x, y] + +-- | Create a term applying the population count bitvector primitive. +-- +-- > bvPopcount : (n : Nat) -> Vec n Bool -> Vec n Bool; +scBvPopcount :: SharedContext -> Term -> Term -> IO Term +scBvPopcount sc n x = scGlobalApply sc "Prelude.bvPopcount" [n, x] + +-- | Create a term applying the leading zero counting bitvector primitive. +-- +-- > bvCountLeadingZeros : (n : Nat) -> Vec n Bool -> Vec n Bool; +scBvCountLeadingZeros :: SharedContext -> Term -> Term -> IO Term +scBvCountLeadingZeros sc n x = scGlobalApply sc "Prelude.bvCountLeadingZeros" [n, x] + +-- | Create a term applying the trailing zero counting bitvector primitive. +-- +-- > bvCountTrailingZeros : (n : Nat) -> Vec n Bool -> Vec n Bool; +scBvCountTrailingZeros :: SharedContext -> Term -> Term -> IO Term +scBvCountTrailingZeros sc n x = scGlobalApply sc "Prelude.bvCountTrailingZeros" [n, x] + +-- | Create a term applying the bit-wise and primitive. +-- +-- > bvAnd : (n : Nat) -> Vec n Bool -> Vec n Bool -> Vec n Bool; +scBvAnd :: SharedContext -> Term -> Term -> Term -> IO Term +scBvAnd sc n x y = scGlobalApply sc "Prelude.bvAnd" [n, x, y] + +-- | Create a term applying the bit-wise xor primitive. +-- +-- > bvXor : (n : Nat) -> Vec n Bool -> Vec n Bool -> Vec n Bool; +scBvXor :: SharedContext -> Term -> Term -> Term -> IO Term +scBvXor sc n x y = scGlobalApply sc "Prelude.bvXor" [n, x, y] + +-- | Create a term applying the bit-wise or primitive. +-- +-- > bvOr : (n : Nat) -> Vec n Bool -> Vec n Bool -> Vec n Bool; +scBvOr :: SharedContext -> Term -> Term -> Term -> IO Term +scBvOr sc n x y = scGlobalApply sc "Prelude.bvOr" [n, x, y] + +-- | Create a term applying the bit-wise negation primitive. +-- +-- > bvNot : (n : Nat) -> Vec n Bool -> Vec n Bool; +scBvNot :: SharedContext -> Term -> Term -> IO Term +scBvNot sc n x = scGlobalApply sc "Prelude.bvNot" [n, x] + +-- | Create a term computing whether the two given bitvectors (of equal length) +-- are equal. +-- +-- > bvEq : (n : Nat) -> Vec n Bool -> Vec n Bool -> Bool; +scBvEq :: SharedContext -> Term -> Term -> Term -> IO Term +scBvEq sc n x y = scGlobalApply sc "Prelude.bvEq" [n, x, y] + +-- | Create a term applying the bitvector (unsigned) greater-than-or-equal +-- primitive. +-- +-- > bvuge : (n : Nat) -> Vec n Bool -> Vec n Bool -> Bool; +scBvUGe :: SharedContext -> Term -> Term -> Term -> IO Term +scBvUGe sc n x y = scGlobalApply sc "Prelude.bvuge" [n, x, y] + +-- | Create a term applying the bitvector (unsigned) less-than-or-equal +-- primitive. +-- +-- > bvule : (n : Nat) -> Vec n Bool -> Vec n Bool -> Bool; +scBvULe :: SharedContext -> Term -> Term -> Term -> IO Term +scBvULe sc n x y = scGlobalApply sc "Prelude.bvule" [n, x, y] + +-- | Create a term applying the bitvector (unsigned) greater-than primitive. +-- +-- > bvugt : (n : Nat) -> Vec n Bool -> Vec n Bool -> Bool; +scBvUGt :: SharedContext -> Term -> Term -> Term -> IO Term +scBvUGt sc n x y = scGlobalApply sc "Prelude.bvugt" [n, x, y] + +-- | Create a term applying the bitvector (unsigned) less-than primitive. +-- +-- > bvult : (n : Nat) -> Vec n Bool -> Vec n Bool -> Bool; +scBvULt :: SharedContext -> Term -> Term -> Term -> IO Term +scBvULt sc n x y = scGlobalApply sc "Prelude.bvult" [n, x, y] + +-- | Create a term applying the bitvector (signed) greater-than-or-equal +-- primitive. +-- +-- > bvsge : (n : Nat) -> Vec n Bool -> Vec n Bool -> Bool; +scBvSGe :: SharedContext -> Term -> Term -> Term -> IO Term +scBvSGe sc n x y = scGlobalApply sc "Prelude.bvsge" [n, x, y] + +-- | Create a term applying the bitvector (signed) less-than-or-equal +-- primitive. +-- +-- > bvsle : (n : Nat) -> Vec n Bool -> Vec n Bool -> Bool; +scBvSLe :: SharedContext -> Term -> Term -> Term -> IO Term +scBvSLe sc n x y = scGlobalApply sc "Prelude.bvsle" [n, x, y] + +-- | Create a term applying the bitvector (signed) greater-than primitive. +-- +-- > bvsgt : (n : Nat) -> Vec n Bool -> Vec n Bool -> Bool; +scBvSGt :: SharedContext -> Term -> Term -> Term -> IO Term +scBvSGt sc n x y = scGlobalApply sc "Prelude.bvsgt" [n, x, y] + +-- | Create a term applying the bitvector (signed) less-than primitive. +-- +-- > bvslt : (n : Nat) -> Vec n Bool -> Vec n Bool -> Bool; +scBvSLt :: SharedContext -> Term -> Term -> Term -> IO Term +scBvSLt sc n x y = scGlobalApply sc "Prelude.bvslt" [n, x, y] + +-- | Create a term applying the left-shift primitive. +-- +-- > bvShl : (n : Nat) -> Vec n Bool -> Nat -> Vec n Bool; +scBvShl :: SharedContext -> Term -> Term -> Term -> IO Term +scBvShl sc n x y = scGlobalApply sc "Prelude.bvShl" [n, x, y] + +-- | Create a term applying the logical right-shift primitive. +-- +-- > bvShr : (n : Nat) -> Vec n Bool -> Nat -> Vec n Bool; +scBvShr :: SharedContext -> Term -> Term -> Term -> IO Term +scBvShr sc n x y = scGlobalApply sc "Prelude.bvShr" [n, x, y] + +-- | Create a term applying the arithmetic/signed right-shift primitive. +-- +-- > bvSShr : (w : Nat) -> Vec (Succ w) Bool -> Nat -> Vec (Succ w) Bool; +scBvSShr :: SharedContext -> Term -> Term -> Term -> IO Term +scBvSShr sc n x y = scGlobalApply sc "Prelude.bvSShr" [n, x, y] + +-- | Create a term applying the unsigned bitvector extension primitive. +-- +-- > bvUExt : (m n : Nat) -> Vec n Bool -> Vec (addNat m n) Bool; +scBvUExt :: SharedContext -> Term -> Term -> Term -> IO Term +scBvUExt sc n m x = scGlobalApply sc "Prelude.bvUExt" [n,m,x] + +-- | Create a term applying the signed bitvector extension primitive. +-- +-- > bvSExt : (m n : Nat) -> Vec (Succ n) Bool -> Vec (addNat m (Succ n)) Bool; +scBvSExt :: SharedContext -> Term -> Term -> Term -> IO Term +scBvSExt sc n m x = scGlobalApply sc "Prelude.bvSExt" [n,m,x] + +-- | Create a term applying the bitvector truncation primitive. Note that this +-- truncates starting from the most significant bit. +-- +-- > bvTrunc : (m n : Nat) -> Vec (addNat m n) Bool -> Vec n Bool; +scBvTrunc :: SharedContext -> Term -> Term -> Term -> IO Term +scBvTrunc sc n m x = scGlobalApply sc "Prelude.bvTrunc" [n,m,x] + +-- | Create a term applying the @updNatFun@ primitive, which satisfies the +-- following laws: +-- +-- > updNatFun : (a : sort 0) -> (Nat -> a) -> Nat -> a -> (Nat -> a); +-- > updNatFun a _ i v i == v +-- > updNatFun a f i v x == f x, when i != x +scUpdNatFun :: SharedContext -> Term -> Term + -> Term -> Term -> IO Term +scUpdNatFun sc a f i v = scGlobalApply sc "Prelude.updNatFun" [a, f, i, v] + +-- | Create a term applying the @updBvFun@ primitive, which has the same +-- behavior as @updNatFun@ but acts on bitvectors. +-- +-- > updBvFun : (n : Nat) -> (a : sort 0) -> (Vec n Bool -> a) -> Vec n Bool -> a -> (Vec n Bool -> a); +scUpdBvFun :: SharedContext -> Term -> Term + -> Term -> Term -> Term -> IO Term +scUpdBvFun sc n a f i v = scGlobalApply sc "Prelude.updBvFun" [n, a, f, i, v] + +-- | Create a term representing the type of arrays, given an index type and +-- element type (as 'Term's). +-- +-- > Array : sort 0 -> sort 0 -> sort 0 +scArrayType :: SharedContext -> Term -> Term -> IO Term +scArrayType sc a b = scGlobalApply sc "Prelude.Array" [a, b] + +-- Create a term computing a constant array, given an index type, element type, +-- and element (all as 'Term's). +-- +-- > arrayConstant : (a b : sort 0) -> b -> (Array a b); +scArrayConstant :: SharedContext -> Term -> Term -> Term -> IO Term +scArrayConstant sc a b e = scGlobalApply sc "Prelude.arrayConstant" [a, b, e] + +-- Create a term computing the value at a particular index of an array. +-- +-- > arrayLookup : (a b : sort 0) -> (Array a b) -> a -> b; +scArrayLookup :: SharedContext -> Term -> Term -> Term -> Term -> IO Term +scArrayLookup sc a b f i = scGlobalApply sc "Prelude.arrayLookup" [a, b, f, i] + +-- Create a term computing an array updated at a particular index. +-- +-- > arrayUpdate : (a b : sort 0) -> (Array a b) -> a -> b -> (Array a b); +scArrayUpdate :: SharedContext -> Term -> Term -> Term -> Term -> Term -> IO Term +scArrayUpdate sc a b f i e = scGlobalApply sc "Prelude.arrayUpdate" [a, b, f, i, e] + +------------------------------------------------------------ +-- | The default instance of the SharedContext operations. +mkSharedContext :: IO SharedContext +mkSharedContext = do + vr <- newMVar 0 -- Reference for getting variables. + cr <- newMVar emptyAppCache + gr <- newIORef HMap.empty + let freshGlobalVar = modifyMVar vr (\i -> return (i+1, i)) + mod_map_ref <- newIORef HMap.empty + envRef <- newIORef emptySAWNamingEnv + return SharedContext { + scModuleMap = mod_map_ref + , scTermF = getTerm cr + , scFreshGlobalVar = freshGlobalVar + , scNamingEnv = envRef + , scGlobalEnv = gr + } + +useChangeCache :: C m => Cache m k (Change v) -> k -> ChangeT m v -> ChangeT m v +useChangeCache c k a = ChangeT $ useCache c k (runChangeT a) + +-- | Performs an action when a value has been modified, and otherwise +-- returns a pure value. +whenModified :: (Functor m, Monad m) => b -> (a -> m b) -> ChangeT m a -> ChangeT m b +whenModified b f m = ChangeT $ do + ca <- runChangeT m + case ca of + Original{} -> return (Original b) + Modified a -> Modified <$> f a + +-- | Return a list of all ExtCns subterms in the given term, sorted by +-- index. Does not traverse the unfoldings of @Constant@ terms. +getAllExts :: Term -> [ExtCns Term] +getAllExts t = Set.toList (getAllExtSet t) + +-- | Return a set of all ExtCns subterms in the given term. +-- Does not traverse the unfoldings of @Constant@ terms. +getAllExtSet :: Term -> Set.Set (ExtCns Term) +getAllExtSet t = snd $ getExtCns (IntSet.empty, Set.empty) t + where getExtCns acc@(is, _) (STApp{ stAppIndex = idx }) | IntSet.member idx is = acc + getExtCns (is, a) (STApp{ stAppIndex = idx, stAppTermF = (FTermF (ExtCns ec)) }) = + (IntSet.insert idx is, Set.insert ec a) + getExtCns (is, a) (Unshared (FTermF (ExtCns ec))) = + (is, Set.insert ec a) + getExtCns acc (STApp{ stAppTermF = Constant {} }) = acc + getExtCns acc (Unshared (Constant {})) = acc + getExtCns (is, a) (STApp{ stAppIndex = idx, stAppTermF = tf'}) = + foldl' getExtCns (IntSet.insert idx is, a) tf' + getExtCns acc (Unshared tf') = + foldl' getExtCns acc tf' + +getConstantSet :: Term -> Map VarIndex (NameInfo, Term, Term) +getConstantSet t = snd $ go (IntSet.empty, Map.empty) t + where + go acc@(idxs, names) (STApp{ stAppIndex = i, stAppTermF = tf}) + | IntSet.member i idxs = acc + | otherwise = termf (IntSet.insert i idxs, names) tf + go acc (Unshared tf) = termf acc tf + + termf acc@(idxs, names) tf = + case tf of + Constant (EC vidx n ty) body -> (idxs, Map.insert vidx (n, ty, body) names) + _ -> foldl' go acc tf + +-- | Instantiate some of the external constants +scInstantiateExt :: SharedContext + -> Map VarIndex Term + -> Term + -> IO Term +scInstantiateExt sc vmap = instantiateVars sc fn 0 + where fn l (Left ec) = + case Map.lookup (ecVarIndex ec) vmap of + Just t -> incVars sc 0 l t + Nothing -> scFlatTermF sc $ ExtCns ec + fn _ (Right i) = scTermF sc $ LocalVar i + +{- +-- RWD: I'm pretty sure the following implementation gets incorrect results when +-- the terms being substituted have free deBruijn variables. The above is a +-- reimplementation based on instantiateVars that does the necessary deBruijn +-- shifting. + +scInstantiateExt sc vmap t0 = do + tcache <- newCacheMap' Map.empty + let go :: Term -> ChangeT IO Term + go t@(Unshared tf) = + case tf of + -- | Lookup variable in term if it is bound. + FTermF (ExtCns ec) -> + maybe (return t) modified $ Map.lookup (ecVarIndex ec) vmap + -- | Recurse on other terms. + _ -> whenModified t (scTermF sc) (traverse go tf) + go t@(STApp idx tf) = + case tf of + -- Lookup variable in term if it is bound. + FTermF (ExtCns ec) -> + maybe (return t) modified $ Map.lookup (ecVarIndex ec) vmap + -- Recurse on other terms. + _ -> useChangeCache tcache idx $ + whenModified t (scTermF sc) (traverse go tf) + commitChangeT (go t0) +-} + +-- | Convert the given list of external constants to local variables, +-- with the right-most mapping to local variable 0. If the term is +-- open (i.e. it contains loose de Bruijn indices) then increment them +-- accordingly. +scExtsToLocals :: SharedContext -> [ExtCns Term] -> Term -> IO Term +scExtsToLocals _ [] x = return x +scExtsToLocals sc exts x = instantiateVars sc fn 0 x + where + m = Map.fromList [ (ecVarIndex ec, k) | (ec, k) <- zip (reverse exts) [0 ..] ] + fn l e = + case e of + Left ec -> + case Map.lookup (ecVarIndex ec) m of + Just k -> scLocalVar sc (l + k) + Nothing -> scFlatTermF sc (ExtCns ec) + Right i -> + scLocalVar sc (i + length exts) + +-- | Abstract over the given list of external constants by wrapping +-- the given term with lambdas and replacing the external constant +-- occurrences with the appropriate local variables. +scAbstractExts :: SharedContext -> [ExtCns Term] -> Term -> IO Term +scAbstractExts _ [] x = return x +scAbstractExts sc exts x = + do let lams = [ (toShortName (ecName ec), ecType ec) | ec <- exts ] + scLambdaList sc lams =<< scExtsToLocals sc exts x + +-- | Generalize over the given list of external constants by wrapping +-- the given term with foralls and replacing the external constant +-- occurrences with the appropriate local variables. +scGeneralizeExts :: SharedContext -> [ExtCns Term] -> Term -> IO Term +scGeneralizeExts _ [] x = return x +scGeneralizeExts sc exts x = + do let pis = [ (toShortName (ecName ec), ecType ec) | ec <- exts ] + scPiList sc pis =<< scExtsToLocals sc exts x + +scUnfoldConstants :: SharedContext -> [VarIndex] -> Term -> IO Term +scUnfoldConstants sc names t0 = scUnfoldConstantSet sc True (Set.fromList names) t0 + +-- | TODO: test whether this version is slower or faster. +scUnfoldConstants' :: SharedContext -> [VarIndex] -> Term -> IO Term +scUnfoldConstants' sc names t0 = scUnfoldConstantSet' sc True (Set.fromList names) t0 + +scUnfoldConstantSet :: SharedContext + -> Bool -- ^ True: unfold constants in set. False: unfold constants NOT in set + -> Set VarIndex -- ^ Set of constant names + -> Term + -> IO Term +scUnfoldConstantSet sc b names t0 = do + cache <- newCache + let go :: Term -> IO Term + go t@(Unshared tf) = + case tf of + Constant (EC idx _ _) rhs + | Set.member idx names == b -> go rhs + | otherwise -> return t + _ -> Unshared <$> traverse go tf + go t@(STApp{ stAppIndex = idx, stAppTermF = tf }) = useCache cache idx $ + case tf of + Constant (EC ecidx _ _) rhs + | Set.member ecidx names == b -> go rhs + | otherwise -> return t + _ -> scTermF sc =<< traverse go tf + go t0 + + +-- | TODO: test whether this version is slower or faster. +scUnfoldConstantSet' :: SharedContext + -> Bool -- ^ True: unfold constants in set. False: unfold constants NOT in set + -> Set VarIndex -- ^ Set of constant names + -> Term + -> IO Term +scUnfoldConstantSet' sc b names t0 = do + tcache <- newCacheMap' Map.empty + let go :: Term -> ChangeT IO Term + go t@(Unshared tf) = + case tf of + Constant (EC idx _ _) rhs + | Set.member idx names == b -> taint (go rhs) + | otherwise -> pure t + _ -> whenModified t (return . Unshared) (traverse go tf) + go t@(STApp{ stAppIndex = idx, stAppTermF = tf }) = + case tf of + Constant (EC ecidx _ _) rhs + | Set.member ecidx names == b -> taint (go rhs) + | otherwise -> pure t + _ -> useChangeCache tcache idx $ + whenModified t (scTermF sc) (traverse go tf) + commitChangeT (go t0) + + +-- | Return the number of DAG nodes used by the given @Term@. +scSharedSize :: Term -> Integer +scSharedSize = fst . go (0, Set.empty) + where + go (sz, seen) (Unshared tf) = foldl' go (strictPair (sz + 1) seen) tf + go (sz, seen) (STApp{ stAppIndex = idx, stAppTermF = tf }) + | Set.member idx seen = (sz, seen) + | otherwise = foldl' go (strictPair (sz + 1) (Set.insert idx seen)) tf + +strictPair :: a -> b -> (a, b) +strictPair x y = x `seq` y `seq` (x, y) + +-- | Return the number of nodes that would be used by the given +-- @Term@ if it were represented as a tree instead of a DAG. +scTreeSize :: Term -> Integer +scTreeSize = fst . go (0, Map.empty) + where + go (sz, seen) (Unshared tf) = foldl' go (sz + 1, seen) tf + go (sz, seen) (STApp{ stAppIndex = idx, stAppTermF = tf }) = + case Map.lookup idx seen of + Just sz' -> (sz + sz', seen) + Nothing -> (sz + sz', Map.insert idx sz' seen') + where (sz', seen') = foldl' go (1, seen) tf + + +-- | `openTerm sc nm ty i body` replaces the loose deBruijn variable `i` +-- with a fresh external constant (with name `nm`, and type `ty`) in `body`. +scOpenTerm :: SharedContext + -> String + -> Term + -> DeBruijnIndex + -> Term + -> IO (ExtCns Term, Term) +scOpenTerm sc nm tp idx body = do + ec <- scFreshEC sc nm tp + ec_term <- scFlatTermF sc (ExtCns ec) + body' <- instantiateVar sc idx ec_term body + return (ec, body') + +-- | `closeTerm closer sc ec body` replaces the external constant `ec` in `body` by +-- a new deBruijn variable and binds it using the binding form given by 'close'. +-- The name and type of the new bound variable are given by the name and type of `ec`. +scCloseTerm :: (SharedContext -> LocalName -> Term -> Term -> IO Term) + -> SharedContext + -> ExtCns Term + -> Term + -> IO Term +scCloseTerm close sc ec body = do + lv <- scLocalVar sc 0 + body' <- scInstantiateExt sc (Map.insert (ecVarIndex ec) lv Map.empty) =<< incVars sc 0 1 body + close sc (toShortName (ecName ec)) (ecType ec) body' diff --git a/saw-core/src/Verifier/SAW/Simulator.hs b/saw-core/src/Verifier/SAW/Simulator.hs new file mode 100644 index 0000000000..7d9a1266b9 --- /dev/null +++ b/saw-core/src/Verifier/SAW/Simulator.hs @@ -0,0 +1,485 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TupleSections #-} + +{- | +Module : Verifier.SAW.Simulator +Copyright : Galois, Inc. 2012-2015 +License : BSD3 +Maintainer : jhendrix@galois.com +Stability : experimental +Portability : non-portable (language extensions) + +Evaluator for SAWCore terms, with lazy evaluation order. +-} + +module Verifier.SAW.Simulator + ( SimulatorConfig(..) + , evalSharedTerm + , evalGlobal + , evalGlobal' + , checkPrimitives + ) where + +import Prelude hiding (mapM) + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>)) +#endif +import Control.Monad (foldM, liftM) +import Control.Monad.Fix (MonadFix(mfix)) +import Control.Monad.Identity (Identity) +import qualified Control.Monad.State as State +import Data.Foldable (foldlM) +import qualified Data.Set as Set +import Data.Map (Map) +import qualified Data.Map as Map +import Data.IntMap (IntMap) +import qualified Data.IntMap as IMap +import Data.Traversable +import qualified Data.Vector as V +--import qualified Debug.Trace as Debug + +import qualified Verifier.SAW.Utils as Panic (panic) + +import Verifier.SAW.Module +import Verifier.SAW.SharedTerm +import Verifier.SAW.TypedAST + +import Verifier.SAW.Simulator.Value + +type Id = Identity + +type ThunkIn m l = Thunk (WithM m l) +type OpenValueIn m l = OpenValue (WithM m l) +type ValueIn m l = Value (WithM m l) +type TValueIn m l = TValue (WithM m l) +type MValueIn m l = MValue (WithM m l) +type SimulatorConfigIn m l = SimulatorConfig (WithM m l) + +panic :: String -> a +panic msg = Panic.panic "Verifier.SAW.Simulator" [msg] + +------------------------------------------------------------ +-- Simulator configuration + +data SimulatorConfig l = + SimulatorConfig + { simPrimitive :: Ident -> MValue l + -- ^ Interpretation of 'Primitive' terms. + , simExtCns :: TermF Term -> ExtCns (TValue l) -> MValue l + -- ^ Interpretation of 'ExtCns' terms. + , simConstant :: TermF Term -> ExtCns (TValue l) -> Maybe (MValue l) + -- ^ Interpretation of 'Constant' terms. 'Nothing' indicates that + -- the body of the constant should be evaluated. 'Just' indicates + -- that the constant's definition should be overridden. + , simCtorApp :: Ident -> Maybe (MValue l) + -- ^ Interpretation of 'Constant' terms. 'Nothing' indicates that + -- the constructor is treated as normal. 'Just' replaces the + -- constructor with a custom implementation. + , simModMap :: ModuleMap + } + +------------------------------------------------------------ +-- Evaluation of terms + +-- | Meaning of an open term, parameterized by environment of bound variables +type OpenValue l = [Thunk l] -> MValue l + +{-# SPECIALIZE + evalTermF :: Show (Extra l) => + SimulatorConfigIn Id l -> + (Term -> OpenValueIn Id l) -> + (Term -> MValueIn Id l) -> + TermF Term -> + OpenValueIn Id l #-} + +{-# SPECIALIZE + evalTermF :: Show (Extra l) => + SimulatorConfigIn IO l -> + (Term -> OpenValueIn IO l) -> + (Term -> MValueIn IO l) -> + TermF Term -> + OpenValueIn IO l #-} + +-- | Generic evaluator for TermFs. +evalTermF :: forall l. (VMonadLazy l, Show (Extra l)) => + SimulatorConfig l -- ^ Evaluator for global constants + -> (Term -> OpenValue l) -- ^ Evaluator for subterms under binders + -> (Term -> MValue l) -- ^ Evaluator for subterms in the same bound variable context + -> TermF Term -> OpenValue l +evalTermF cfg lam recEval tf env = + case tf of + App t1 t2 -> do v <- recEval t1 + x <- recEvalDelay t2 + apply v x + Lambda _ _ t -> return $ VFun (\x -> lam t (x : env)) + Pi _ t1 t2 -> do v <- toTValue <$> recEval t1 + return $ TValue $ VPiType v (\x -> toTValue <$> lam t2 (x : env)) + LocalVar i -> force (env !! i) + Constant ec t -> do ec' <- traverse (fmap toTValue . recEval) ec + maybe (recEval t) id (simConstant cfg tf ec') + FTermF ftf -> + case ftf of + Primitive ec -> + do ec' <- traverse (fmap toTValue . recEval) ec + case ecName ec' of + ModuleIdentifier ident -> simPrimitive cfg ident + _ -> simExtCns cfg tf ec' + UnitValue -> return VUnit + UnitType -> return $ TValue VUnitType + PairValue x y -> do tx <- recEvalDelay x + ty <- recEvalDelay y + return $ VPair tx ty + PairType x y -> do vx <- toTValue <$> recEval x + vy <- toTValue <$> recEval y + return $ TValue $ VPairType vx vy + PairLeft x -> valPairLeft =<< recEval x + PairRight x -> valPairRight =<< recEval x + CtorApp ident ps ts -> do ps' <- mapM recEvalDelay ps + ts' <- mapM recEvalDelay ts + case simCtorApp cfg ident of + Just mv -> + do v <- mv + foldM apply v (ps' ++ ts') + Nothing -> + pure $ VCtorApp ident (V.fromList (ps' ++ ts')) + DataTypeApp i ps ts -> TValue . VDataType i <$> mapM recEval (ps ++ ts) + RecursorApp _d ps p_ret cs_fs _ixs arg -> + do ps_th <- mapM recEvalDelay ps + p_ret_th <- recEvalDelay p_ret + cs_fs_th <- mapM (\(c,f) -> (c,) <$> recEvalDelay f) cs_fs + arg_v <- recEval arg + evalRecursorApp (simModMap cfg) lam ps_th p_ret_th cs_fs_th arg_v + RecordType elem_tps -> + TValue . VRecordType <$> traverse (traverse (fmap toTValue . recEval)) elem_tps + RecordValue elems -> + VRecordValue <$> mapM (\(fld,t) -> (fld,) <$> recEvalDelay t) elems + RecordProj t fld -> recEval t >>= flip valRecordProj fld + Sort s -> return $ TValue (VSort s) + NatLit n -> return $ VNat n + ArrayValue _ tv -> liftM VVector $ mapM recEvalDelay tv + StringLit s -> return $ VString s + ExtCns ec -> do ec' <- traverse (fmap toTValue . recEval) ec + simExtCns cfg tf ec' + where + recEvalDelay :: Term -> EvalM l (Thunk l) + recEvalDelay = delay . recEval + + +{-# SPECIALIZE evalGlobal :: + Show (Extra l) => + ModuleMap -> + Map Ident (ValueIn Id l) -> + (ExtCns (TValueIn Id l) -> MValueIn Id l) -> + (ExtCns (TValueIn Id l) -> Maybe (MValueIn Id l)) -> + Id (SimulatorConfigIn Id l) #-} +{-# SPECIALIZE evalGlobal :: + Show (Extra l) => + ModuleMap -> + Map Ident (ValueIn IO l) -> + (ExtCns (TValueIn IO l) -> MValueIn IO l) -> + (ExtCns (TValueIn IO l) -> Maybe (MValueIn IO l)) -> + IO (SimulatorConfigIn IO l) #-} +evalGlobal :: forall l. (VMonadLazy l, MonadFix (EvalM l), Show (Extra l)) => + ModuleMap -> Map Ident (Value l) -> + (ExtCns (TValue l) -> MValue l) -> + (ExtCns (TValue l) -> Maybe (EvalM l (Value l))) -> + EvalM l (SimulatorConfig l) +evalGlobal modmap prims extcns uninterpreted = + evalGlobal' modmap prims (const extcns) (const uninterpreted) + +{-# SPECIALIZE evalGlobal' :: + Show (Extra l) => + ModuleMap -> + Map Ident (ValueIn Id l) -> + (TermF Term -> ExtCns (TValueIn Id l) -> MValueIn Id l) -> + (TermF Term -> ExtCns (TValueIn Id l) -> Maybe (MValueIn Id l)) -> + Id (SimulatorConfigIn Id l) #-} +{-# SPECIALIZE evalGlobal' :: + Show (Extra l) => + ModuleMap -> + Map Ident (ValueIn IO l) -> + (TermF Term -> ExtCns (TValueIn IO l) -> MValueIn IO l) -> + (TermF Term -> ExtCns (TValueIn IO l) -> Maybe (MValueIn IO l)) -> + IO (SimulatorConfigIn IO l) #-} +-- | A variant of 'evalGlobal' that lets the uninterpreted function +-- symbol and external-constant callbacks have access to the 'TermF'. +evalGlobal' :: + forall l. (VMonadLazy l, Show (Extra l)) => + ModuleMap -> + -- | Implementations of 'Primitive' terms, plus overrides for 'Constant' and 'CtorApp' terms + Map Ident (Value l) -> + -- | Implementations of ExtCns terms + (TermF Term -> ExtCns (TValue l) -> MValue l) -> + -- | Overrides for Constant terms (e.g. uninterpreted functions) + (TermF Term -> ExtCns (TValue l) -> Maybe (MValue l)) -> + EvalM l (SimulatorConfig l) +evalGlobal' modmap prims extcns constant = + do checkPrimitives modmap prims + return (SimulatorConfig primitive extcns constant' ctors modmap) + where + constant' :: TermF Term -> ExtCns (TValue l) -> Maybe (MValue l) + constant' tf ec = + case constant tf ec of + Just v -> Just v + Nothing -> + case ecName ec of + ModuleIdentifier ident -> pure <$> Map.lookup ident prims + _ -> Nothing + + ctors :: Ident -> Maybe (MValue l) + ctors ident = pure <$> Map.lookup ident prims + + primitive :: Ident -> MValue l + primitive ident = + case Map.lookup ident prims of + Just v -> pure v + Nothing -> panic $ "Unimplemented global: " ++ show ident + +-- | Check that all the primitives declared in the given module +-- are implemented, and that terms with implementations are not +-- overridden. +checkPrimitives :: forall l. (VMonadLazy l, Show (Extra l)) + => ModuleMap + -> Map Ident (Value l) + -> EvalM l () +checkPrimitives modmap prims = do + -- FIXME this is downgraded to a warning temporarily while we work out a + -- solution to issue GaloisInc/saw-script#48 + -- when (not $ null unimplementedPrims) (panic $ unimplementedMsg) + -- (if null unimplementedPrims then id else Debug.trace (unimplementedMsg++"\n")) $ +-- (if null overridePrims then id else Debug.trace (overrideMsg++"\n")) $ + return () + + where _unimplementedMsg = unwords $ + ("WARNING unimplemented primitives:" : (map show unimplementedPrims)) + _overrideMsg = unwords $ + ("WARNING overridden definitions:" : (map show overridePrims)) + + primSet = Set.fromList $ map defIdent $ allModulePrimitives modmap + defSet = Set.fromList $ map defIdent $ allModuleActualDefs modmap + implementedPrims = Map.keysSet prims + + unimplementedPrims = Set.toList $ Set.difference primSet implementedPrims + overridePrims = Set.toList $ Set.intersection defSet implementedPrims + + +-- | Evaluate a recursor application given a recursive way to evaluate terms, +-- the current 'RecursorInfo' structure, and thunks for the @p_ret@, eliminators +-- for the current inductive type, and the value being pattern-matched +evalRecursorApp :: (VMonad l, Show (Extra l)) => + ModuleMap -> (Term -> OpenValue l) -> + [Thunk l] -> Thunk l -> [(Ident, Thunk l)] -> Value l -> + MValue l +evalRecursorApp modmap lam ps p_ret cs_fs (VCtorApp c all_args) + | Just ctor <- findCtorInMap modmap c + , Just dt <- findDataTypeInMap modmap (ctorDataTypeName ctor) + = do elims <- + mapM (\c' -> case lookup (ctorName c') cs_fs of + Just elim -> return elim + Nothing -> + panic ("evalRecursorApp: internal error: " + ++ "constructor not found in its own datatype: " + ++ show c')) $ + dtCtors dt + let args = drop (length ps) $ V.toList all_args + lam (ctorIotaReduction ctor) (reverse $ ps ++ [p_ret] ++ elims ++ args) +evalRecursorApp _ _ _ _ _ (VCtorApp c _) = + panic $ ("evalRecursorApp: could not find info for constructor: " ++ show c) +evalRecursorApp modmap lam ps p_ret cs_fs (VNat 0) = + evalRecursorApp modmap lam ps p_ret cs_fs (VCtorApp "Prelude.Zero" V.empty) +evalRecursorApp modmap lam ps p_ret cs_fs (VNat i) = + evalRecursorApp modmap lam ps p_ret cs_fs + (VCtorApp "Prelude.Succ" (V.singleton $ ready $ VNat $ i-1)) +evalRecursorApp _modmap _lam _ps _p_ret _cs_fs (VToNat _bv) = + panic $ "evalRecursorApp: VToNat!" +evalRecursorApp _ _ _ _ _ v = + panic $ "evalRecursorApp: non-constructor value: " ++ show v + + +---------------------------------------------------------------------- +-- The evaluation strategy for SharedTerms involves two memo tables: +-- The first, @memoClosed@, is precomputed and contains the result of +-- evaluating all _closed_ subterms. The same @memoClosed@ table is +-- used for evaluation under lambdas, since the meaning of a closed +-- term does not depend on the local variable context. The second memo +-- table is @memoLocal@, which additionally includes the result of +-- evaluating _open_ terms in the current variable context. It is +-- reinitialized to @memoClosed@ whenever we descend under a lambda +-- binder. + +{-# SPECIALIZE evalSharedTerm :: + Show (Extra l) => SimulatorConfigIn Id l -> Term -> MValueIn Id l #-} +{-# SPECIALIZE evalSharedTerm :: + Show (Extra l) => SimulatorConfigIn IO l -> Term -> MValueIn IO l #-} + +-- | Evaluator for shared terms. +evalSharedTerm :: (VMonadLazy l, MonadFix (EvalM l), Show (Extra l)) => + SimulatorConfig l -> Term -> MValue l +evalSharedTerm cfg t = do + memoClosed <- mkMemoClosed cfg t + evalOpen cfg memoClosed t [] + +{-# SPECIALIZE mkMemoClosed :: + Show (Extra l) => + SimulatorConfigIn Id l -> Term -> Id (IntMap (ThunkIn Id l)) #-} +{-# SPECIALIZE mkMemoClosed :: + Show (Extra l) => + SimulatorConfigIn IO l -> Term -> IO (IntMap (ThunkIn IO l)) #-} + +-- | Precomputing the memo table for closed subterms. +mkMemoClosed :: forall l. (VMonadLazy l, MonadFix (EvalM l), Show (Extra l)) => + SimulatorConfig l -> Term -> EvalM l (IntMap (Thunk l)) +mkMemoClosed cfg t = + mfix $ \memoClosed -> mapM (delay . evalClosedTermF cfg memoClosed) subterms + where + -- | Map of all closed subterms of t. + subterms :: IntMap (TermF Term) + subterms = fmap fst $ IMap.filter ((== emptyBitSet) . snd) $ State.execState (go t) IMap.empty + + go :: Term -> State.State (IntMap (TermF Term, BitSet)) BitSet + go (Unshared tf) = freesTermF <$> traverse go tf + go (STApp{ stAppIndex = i, stAppTermF = tf }) = do + memo <- State.get + case IMap.lookup i memo of + Just (_, b) -> return b + Nothing -> do + b <- freesTermF <$> traverse go tf + State.modify (IMap.insert i (tf, b)) + return b + +{-# SPECIALIZE evalClosedTermF :: + Show (Extra l) => + SimulatorConfigIn Id l -> + IntMap (ThunkIn Id l) -> + TermF Term -> + MValueIn Id l #-} +{-# SPECIALIZE evalClosedTermF :: + Show (Extra l) => + SimulatorConfigIn IO l -> + IntMap (ThunkIn IO l) -> + TermF Term -> + MValueIn IO l #-} + +-- | Evaluator for closed terms, used to populate @memoClosed@. +evalClosedTermF :: (VMonadLazy l, Show (Extra l)) => + SimulatorConfig l + -> IntMap (Thunk l) + -> TermF Term -> MValue l +evalClosedTermF cfg memoClosed tf = evalTermF cfg lam recEval tf [] + where + lam = evalOpen cfg memoClosed + recEval (Unshared tf') = evalTermF cfg lam recEval tf' [] + recEval (STApp{ stAppIndex = i }) = + case IMap.lookup i memoClosed of + Just x -> force x + Nothing -> panic "evalClosedTermF: internal error" + +{-# SPECIALIZE mkMemoLocal :: + Show (Extra l) => + SimulatorConfigIn Id l -> + IntMap (ThunkIn Id l) -> + Term -> + [ThunkIn Id l] -> + Id (IntMap (ThunkIn Id l)) #-} +{-# SPECIALIZE mkMemoLocal :: + Show (Extra l) => + SimulatorConfigIn IO l -> + IntMap (ThunkIn IO l) -> + Term -> + [ThunkIn IO l] -> + IO (IntMap (ThunkIn IO l)) #-} + +-- | Precomputing the memo table for open subterms in the current context. +mkMemoLocal :: forall l. (VMonadLazy l, Show (Extra l)) => + SimulatorConfig l -> IntMap (Thunk l) -> + Term -> [Thunk l] -> EvalM l (IntMap (Thunk l)) +mkMemoLocal cfg memoClosed t env = go memoClosed t + where + go :: IntMap (Thunk l) -> Term -> EvalM l (IntMap (Thunk l)) + go memo (Unshared tf) = goTermF memo tf + go memo (STApp{ stAppIndex = i, stAppTermF = tf }) = + case IMap.lookup i memo of + Just _ -> return memo + Nothing -> do + memo' <- goTermF memo tf + thunk <- delay (evalLocalTermF cfg memoClosed memo' tf env) + return (IMap.insert i thunk memo') + + goTermF :: IntMap (Thunk l) -> TermF Term -> EvalM l (IntMap (Thunk l)) + goTermF memo tf = + case tf of + FTermF ftf -> foldlM go memo ftf + App t1 t2 -> do memo' <- go memo t1 + go memo' t2 + Lambda _ t1 _ -> go memo t1 + Pi _ t1 _ -> go memo t1 + LocalVar _ -> return memo + Constant _ t1 -> go memo t1 + +{-# SPECIALIZE evalLocalTermF :: + Show (Extra l) => + SimulatorConfigIn Id l -> + IntMap (ThunkIn Id l) -> + IntMap (ThunkIn Id l) -> + TermF Term -> + OpenValueIn Id l #-} +{-# SPECIALIZE evalLocalTermF :: + Show (Extra l) => + SimulatorConfigIn IO l -> + IntMap (ThunkIn IO l) -> + IntMap (ThunkIn IO l) -> + TermF Term -> + OpenValueIn IO l #-} +-- | Evaluator for open terms, used to populate @memoLocal@. +evalLocalTermF :: (VMonadLazy l, Show (Extra l)) => + SimulatorConfig l + -> IntMap (Thunk l) -> IntMap (Thunk l) + -> TermF Term -> OpenValue l +evalLocalTermF cfg memoClosed memoLocal tf0 env = evalTermF cfg lam recEval tf0 env + where + lam = evalOpen cfg memoClosed + recEval (Unshared tf) = evalTermF cfg lam recEval tf env + recEval (STApp{ stAppIndex = i }) = + case IMap.lookup i memoLocal of + Just x -> force x + Nothing -> panic "evalLocalTermF: internal error" + +{-# SPECIALIZE evalOpen :: + Show (Extra l) => + SimulatorConfigIn Id l -> + IntMap (ThunkIn Id l) -> + Term -> + OpenValueIn Id l #-} + +{-# SPECIALIZE evalOpen :: + Show (Extra l) => + SimulatorConfigIn IO l -> + IntMap (ThunkIn IO l) -> + Term -> + OpenValueIn IO l #-} + +-- | Evaluator for open terms; parameterized by a precomputed table @memoClosed@. +evalOpen :: forall l. (VMonadLazy l, Show (Extra l)) => + SimulatorConfig l + -> IntMap (Thunk l) + -> Term -> OpenValue l +evalOpen cfg memoClosed t env = do + memoLocal <- mkMemoLocal cfg memoClosed t env + let eval :: Term -> MValue l + eval (Unshared tf) = evalF tf + eval (STApp{ stAppIndex = i, stAppTermF = tf }) = + case IMap.lookup i memoLocal of + Just x -> force x + Nothing -> evalF tf + evalF :: TermF Term -> MValue l + evalF tf = evalTermF cfg (evalOpen cfg memoClosed) eval tf env + eval t diff --git a/saw-core/src/Verifier/SAW/Simulator/Concrete.hs b/saw-core/src/Verifier/SAW/Simulator/Concrete.hs new file mode 100644 index 0000000000..22c271a391 --- /dev/null +++ b/saw-core/src/Verifier/SAW/Simulator/Concrete.hs @@ -0,0 +1,369 @@ +{-# LANGUAGE DoAndIfThenElse #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE TypeFamilies #-} + +{- | +Module : Verifier.SAW.Simulator.Concrete +Copyright : Galois, Inc. 2012-2015 +License : BSD3 +Maintainer : huffman@galois.com +Stability : experimental +Portability : non-portable (language extensions) +-} + +module Verifier.SAW.Simulator.Concrete + ( evalSharedTerm + , CValue, Concrete, Value(..), TValue(..) + , CExtra(..) + , toBool + , toWord + , runIdentity + ) where + +--import Control.Applicative +--import Control.Monad (zipWithM, (<=<)) +import Control.Monad.Identity +import Data.Bits +import Data.IntTrie (IntTrie) +import qualified Data.IntTrie as IntTrie +import Data.Map (Map) +import qualified Data.Map as Map +--import Data.Traversable +import Data.Vector (Vector) +import qualified Data.Vector as V + +import Verifier.SAW.Prim (BitVector(..), signed, bv, bvNeg) +import qualified Verifier.SAW.Prim as Prim +import qualified Verifier.SAW.Simulator as Sim +import Verifier.SAW.Simulator.Value +import qualified Verifier.SAW.Simulator.Prims as Prims +import Verifier.SAW.TypedAST (ModuleMap) +import Verifier.SAW.SharedTerm + +------------------------------------------------------------ + +-- type ExtCnsEnv = VarIndex -> String -> CValue + +-- | Evaluator for shared terms. +evalSharedTerm :: ModuleMap -> Map Ident CValue -> Map VarIndex CValue -> Term -> CValue +evalSharedTerm m addlPrims ecVals t = + runIdentity $ do + cfg <- Sim.evalGlobal m (Map.union constMap addlPrims) extcns (const Nothing) + Sim.evalSharedTerm cfg t + where + extcns ec = + case Map.lookup (ecVarIndex ec) ecVals of + Just v -> return v + Nothing -> return $ Prim.userError $ "Unimplemented: external constant " ++ show (ecName ec) + +------------------------------------------------------------ +-- Values + +data Concrete + +type instance EvalM Concrete = Identity +type instance VBool Concrete = Bool +type instance VWord Concrete = BitVector +type instance VInt Concrete = Integer +type instance VArray Concrete = () +type instance Extra Concrete = CExtra + +type CValue = Value Concrete -- (WithM Identity Concrete) + +data CExtra + = CStream (IntTrie CValue) + +instance Show CExtra where + show (CStream _) = "" + +toBool :: CValue -> Bool +toBool (VBool b) = b +toBool x = error $ unwords ["Verifier.SAW.Simulator.Concrete.toBool", show x] + +vWord :: BitVector -> CValue +vWord x = VWord x + +-- | Conversion from list of bits to integer (big-endian) +bvToInteger :: Vector Bool -> Integer +bvToInteger = V.foldl' (\x b -> if b then 2*x+1 else 2*x) 0 + +unpackBitVector :: BitVector -> Vector Bool +unpackBitVector x = V.generate (Prim.width x) (Prim.bvAt x) + +packBitVector :: Vector Bool -> BitVector +packBitVector v = BV (V.length v) (bvToInteger v) + +toWord :: CValue -> BitVector +toWord (VWord x) = x +toWord (VVector vv) = packBitVector (fmap (toBool . runIdentity . force) vv) +toWord x = error $ unwords ["Verifier.SAW.Simulator.Concrete.toWord", show x] + +vStream :: IntTrie CValue -> CValue +vStream x = VExtra (CStream x) + +toStream :: CValue -> IntTrie CValue +toStream (VExtra (CStream x)) = x +toStream x = error $ unwords ["Verifier.SAW.Simulator.Concrete.toStream", show x] + +{- +flattenBValue :: CValue -> BitVector +flattenBValue (VExtra (BBool l)) = return (AIG.replicate 1 l) +flattenBValue (VWord lv) = return lv +flattenBValue (VExtra (CStream _ _)) = error "Verifier.SAW.Simulator.Concrete.flattenBValue: CStream" +flattenBValue (VVector vv) = + AIG.concat <$> traverse (flattenBValue <=< force) (V.toList vv) +flattenBValue (VTuple vv) = + AIG.concat <$> traverse (flattenBValue <=< force) (V.toList vv) +flattenBValue (VRecord m) = + AIG.concat <$> traverse (flattenBValue <=< force) (Map.elems m) +flattenBValue _ = error $ unwords ["Verifier.SAW.Simulator.Concrete.flattenBValue: unsupported value"] +-} + +wordFun :: (BitVector -> CValue) -> CValue +wordFun f = pureFun (\x -> f (toWord x)) + +-- | op : (n : Nat) -> Vec n Bool -> Nat -> Vec n Bool +bvShiftOp :: (BitVector -> Int -> BitVector) -> CValue +bvShiftOp natOp = + constFun $ + wordFun $ \x -> + pureFun $ \y -> + case y of + VNat n | toInteger n < toInteger (maxBound :: Int) -> vWord (natOp x (fromIntegral n)) + _ -> error $ unwords ["Verifier.SAW.Simulator.Concrete.shiftOp", show y] + +------------------------------------------------------------ + +pure1 :: Applicative f => (a -> b) -> a -> f b +pure1 f x = pure (f x) + +pure2 :: Applicative f => (a -> b -> c) -> a -> b -> f c +pure2 f x y = pure (f x y) + +pure3 :: Applicative f => (a -> b -> c -> d) -> a -> b -> c -> f d +pure3 f x y z = pure (f x y z) + +divOp :: (a -> b -> Maybe c) -> a -> b -> Identity c +divOp f x y = maybe Prim.divideByZero pure (f x y) + +ite :: Bool -> a -> a -> a +ite b x y = if b then x else y + +prims :: Prims.BasePrims Concrete +prims = + Prims.BasePrims + { Prims.bpAsBool = Just + , Prims.bpUnpack = pure1 unpackBitVector + , Prims.bpPack = pure1 packBitVector + , Prims.bpBvAt = pure2 Prim.bvAt + , Prims.bpBvLit = pure2 Prim.bv + , Prims.bpBvSize = Prim.width + , Prims.bpBvJoin = pure2 (Prim.append_bv undefined undefined undefined) + , Prims.bpBvSlice = pure3 (\m n x -> Prim.slice_bv () m n (Prim.width x - m - n) x) + -- Conditionals + , Prims.bpMuxBool = pure3 ite + , Prims.bpMuxWord = pure3 ite + , Prims.bpMuxInt = pure3 ite + , Prims.bpMuxExtra = pure3 ite + -- Booleans + , Prims.bpTrue = True + , Prims.bpFalse = False + , Prims.bpNot = pure1 not + , Prims.bpAnd = pure2 (&&) + , Prims.bpOr = pure2 (||) + , Prims.bpXor = pure2 (/=) + , Prims.bpBoolEq = pure2 (==) + -- Bitvector logical + , Prims.bpBvNot = pure1 (Prim.bvNot undefined) + , Prims.bpBvAnd = pure2 (Prim.bvAnd undefined) + , Prims.bpBvOr = pure2 (Prim.bvOr undefined) + , Prims.bpBvXor = pure2 (Prim.bvXor undefined) + -- Bitvector arithmetic + , Prims.bpBvNeg = pure1 (Prim.bvNeg undefined) + , Prims.bpBvAdd = pure2 (Prim.bvAdd undefined) + , Prims.bpBvSub = pure2 (Prim.bvSub undefined) + , Prims.bpBvMul = pure2 (Prim.bvMul undefined) + , Prims.bpBvUDiv = divOp (Prim.bvUDiv undefined) + , Prims.bpBvURem = divOp (Prim.bvURem undefined) + , Prims.bpBvSDiv = divOp (Prim.bvSDiv undefined) + , Prims.bpBvSRem = divOp (Prim.bvSRem undefined) + , Prims.bpBvLg2 = pure1 Prim.bvLg2 + -- Bitvector comparisons + , Prims.bpBvEq = pure2 (Prim.bvEq undefined) + , Prims.bpBvsle = pure2 (Prim.bvsle undefined) + , Prims.bpBvslt = pure2 (Prim.bvslt undefined) + , Prims.bpBvule = pure2 (Prim.bvule undefined) + , Prims.bpBvult = pure2 (Prim.bvult undefined) + , Prims.bpBvsge = pure2 (Prim.bvsge undefined) + , Prims.bpBvsgt = pure2 (Prim.bvsgt undefined) + , Prims.bpBvuge = pure2 (Prim.bvuge undefined) + , Prims.bpBvugt = pure2 (Prim.bvugt undefined) + -- Bitvector shift/rotate + , Prims.bpBvRolInt = pure2 bvRotateL + , Prims.bpBvRorInt = pure2 bvRotateR + , Prims.bpBvShlInt = pure3 bvShiftL + , Prims.bpBvShrInt = pure3 bvShiftR + , Prims.bpBvRol = pure2 (\x y -> bvRotateL x (unsigned y)) + , Prims.bpBvRor = pure2 (\x y -> bvRotateR x (unsigned y)) + , Prims.bpBvShl = pure3 (\b x y -> bvShiftL b x (unsigned y)) + , Prims.bpBvShr = pure3 (\b x y -> bvShiftR b x (unsigned y)) + -- Bitvector misc + , Prims.bpBvPopcount = pure1 (Prim.bvPopcount undefined) + , Prims.bpBvCountLeadingZeros = pure1 (Prim.bvCountLeadingZeros undefined) + , Prims.bpBvCountTrailingZeros = pure1 (Prim.bvCountTrailingZeros undefined) + , Prims.bpBvForall = unsupportedConcretePrimitive "bvForall" + + -- Integer operations + , Prims.bpIntAdd = pure2 (+) + , Prims.bpIntSub = pure2 (-) + , Prims.bpIntMul = pure2 (*) + , Prims.bpIntDiv = pure2 div + , Prims.bpIntMod = pure2 mod + , Prims.bpIntNeg = pure1 negate + , Prims.bpIntAbs = pure1 abs + , Prims.bpIntEq = pure2 (==) + , Prims.bpIntLe = pure2 (<=) + , Prims.bpIntLt = pure2 (<) + , Prims.bpIntMin = pure2 min + , Prims.bpIntMax = pure2 max + + -- Array operations + , Prims.bpArrayConstant = unsupportedConcretePrimitive "bpArrayConstant" + , Prims.bpArrayLookup = unsupportedConcretePrimitive "bpArrayLookup" + , Prims.bpArrayUpdate = unsupportedConcretePrimitive "bpArrayUpdate" + , Prims.bpArrayEq = unsupportedConcretePrimitive "bpArrayEq" + } + +unsupportedConcretePrimitive :: String -> a +unsupportedConcretePrimitive = Prim.unsupportedPrimitive "concrete" + +constMap :: Map Ident CValue +constMap = + flip Map.union (Prims.constMap prims) $ + Map.fromList + -- Shifts + [ ("Prelude.bvShl" , bvShiftOp (Prim.bvShl undefined)) + , ("Prelude.bvShr" , bvShiftOp (Prim.bvShr undefined)) + , ("Prelude.bvSShr", bvShiftOp (Prim.bvSShr undefined)) + -- Integers + , ("Prelude.intToNat", Prims.intToNatOp) + , ("Prelude.natToInt", Prims.natToIntOp) + , ("Prelude.intToBv" , intToBvOp) + , ("Prelude.bvToInt" , bvToIntOp) + , ("Prelude.sbvToInt", sbvToIntOp) + -- Integers mod n + , ("Prelude.toIntMod" , toIntModOp) + , ("Prelude.fromIntMod", fromIntModOp) + , ("Prelude.intModEq" , intModEqOp) + , ("Prelude.intModAdd" , intModBinOp (+)) + , ("Prelude.intModSub" , intModBinOp (-)) + , ("Prelude.intModMul" , intModBinOp (*)) + , ("Prelude.intModNeg" , intModUnOp negate) + -- Streams + , ("Prelude.MkStream", mkStreamOp) + , ("Prelude.streamGet", streamGetOp) + -- Miscellaneous + , ("Prelude.bvToNat", bvToNatOp) -- override Prims.constMap + , ("Prelude.expByNat", Prims.expByNatOp prims) + ] + +------------------------------------------------------------ + +-- primitive bvToNat : (n : Nat) -> Vec n Bool -> Nat; +bvToNatOp :: CValue +bvToNatOp = constFun $ wordFun $ VNat . fromInteger . unsigned + +-- primitive bvToInt : (n : Nat) -> Vec n Bool -> Integer; +bvToIntOp :: CValue +bvToIntOp = constFun $ wordFun $ VInt . unsigned + +-- primitive sbvToInt : (n : Nat) -> Vec n Bool -> Integer; +sbvToIntOp :: CValue +sbvToIntOp = constFun $ wordFun $ VInt . signed + +-- primitive intToBv : (n : Nat) -> Integer -> Vec n Bool; +intToBvOp :: CValue +intToBvOp = + Prims.natFun' "intToBv n" $ \n -> return $ + Prims.intFun "intToBv x" $ \x -> return $ + VWord $ + if n >= 0 then bv (fromIntegral n) x + else bvNeg n $ bv (fromIntegral n) $ negate x + +------------------------------------------------------------ +-- BitVector operations + +bvRotateL :: BitVector -> Integer -> BitVector +bvRotateL (BV w x) i = Prim.bv w ((x `shiftL` j) .|. (x `shiftR` (w - j))) + where j = fromInteger (i `mod` toInteger w) + +bvRotateR :: BitVector -> Integer -> BitVector +bvRotateR w i = bvRotateL w (- i) + +bvShiftL :: Bool -> BitVector -> Integer -> BitVector +bvShiftL c (BV w x) i = Prim.bv w ((x `shiftL` j) .|. c') + where c' = if c then (1 `shiftL` j) - 1 else 0 + j = fromInteger (i `min` toInteger w) + +bvShiftR :: Bool -> BitVector -> Integer -> BitVector +bvShiftR c (BV w x) i = Prim.bv w (c' .|. (x `shiftR` j)) + where c' = if c then (full `shiftL` (w - j)) .&. full else 0 + full = (1 `shiftL` w) - 1 + j = fromInteger (i `min` toInteger w) + +------------------------------------------------------------ + +toIntModOp :: CValue +toIntModOp = + Prims.natFun $ \n -> return $ + Prims.intFun "toIntModOp" $ \x -> return $ + VIntMod n (x `mod` toInteger n) + +fromIntModOp :: CValue +fromIntModOp = + constFun $ + Prims.intModFun "fromIntModOp" $ \x -> pure $ + VInt x + +intModEqOp :: CValue +intModEqOp = + constFun $ + Prims.intModFun "intModEqOp" $ \x -> return $ + Prims.intModFun "intModEqOp" $ \y -> return $ + VBool (x == y) + +intModBinOp :: (Integer -> Integer -> Integer) -> CValue +intModBinOp f = + Prims.natFun $ \n -> return $ + Prims.intModFun "intModBinOp x" $ \x -> return $ + Prims.intModFun "intModBinOp y" $ \y -> return $ + VIntMod n (f x y `mod` toInteger n) + +intModUnOp :: (Integer -> Integer) -> CValue +intModUnOp f = + Prims.natFun $ \n -> return $ + Prims.intModFun "intModUnOp" $ \x -> return $ + VIntMod n (f x `mod` toInteger n) + +------------------------------------------------------------ + +-- MkStream :: (a :: sort 0) -> (Nat -> a) -> Stream a; +mkStreamOp :: CValue +mkStreamOp = + constFun $ + pureFun $ \f -> + vStream (fmap (\n -> runIdentity (apply f (ready (VNat n)))) IntTrie.identity) + +-- streamGet :: (a :: sort 0) -> Stream a -> Nat -> a; +streamGetOp :: CValue +streamGetOp = + constFun $ + pureFun $ \xs -> + strictFun $ \case + VNat n -> return $ IntTrie.apply (toStream xs) (toInteger n) + VToNat w -> return $ IntTrie.apply (toStream xs) (unsigned (toWord w)) + n -> Prims.panic "Verifier.SAW.Simulator.Concrete.streamGetOp" + ["Expected Nat value", show n] diff --git a/saw-core/src/Verifier/SAW/Simulator/MonadLazy.hs b/saw-core/src/Verifier/SAW/Simulator/MonadLazy.hs new file mode 100644 index 0000000000..575a382e91 --- /dev/null +++ b/saw-core/src/Verifier/SAW/Simulator/MonadLazy.hs @@ -0,0 +1,42 @@ +{- | +Module : Verifier.SAW.Simulator.MonadLazy +Copyright : Galois, Inc. 2012-2015 +License : BSD3 +Maintainer : huffman@galois.com +Stability : experimental +Portability : non-portable (language extensions) +-} +module Verifier.SAW.Simulator.MonadLazy where + +import Control.Monad.Identity +import Control.Monad.IO.Class +import Data.IORef + +newtype Lazy m a = Lazy (m a) + +class Monad m => MonadLazy m where + delay :: m a -> m (Lazy m a) + +force :: Lazy m a -> m a +force (Lazy m) = m + +ready :: Monad m => a -> Lazy m a +ready x = Lazy (return x) + +instance MonadLazy Identity where + delay m = return (Lazy m) + +instance MonadLazy IO where + delay = delayIO + +delayIO :: MonadIO m => m a -> m (Lazy m a) +delayIO m = liftM pull (liftIO (newIORef Nothing)) + where + pull ref = Lazy $ do + r <- liftIO (readIORef ref) + case r of + Nothing -> do + x <- m + liftIO (writeIORef ref (Just x)) + return x + Just x -> return x diff --git a/saw-core/src/Verifier/SAW/Simulator/Prims.hs b/saw-core/src/Verifier/SAW/Simulator/Prims.hs new file mode 100644 index 0000000000..896bdcaa06 --- /dev/null +++ b/saw-core/src/Verifier/SAW/Simulator/Prims.hs @@ -0,0 +1,1350 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DoAndIfThenElse #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TupleSections #-} + +{- | +Module : Verifier.SAW.Simulator.Prims +Copyright : Galois, Inc. 2012-2015 +License : BSD3 +Maintainer : jhendrix@galois.com +Stability : experimental +Portability : non-portable (language extensions) +-} + +module Verifier.SAW.Simulator.Prims where + +import Prelude hiding (sequence, mapM) + +import GHC.Stack( HasCallStack ) + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif +import Control.Monad (foldM, liftM, zipWithM, unless) +import Control.Monad.Fix (MonadFix(mfix)) +import Data.Bits +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Data.Text as Text +import Data.Traversable +import Data.Vector (Vector) +import qualified Data.Vector as V +import Numeric.Natural (Natural) + +import Verifier.SAW.Term.Functor (Ident, alistAllFields) +import Verifier.SAW.Simulator.Value +import Verifier.SAW.Prim +import qualified Verifier.SAW.Prim as Prim + +import qualified Verifier.SAW.Utils as Panic (panic) + +------------------------------------------------------------ +-- + +-- | A collection of implementations of primitives on base types. +-- These can be used to derive other primitives on higher types. +data BasePrims l = + BasePrims + { bpAsBool :: VBool l -> Maybe Bool + -- Bitvectors + , bpUnpack :: VWord l -> EvalM l (Vector (VBool l)) + , bpPack :: Vector (VBool l) -> MWord l + , bpBvAt :: VWord l -> Int -> MBool l + , bpBvLit :: Int -> Integer -> MWord l + , bpBvSize :: VWord l -> Int + , bpBvJoin :: VWord l -> VWord l -> MWord l + , bpBvSlice :: Int -> Int -> VWord l -> MWord l + -- Conditionals + , bpMuxBool :: VBool l -> VBool l -> VBool l -> MBool l + , bpMuxWord :: VBool l -> VWord l -> VWord l -> MWord l + , bpMuxInt :: VBool l -> VInt l -> VInt l -> MInt l + , bpMuxExtra :: VBool l -> Extra l -> Extra l -> EvalM l (Extra l) + -- Booleans + , bpTrue :: VBool l + , bpFalse :: VBool l + , bpNot :: VBool l -> MBool l + , bpAnd :: VBool l -> VBool l -> MBool l + , bpOr :: VBool l -> VBool l -> MBool l + , bpXor :: VBool l -> VBool l -> MBool l + , bpBoolEq :: VBool l -> VBool l -> MBool l + -- Bitvector logical + , bpBvNot :: VWord l -> MWord l + , bpBvAnd :: VWord l -> VWord l -> MWord l + , bpBvOr :: VWord l -> VWord l -> MWord l + , bpBvXor :: VWord l -> VWord l -> MWord l + -- Bitvector arithmetic + , bpBvNeg :: VWord l -> MWord l + , bpBvAdd :: VWord l -> VWord l -> MWord l + , bpBvSub :: VWord l -> VWord l -> MWord l + , bpBvMul :: VWord l -> VWord l -> MWord l + , bpBvUDiv :: VWord l -> VWord l -> MWord l + , bpBvURem :: VWord l -> VWord l -> MWord l + , bpBvSDiv :: VWord l -> VWord l -> MWord l + , bpBvSRem :: VWord l -> VWord l -> MWord l + , bpBvLg2 :: VWord l -> MWord l + -- Bitvector comparisons + , bpBvEq :: VWord l -> VWord l -> MBool l + , bpBvsle :: VWord l -> VWord l -> MBool l + , bpBvslt :: VWord l -> VWord l -> MBool l + , bpBvule :: VWord l -> VWord l -> MBool l + , bpBvult :: VWord l -> VWord l -> MBool l + , bpBvsge :: VWord l -> VWord l -> MBool l + , bpBvsgt :: VWord l -> VWord l -> MBool l + , bpBvuge :: VWord l -> VWord l -> MBool l + , bpBvugt :: VWord l -> VWord l -> MBool l + -- Bitvector shift/rotate + , bpBvRolInt :: VWord l -> Integer -> MWord l + , bpBvRorInt :: VWord l -> Integer -> MWord l + , bpBvShlInt :: VBool l -> VWord l -> Integer -> MWord l + , bpBvShrInt :: VBool l -> VWord l -> Integer -> MWord l + , bpBvRol :: VWord l -> VWord l -> MWord l + , bpBvRor :: VWord l -> VWord l -> MWord l + , bpBvShl :: VBool l -> VWord l -> VWord l -> MWord l + , bpBvShr :: VBool l -> VWord l -> VWord l -> MWord l + -- Bitvector misc + , bpBvPopcount :: VWord l -> MWord l + , bpBvCountLeadingZeros :: VWord l -> MWord l + , bpBvCountTrailingZeros :: VWord l -> MWord l + , bpBvForall :: Natural -> (VWord l -> MBool l) -> MBool l + -- Integer operations + , bpIntAdd :: VInt l -> VInt l -> MInt l + , bpIntSub :: VInt l -> VInt l -> MInt l + , bpIntMul :: VInt l -> VInt l -> MInt l + , bpIntDiv :: VInt l -> VInt l -> MInt l + , bpIntMod :: VInt l -> VInt l -> MInt l + , bpIntNeg :: VInt l -> MInt l + , bpIntAbs :: VInt l -> MInt l + , bpIntEq :: VInt l -> VInt l -> MBool l + , bpIntLe :: VInt l -> VInt l -> MBool l + , bpIntLt :: VInt l -> VInt l -> MBool l + , bpIntMin :: VInt l -> VInt l -> MInt l + , bpIntMax :: VInt l -> VInt l -> MInt l + -- Array operations + , bpArrayConstant :: TValue l -> Value l -> MArray l + , bpArrayLookup :: VArray l -> Value l -> MValue l + , bpArrayUpdate :: VArray l -> Value l -> Value l -> MArray l + , bpArrayEq :: VArray l -> VArray l -> MBool l + } + +bpBool :: VMonad l => BasePrims l -> Bool -> MBool l +bpBool bp True = return (bpTrue bp) +bpBool bp False = return (bpFalse bp) + +-- | Given implementations of the base primitives, construct a table +-- containing implementations of all primitives. +constMap :: + forall l. + (VMonadLazy l, MonadFix (EvalM l), Show (Extra l)) => + BasePrims l -> Map Ident (Value l) +constMap bp = Map.fromList + -- Boolean + [ ("Prelude.Bool" , TValue VBoolType) + , ("Prelude.True" , VBool (bpTrue bp)) + , ("Prelude.False" , VBool (bpFalse bp)) + , ("Prelude.not" , strictFun (liftM VBool . bpNot bp . toBool)) + , ("Prelude.and" , boolBinOp (bpAnd bp)) + , ("Prelude.or" , boolBinOp (bpOr bp)) + , ("Prelude.xor" , boolBinOp (bpXor bp)) + , ("Prelude.boolEq", boolBinOp (bpBoolEq bp)) + -- Bitwise + , ("Prelude.bvAnd" , wordBinOp (bpPack bp) (bpBvAnd bp)) + , ("Prelude.bvOr" , wordBinOp (bpPack bp) (bpBvOr bp)) + , ("Prelude.bvXor" , wordBinOp (bpPack bp) (bpBvXor bp)) + , ("Prelude.bvNot" , wordUnOp (bpPack bp) (bpBvNot bp)) + -- Arithmetic + , ("Prelude.bvNeg" , wordUnOp (bpPack bp) (bpBvNeg bp)) + , ("Prelude.bvAdd" , wordBinOp (bpPack bp) (bpBvAdd bp)) + , ("Prelude.bvSub" , wordBinOp (bpPack bp) (bpBvSub bp)) + , ("Prelude.bvMul" , wordBinOp (bpPack bp) (bpBvMul bp)) + , ("Prelude.bvUDiv", wordBinOp (bpPack bp) (bpBvUDiv bp)) + , ("Prelude.bvURem", wordBinOp (bpPack bp) (bpBvURem bp)) + , ("Prelude.bvSDiv", wordBinOp (bpPack bp) (bpBvSDiv bp)) + , ("Prelude.bvSRem", wordBinOp (bpPack bp) (bpBvSRem bp)) + , ("Prelude.bvLg2" , wordUnOp (bpPack bp) (bpBvLg2 bp)) + -- Comparisons + , ("Prelude.bvEq" , wordBinRel (bpPack bp) (bpBvEq bp)) + , ("Prelude.bvsle" , wordBinRel (bpPack bp) (bpBvsle bp)) + , ("Prelude.bvslt" , wordBinRel (bpPack bp) (bpBvslt bp)) + , ("Prelude.bvule" , wordBinRel (bpPack bp) (bpBvule bp)) + , ("Prelude.bvult" , wordBinRel (bpPack bp) (bpBvult bp)) + , ("Prelude.bvsge" , wordBinRel (bpPack bp) (bpBvsge bp)) + , ("Prelude.bvsgt" , wordBinRel (bpPack bp) (bpBvsgt bp)) + , ("Prelude.bvuge" , wordBinRel (bpPack bp) (bpBvuge bp)) + , ("Prelude.bvugt" , wordBinRel (bpPack bp) (bpBvugt bp)) + -- Bitvector misc + , ("Prelude.bvPopcount", wordUnOp (bpPack bp) (bpBvPopcount bp)) + , ("Prelude.bvCountLeadingZeros", wordUnOp (bpPack bp) (bpBvCountLeadingZeros bp)) + , ("Prelude.bvCountTrailingZeros", wordUnOp (bpPack bp) (bpBvCountTrailingZeros bp)) + , ("Prelude.bvForall", natFun $ \n -> + pure . strictFun $ fmap VBool . bpBvForall bp n . toWordPred + ) + +{- + -- Shifts + , ("Prelude.bvShl" , bvShLOp) + , ("Prelude.bvShr" , bvShROp) + , ("Prelude.bvSShr", bvSShROp) +-} + -- Nat + , ("Prelude.Succ", succOp) + , ("Prelude.addNat", addNatOp) + , ("Prelude.subNat", subNatOp bp) + , ("Prelude.mulNat", mulNatOp) + , ("Prelude.minNat", minNatOp) + , ("Prelude.maxNat", maxNatOp) + , ("Prelude.divModNat", divModNatOp) + , ("Prelude.expNat", expNatOp) + , ("Prelude.widthNat", widthNatOp) + , ("Prelude.natCase", natCaseOp) + , ("Prelude.equalNat", equalNatOp bp) + , ("Prelude.ltNat", ltNatOp bp) + -- Integers + , ("Prelude.Integer", TValue VIntType) + , ("Prelude.intAdd", intBinOp "intAdd" (bpIntAdd bp)) + , ("Prelude.intSub", intBinOp "intSub" (bpIntSub bp)) + , ("Prelude.intMul", intBinOp "intMul" (bpIntMul bp)) + , ("Prelude.intDiv", intBinOp "intDiv" (bpIntDiv bp)) + , ("Prelude.intMod", intBinOp "intMod" (bpIntMod bp)) + , ("Prelude.intNeg", intUnOp "intNeg" (bpIntNeg bp)) + , ("Prelude.intAbs", intUnOp "intAbs" (bpIntAbs bp)) + , ("Prelude.intEq" , intBinCmp "intEq" (bpIntEq bp)) + , ("Prelude.intLe" , intBinCmp "intLe" (bpIntLe bp)) + , ("Prelude.intLt" , intBinCmp "intLt" (bpIntLt bp)) +{- + --XXX , ("Prelude.intToNat", Prims.intToNatOp) + , ("Prelude.natToInt", natToIntOp) + , ("Prelude.intToBv" , intToBvOp) + , ("Prelude.bvToInt" , bvToIntOp) + , ("Prelude.sbvToInt", sbvToIntOp) + --XXX , ("Prelude.intMin" , Prims.intMinOp) + --XXX , ("Prelude.intMax" , Prims.intMaxOp) +-} + , ("Prelude.intMin", intBinOp "intMin" (bpIntMin bp)) + , ("Prelude.intMax", intBinOp "intMax" (bpIntMax bp)) + -- Modular Integers + , ("Prelude.IntMod", natFun $ \n -> pure $ TValue (VIntModType n)) + -- Vectors + , ("Prelude.Vec", vecTypeOp) + , ("Prelude.gen", genOp) + , ("Prelude.atWithDefault", atWithDefaultOp bp) + , ("Prelude.upd", updOp bp) + , ("Prelude.take", takeOp bp) + , ("Prelude.drop", dropOp bp) + , ("Prelude.append", appendOp bp) + , ("Prelude.join", joinOp bp) + , ("Prelude.split", splitOp bp) + , ("Prelude.zip", vZipOp (bpUnpack bp)) + , ("Prelude.foldr", foldrOp (bpUnpack bp)) + , ("Prelude.rotateL", rotateLOp bp) + , ("Prelude.rotateR", rotateROp bp) + , ("Prelude.shiftL", shiftLOp bp) + , ("Prelude.shiftR", shiftROp bp) + , ("Prelude.EmptyVec", emptyVec) + -- Miscellaneous + , ("Prelude.coerce", coerceOp) + , ("Prelude.bvNat", bvNatOp bp) + , ("Prelude.bvToNat", bvToNatOp) + , ("Prelude.error", errorOp) + , ("Prelude.fix", fixOp) + -- Overloaded + , ("Prelude.ite", iteOp bp) + , ("Prelude.iteDep", iteOp bp) + -- SMT Arrays + , ("Prelude.Array", arrayTypeOp) + , ("Prelude.arrayConstant", arrayConstantOp bp) + , ("Prelude.arrayLookup", arrayLookupOp bp) + , ("Prelude.arrayUpdate", arrayUpdateOp bp) + , ("Prelude.arrayEq", arrayEqOp bp) + ] + +-- | Call this function to indicate that a programming error has +-- occurred, e.g. a datatype invariant has been violated. +panic :: HasCallStack => String -> a +panic msg = Panic.panic "Verifier.SAW.Simulator.Prims" [msg] + +------------------------------------------------------------ +-- Value accessors and constructors + +vNat :: Natural -> Value l +vNat n = VNat n + +natFromValue :: Value l -> Natural +natFromValue (VNat n) = n +natFromValue _ = panic "natFromValue" + +natFun'' :: (HasCallStack, VMonad l, Show (Extra l)) => String -> (Natural -> MValue l) -> Value l +natFun'' s f = strictFun g + where g (VNat n) = f n + g v = panic $ "expected Nat (" ++ s ++ "): " ++ show v + +natFun' :: (HasCallStack, VMonad l) => String -> (Natural -> MValue l) -> Value l +natFun' s f = strictFun g + where g (VNat n) = f n + g _ = panic $ "expected Nat: " ++ s + +natFun :: (HasCallStack, VMonad l) => (Natural -> MValue l) -> Value l +natFun f = strictFun g + where g (VNat n) = f n + g _ = panic "expected Nat" + +intFun :: VMonad l => String -> (VInt l -> MValue l) -> Value l +intFun msg f = strictFun g + where g (VInt i) = f i + g _ = panic $ "expected Integer "++ msg + +intModFun :: VMonad l => String -> (VInt l -> MValue l) -> Value l +intModFun msg f = strictFun g + where g (VIntMod _ i) = f i + g _ = panic $ "expected IntMod "++ msg + +toBool :: Show (Extra l) => Value l -> VBool l +toBool (VBool b) = b +toBool x = panic $ unwords ["Verifier.SAW.Simulator.toBool", show x] + +type Pack l = Vector (VBool l) -> MWord l +type Unpack l = VWord l -> EvalM l (Vector (VBool l)) + +toWord :: (VMonad l, Show (Extra l)) => Pack l -> Value l -> MWord l +toWord _ (VWord w) = return w +toWord pack (VVector vv) = pack =<< V.mapM (liftM toBool . force) vv +toWord _ x = panic $ unwords ["Verifier.SAW.Simulator.toWord", show x] + +toWordPred :: (VMonad l, Show (Extra l)) => Value l -> VWord l -> MBool l +toWordPred (VFun f) = fmap toBool . f . ready . VWord +toWordPred x = panic $ unwords ["Verifier.SAW.Simulator.toWordPred", show x] + +toBits :: (VMonad l, Show (Extra l)) => Unpack l -> Value l -> + EvalM l (Vector (VBool l)) +toBits unpack (VWord w) = unpack w +toBits _ (VVector v) = V.mapM (liftM toBool . force) v +toBits _ x = panic $ unwords ["Verifier.SAW.Simulator.toBits", show x] + +toVector :: (VMonad l, Show (Extra l)) => Unpack l + -> Value l -> EvalM l (Vector (Thunk l)) +toVector _ (VVector v) = return v +toVector unpack (VWord w) = liftM (fmap (ready . VBool)) (unpack w) +toVector _ x = panic $ unwords ["Verifier.SAW.Simulator.toVector", show x] + +wordFun :: (VMonad l, Show (Extra l)) => Pack l -> (VWord l -> MValue l) -> Value l +wordFun pack f = strictFun (\x -> toWord pack x >>= f) + +bitsFun :: (VMonad l, Show (Extra l)) => + Unpack l -> (Vector (VBool l) -> MValue l) -> Value l +bitsFun unpack f = strictFun (\x -> toBits unpack x >>= f) + +vectorFun :: (VMonad l, Show (Extra l)) => + Unpack l -> (Vector (Thunk l) -> MValue l) -> Value l +vectorFun unpack f = strictFun (\x -> toVector unpack x >>= f) + +vecIdx :: a -> Vector a -> Int -> a +vecIdx err v n = + case (V.!?) v n of + Just a -> a + Nothing -> err + +toArray :: (VMonad l, Show (Extra l)) => Value l -> MArray l +toArray (VArray f) = return f +toArray x = panic $ unwords ["Verifier.SAW.Simulator.toArray", show x] + +------------------------------------------------------------ +-- Standard operator types + +-- op :: Bool -> Bool -> Bool; +boolBinOp :: + (VMonad l, Show (Extra l)) => + (VBool l -> VBool l -> MBool l) -> Value l +boolBinOp op = + strictFun $ \x -> return $ + strictFun $ \y -> VBool <$> op (toBool x) (toBool y) + +-- op : (n : Nat) -> Vec n Bool -> Vec n Bool; +wordUnOp :: + (VMonad l, Show (Extra l)) => + Pack l -> (VWord l -> MWord l) -> Value l +wordUnOp pack op = + constFun $ + strictFun $ \x -> + do xw <- toWord pack x + VWord <$> op xw + +-- op : (n : Nat) -> Vec n Bool -> Vec n Bool -> Vec n Bool; +wordBinOp :: + (VMonad l, Show (Extra l)) => + Pack l -> (VWord l -> VWord l -> MWord l) -> Value l +wordBinOp pack op = + constFun $ + strictFun $ \x -> return $ + strictFun $ \y -> + do xw <- toWord pack x + yw <- toWord pack y + VWord <$> op xw yw + +-- op : (n : Nat) -> Vec n Bool -> Vec n Bool -> Bool; +wordBinRel :: + (VMonad l, Show (Extra l)) => + Pack l -> (VWord l -> VWord l -> MBool l) -> Value l +wordBinRel pack op = + constFun $ + strictFun $ \x -> return $ + strictFun $ \y -> + do xw <- toWord pack x + yw <- toWord pack y + VBool <$> op xw yw + +------------------------------------------------------------ +-- Utility functions + +-- @selectV mux maxValue valueFn v@ treats the vector @v@ as an +-- index, represented as a big-endian list of bits. It does a binary +-- lookup, using @mux@ as an if-then-else operator. If the index is +-- greater than @maxValue@, then it returns @valueFn maxValue@. +selectV :: (b -> a -> a -> a) -> Int -> (Int -> a) -> Vector b -> a +selectV mux maxValue valueFn v = impl len 0 + where + len = V.length v + err = panic "selectV: impossible" + impl _ x | x > maxValue || x < 0 = valueFn maxValue + impl 0 x = valueFn x + impl i x = mux (vecIdx err v (len - i)) (impl j (x `setBit` j)) (impl j x) where j = i - 1 + +------------------------------------------------------------ +-- Values for common primitives + +-- bvNat : (n : Nat) -> Nat -> Vec n Bool; +bvNatOp :: (VMonad l, Show (Extra l)) => BasePrims l -> Value l +bvNatOp bp = + natFun'' "bvNatOp1" $ \w -> return $ + natFun'' "bvNatOp2" $ \x -> + VWord <$> bpBvLit bp (fromIntegral w) (toInteger x) -- FIXME check for overflow on w + +-- bvToNat : (n : Nat) -> Vec n Bool -> Nat; +bvToNatOp :: VMonad l => Value l +bvToNatOp = constFun $ pureFun VToNat + +-- coerce :: (a b :: sort 0) -> Eq (sort 0) a b -> a -> b; +coerceOp :: VMonad l => Value l +coerceOp = + constFun $ + constFun $ + constFun $ + VFun force + +------------------------------------------------------------ +-- Nat primitives + +-- | Return the number of bits necessary to represent the given value, +-- which should be a value of type Nat. +natSize :: BasePrims l -> Value l -> Natural +natSize bp val = + case val of + VNat n -> widthNat n + VToNat (VVector v) -> fromIntegral (V.length v) + VToNat (VWord w) -> fromIntegral (bpBvSize bp w) + _ -> panic "natSize: expected Nat" + +-- | Convert the given value (which should be of type Nat) to a word +-- of the given bit-width. The bit-width must be at least as large as +-- that returned by @natSize@. +natToWord :: (VMonad l, Show (Extra l)) => BasePrims l -> Int -> Value l -> MWord l +natToWord bp w val = + case val of + VNat n -> bpBvLit bp w (toInteger n) + VToNat v -> + do x <- toWord (bpPack bp) v + let xsize = bpBvSize bp x + case compare xsize w of + GT -> panic "natToWord: not enough bits" + EQ -> return x + LT -> -- zero-extend x to width w + do pad <- bpBvLit bp (w - xsize) 0 + bpBvJoin bp pad x + _ -> panic "natToWord: expected Nat" + +-- Succ :: Nat -> Nat; +succOp :: VMonad l => Value l +succOp = + natFun' "Succ" $ \n -> return $ + vNat (succ n) + +-- addNat :: Nat -> Nat -> Nat; +addNatOp :: VMonad l => Value l +addNatOp = + natFun' "addNat1" $ \m -> return $ + natFun' "addNat2" $ \n -> return $ + vNat (m + n) + +-- subNat :: Nat -> Nat -> Nat; +subNatOp :: (VMonad l, Show (Extra l)) => BasePrims l -> Value l +subNatOp bp = + strictFun $ \x -> return $ + strictFun $ \y -> g x y + where + g (VNat i) (VNat j) = return $ VNat (if i < j then 0 else i - j) + g v1 v2 = + do let w = toInteger (max (natSize bp v1) (natSize bp v2)) + unless (w <= toInteger (maxBound :: Int)) + (panic "subNatOp" ["width too large", show w]) + x1 <- natToWord bp (fromInteger w) v1 + x2 <- natToWord bp (fromInteger w) v2 + lt <- bpBvult bp x1 x2 + z <- bpBvLit bp (fromInteger w) 0 + d <- bpBvSub bp x1 x2 + VToNat . VWord <$> bpMuxWord bp lt z d + +-- mulNat :: Nat -> Nat -> Nat; +mulNatOp :: VMonad l => Value l +mulNatOp = + natFun' "mulNat1" $ \m -> return $ + natFun' "mulNat2" $ \n -> return $ + vNat (m * n) + +-- minNat :: Nat -> Nat -> Nat; +minNatOp :: VMonad l => Value l +minNatOp = + natFun' "minNat1" $ \m -> return $ + natFun' "minNat2" $ \n -> return $ + vNat (min m n) + +-- maxNat :: Nat -> Nat -> Nat; +maxNatOp :: VMonad l => Value l +maxNatOp = + natFun' "maxNat1" $ \m -> return $ + natFun' "maxNat2" $ \n -> return $ + vNat (max m n) + +-- divModNat :: Nat -> Nat -> #(Nat, Nat); +divModNatOp :: VMonad l => Value l +divModNatOp = + natFun' "divModNat1" $ \m -> return $ + natFun' "divModNat2" $ \n -> return $ + let (q,r) = divMod m n in + vTuple [ready $ vNat q, ready $ vNat r] + +-- expNat :: Nat -> Nat -> Nat; +expNatOp :: VMonad l => Value l +expNatOp = + natFun' "expNat1" $ \m -> return $ + natFun' "expNat2" $ \n -> return $ + vNat (m ^ n) + +-- widthNat :: Nat -> Nat; +widthNatOp :: VMonad l => Value l +widthNatOp = + natFun' "widthNat1" $ \n -> return $ + vNat (widthNat n) + +-- equalNat :: Nat -> Nat -> Bool; +equalNatOp :: (VMonad l, Show (Extra l)) => BasePrims l -> Value l +equalNatOp bp = + strictFun $ \x -> return $ + strictFun $ \y -> g x y + where + g (VNat i) (VNat j) = VBool <$> bpBool bp (i == j) + g v1 v2 = + do let w = toInteger (max (natSize bp v1) (natSize bp v2)) + unless (w <= toInteger (maxBound :: Int)) + (panic "equalNatOp" ["width too large", show w]) + x1 <- natToWord bp (fromInteger w) v1 + x2 <- natToWord bp (fromInteger w) v2 + VBool <$> bpBvEq bp x1 x2 + +-- ltNat :: Nat -> Nat -> Bool; +ltNatOp :: (VMonad l, Show (Extra l)) => BasePrims l -> Value l +ltNatOp bp = + strictFun $ \x -> return $ + strictFun $ \y -> g x y + where + g (VNat i) (VNat j) = VBool <$> bpBool bp (i < j) + g v1 v2 = + do let w = toInteger (max (natSize bp v1) (natSize bp v2)) + unless (w <= toInteger (maxBound :: Int)) + (panic "ltNatOp" ["width too large", show w]) + x1 <- natToWord bp (fromInteger w) v1 + x2 <- natToWord bp (fromInteger w) v2 + VBool <$> bpBvult bp x1 x2 + +-- natCase :: (p :: Nat -> sort 0) -> p Zero -> ((n :: Nat) -> p (Succ n)) -> (n :: Nat) -> p n; +natCaseOp :: (VMonad l, Show (Extra l)) => Value l +natCaseOp = + constFun $ + VFun $ \z -> return $ + VFun $ \s -> return $ + natFun' "natCase" $ \n -> + if n == 0 + then force z + else do s' <- force s + apply s' (ready (VNat (n - 1))) + +-------------------------------------------------------------------------------- + +-- Vec :: (n :: Nat) -> (a :: sort 0) -> sort 0; +vecTypeOp :: VMonad l => Value l +vecTypeOp = + natFun' "VecType" $ \n -> return $ + pureFun $ \a -> TValue (VVecType n (toTValue a)) + +-- gen :: (n :: Nat) -> (a :: sort 0) -> (Nat -> a) -> Vec n a; +genOp :: (VMonadLazy l, Show (Extra l)) => Value l +genOp = + natFun' "gen1" $ \n -> return $ + constFun $ + strictFun $ \f -> do + let g i = delay $ apply f (ready (VNat (fromIntegral i))) + if toInteger n > toInteger (maxBound :: Int) then + panic ("Verifier.SAW.Simulator.gen: vector size too large: " ++ show n) + else liftM VVector $ V.generateM (fromIntegral n) g + +-- eq :: (a :: sort 0) -> a -> a -> Bool +eqOp :: forall l. (VMonadLazy l, Show (Extra l)) => BasePrims l -> Value l +eqOp bp = + constFun $ pureFun $ \v1 -> strictFun $ \v2 -> VBool <$> go v1 v2 + where + go :: Value l -> Value l -> MBool l + go VUnit VUnit = return (bpTrue bp) + go (VPair x1 x2) (VPair y1 y2) = + do b1 <- go' x1 y1 + b2 <- go' x2 y2 + bpAnd bp b1 b2 + go (VWord w1) (VWord w2) = bpBvEq bp w1 w2 + go (VVector v1) (VVector v2) = + do bs <- sequence $ zipWith go' (V.toList v1) (V.toList v2) + foldM (bpAnd bp) (bpTrue bp) bs + go x1 (VVector v2) = + do v1 <- toVector (bpUnpack bp) x1 + go (VVector v1) (VVector v2) + go (VVector v1) x2 = + do v2 <- toVector (bpUnpack bp) x2 + go (VVector v1) (VVector v2) + go (VRecordValue elems1) (VRecordValue + (alistAllFields (map fst elems1) -> Just elems2)) = + zipWithM go' (map snd elems1) elems2 >>= foldM (bpAnd bp) (bpTrue bp) + go (VBool b1) (VBool b2) = bpBoolEq bp b1 b2 + go (VInt i1) (VInt i2) = bpIntEq bp i1 i2 + go (VArray f1) (VArray f2) = bpArrayEq bp f1 f2 + go x1 x2 = panic $ "eq: invalid arguments: " ++ show (x1, x2) + + go' :: Thunk l -> Thunk l -> MBool l + go' thunk1 thunk2 = + do v1 <- force thunk1 + v2 <- force thunk2 + go v1 v2 + +-- atWithDefault :: (n :: Nat) -> (a :: sort 0) -> a -> Vec n a -> Nat -> a; +atWithDefaultOp :: (VMonadLazy l, Show (Extra l)) => BasePrims l -> Value l +atWithDefaultOp bp = + natFun $ \n -> return $ + constFun $ + VFun $ \d -> return $ + strictFun $ \x -> return $ + strictFun $ \idx -> + case idx of + VNat i -> + case x of + VVector xv -> force (vecIdx d xv (fromIntegral i)) -- FIXME dangerous fromIntegral + VWord xw -> VBool <$> bpBvAt bp xw (fromIntegral i) -- FIXME dangerous fromIntegral + _ -> panic "atOp: expected vector" + VToNat i -> do + iv <- toBits (bpUnpack bp) i + case x of + VVector xv -> + selectV (lazyMuxValue bp) (fromIntegral n - 1) (force . vecIdx d xv) iv -- FIXME dangerous fromIntegral + VWord xw -> + selectV (lazyMuxValue bp) (fromIntegral n - 1) (liftM VBool . bpBvAt bp xw) iv -- FIXME dangerous fromIntegral + _ -> panic "atOp: expected vector" + _ -> panic $ "atOp: expected Nat, got " ++ show idx + +-- upd :: (n :: Nat) -> (a :: sort 0) -> Vec n a -> Nat -> a -> Vec n a; +updOp :: (VMonadLazy l, Show (Extra l)) => BasePrims l -> Value l +updOp bp = + natFun $ \n -> return $ + constFun $ + vectorFun (bpUnpack bp) $ \xv -> return $ + strictFun $ \idx -> return $ + VFun $ \y -> + case idx of + VNat i + | toInteger i < toInteger (V.length xv) + -> return (VVector (xv V.// [(fromIntegral i, y)])) + | otherwise -> return (VVector xv) + VToNat (VWord w) -> + do let wsize = bpBvSize bp w + f i = do b <- bpBvEq bp w =<< bpBvLit bp wsize (toInteger i) + if wsize < 64 && toInteger i >= 2 ^ wsize + then return (xv V.! i) + else delay (lazyMuxValue bp b (force y) (force (xv V.! i))) + yv <- V.generateM (V.length xv) f + return (VVector yv) + VToNat (VVector iv) -> + do let update i = return (VVector (xv V.// [(i, y)])) + iv' <- V.mapM (liftM toBool . force) iv + selectV (lazyMuxValue bp) (fromIntegral n - 1) update iv' -- FIXME dangerous fromIntegral + _ -> panic $ "updOp: expected Nat, got " ++ show idx + +-- primitive EmptyVec :: (a :: sort 0) -> Vec 0 a; +emptyVec :: VMonad l => Value l +emptyVec = constFun $ VVector V.empty + +-- take :: (a :: sort 0) -> (m n :: Nat) -> Vec (addNat m n) a -> Vec m a; +takeOp :: (VMonad l, Show (Extra l)) => BasePrims l -> Value l +takeOp bp = + constFun $ + natFun $ \(fromIntegral -> m) -> return $ -- FIXME dangerous fromIntegral + constFun $ + strictFun $ \v -> + case v of + VVector vv -> return (VVector (V.take m vv)) + VWord vw -> VWord <$> bpBvSlice bp 0 m vw + _ -> panic $ "takeOp: " ++ show v + +-- drop :: (a :: sort 0) -> (m n :: Nat) -> Vec (addNat m n) a -> Vec n a; +dropOp :: (VMonad l, Show (Extra l)) => BasePrims l -> Value l +dropOp bp = + constFun $ + natFun $ \(fromIntegral -> m) -> return $ -- FIXME dangerous fromIntegral + constFun $ + strictFun $ \v -> + case v of + VVector vv -> return (VVector (V.drop m vv)) + VWord vw -> VWord <$> bpBvSlice bp m (bpBvSize bp vw - m) vw + _ -> panic $ "dropOp: " ++ show v + +-- append :: (m n :: Nat) -> (a :: sort 0) -> Vec m a -> Vec n a -> Vec (addNat m n) a; +appendOp :: (VMonad l, Show (Extra l)) => BasePrims l -> Value l +appendOp bp = + constFun $ + constFun $ + constFun $ + strictFun $ \xs -> return $ + strictFun $ \ys -> + appV bp xs ys + +appV :: (VMonad l, Show (Extra l)) => BasePrims l -> Value l -> Value l -> MValue l +appV bp xs ys = + case (xs, ys) of + (VVector xv, _) | V.null xv -> return ys + (_, VVector yv) | V.null yv -> return xs + (VWord xw, VWord yw) -> VWord <$> bpBvJoin bp xw yw + (VVector xv, VVector yv) -> return $ VVector ((V.++) xv yv) + (VVector xv, VWord yw) -> liftM (\yv -> VVector ((V.++) xv (fmap (ready . VBool) yv))) (bpUnpack bp yw) + (VWord xw, VVector yv) -> liftM (\xv -> VVector ((V.++) (fmap (ready . VBool) xv) yv)) (bpUnpack bp xw) + _ -> panic $ "Verifier.SAW.Simulator.Prims.appendOp: " ++ show xs ++ ", " ++ show ys + +-- join :: (m n :: Nat) -> (a :: sort 0) -> Vec m (Vec n a) -> Vec (mulNat m n) a; +joinOp :: (VMonad l, Show (Extra l)) => BasePrims l -> Value l +joinOp bp = + constFun $ + constFun $ + constFun $ + strictFun $ \x -> + case x of + VVector xv -> do + vv <- V.mapM force xv + V.foldM (appV bp) (VVector V.empty) vv + _ -> panic "Verifier.SAW.Simulator.Prims.joinOp" + +-- split :: (m n :: Nat) -> (a :: sort 0) -> Vec (mulNat m n) a -> Vec m (Vec n a); +splitOp :: (VMonad l, Show (Extra l)) => BasePrims l -> Value l +splitOp bp = + natFun $ \(fromIntegral -> m) -> return $ -- FIXME dangerous fromIntegral + natFun $ \(fromIntegral -> n) -> return $ -- FIXME dangerous fromIntegral + constFun $ + strictFun $ \x -> + case x of + VVector xv -> + let f i = ready (VVector (V.slice (i*n) n xv)) + in return (VVector (V.generate m f)) + VWord xw -> + let f i = (ready . VWord) <$> bpBvSlice bp (i*n) n xw + in VVector <$> V.generateM m f + _ -> panic "Verifier.SAW.Simulator.SBV.splitOp" + +-- vZip :: (a b :: sort 0) -> (m n :: Nat) -> Vec m a -> Vec n b -> Vec (minNat m n) #(a, b); +vZipOp :: (VMonadLazy l, Show (Extra l)) => Unpack l -> Value l +vZipOp unpack = + constFun $ + constFun $ + constFun $ + constFun $ + strictFun $ \x -> return $ + strictFun $ \y -> + do xv <- toVector unpack x + yv <- toVector unpack y + let pair a b = ready (vTuple [a, b]) + return (VVector (V.zipWith pair xv yv)) + + +-------------------------------------------------------------------------- +-- Generic square-and-multiply + +-- primitive expByNat : (a:sort 0) -> a -> (a -> a -> a) -> a -> Nat -> a; +expByNatOp :: (MonadLazy (EvalM l), VMonad l, Show (Extra l)) => BasePrims l -> Value l +expByNatOp bp = + constFun $ + pureFun $ \one -> + pureFun $ \mul -> + pureFun $ \x -> + strictFun $ \case + VToNat w -> + do let loop acc [] = return acc + loop acc (b:bs) + | Just False <- bpAsBool bp b + = do sq <- applyAll mul [ ready acc, ready acc ] + loop sq bs + | Just True <- bpAsBool bp b + = do sq <- applyAll mul [ ready acc, ready acc ] + sq_x <- applyAll mul [ ready sq, ready x ] + loop sq_x bs + | otherwise + = do sq <- applyAll mul [ ready acc, ready acc ] + sq_x <- applyAll mul [ ready sq, ready x ] + acc' <- muxValue bp b sq_x sq + loop acc' bs + + loop one . V.toList =<< toBits (bpUnpack bp) w + + VNat n -> + do let loop acc [] = return acc + loop acc (False:bs) = + do sq <- applyAll mul [ ready acc, ready acc ] + loop sq bs + loop acc (True:bs) = + do sq <- applyAll mul [ ready acc, ready acc ] + sq_x <- applyAll mul [ ready sq, ready x ] + loop sq_x bs + + w = toInteger (widthNat n) + + if w > toInteger (maxBound :: Int) then + panic "expByNatOp" ["Exponent too large", show n] + else + loop one [ testBit n (fromInteger i) | i <- reverse [ 0 .. w-1 ]] + + v -> panic "expByNatOp" [ "Expected Nat value", show v ] + + + +------------------------------------------------------------ +-- Shifts and Rotates + +-- | Barrel-shifter algorithm. Takes a list of bits in big-endian order. +shifter :: Monad m => (b -> a -> a -> m a) -> (a -> Integer -> m a) -> a -> [b] -> m a +shifter mux op = go + where + go x [] = return x + go x (b : bs) = do + x' <- op x (2 ^ length bs) + y <- mux b x' x + go y bs + +-- shift{L,R} :: (n :: Nat) -> (a :: sort 0) -> a -> Vec n a -> Nat -> Vec n a; +shiftOp :: forall l. + (VMonadLazy l, Show (Extra l)) => + BasePrims l -> + (Thunk l -> Vector (Thunk l) -> Integer -> Vector (Thunk l)) -> + (VBool l -> VWord l -> Integer -> MWord l) -> + (VBool l -> VWord l -> VWord l -> MWord l) -> + Value l +shiftOp bp vecOp wordIntOp wordOp = + natFun $ \n -> return $ + constFun $ + VFun $ \z -> return $ + strictFun $ \xs -> return $ + strictFun $ \y -> + case y of + VNat i -> + case xs of + VVector xv -> return $ VVector (vecOp z xv (toInteger i)) + VWord xw -> do + zb <- toBool <$> force z + VWord <$> wordIntOp zb xw (toInteger (min i n)) + _ -> panic $ "shiftOp: " ++ show xs + VToNat (VVector iv) -> do + bs <- V.toList <$> traverse (fmap toBool . force) iv + case xs of + VVector xv -> VVector <$> shifter muxVector (\v i -> return (vecOp z v i)) xv bs + VWord xw -> do + zb <- toBool <$> force z + VWord <$> shifter (bpMuxWord bp) (wordIntOp zb) xw bs + _ -> panic $ "shiftOp: " ++ show xs + VToNat (VWord iw) -> + case xs of + VVector xv -> do + bs <- V.toList <$> bpUnpack bp iw + VVector <$> shifter muxVector (\v i -> return (vecOp z v i)) xv bs + VWord xw -> do + zb <- toBool <$> force z + VWord <$> wordOp zb xw iw + _ -> panic $ "shiftOp: " ++ show xs + _ -> panic $ "shiftOp: " ++ show y + where + muxVector :: VBool l -> Vector (Thunk l) -> Vector (Thunk l) -> EvalM l (Vector (Thunk l)) + muxVector b v1 v2 = toVector (bpUnpack bp) =<< muxVal b (VVector v1) (VVector v2) + + muxVal :: VBool l -> Value l -> Value l -> MValue l + muxVal = muxValue bp + +-- rotate{L,R} :: (n :: Nat) -> (a :: sort 0) -> Vec n a -> Nat -> Vec n a; +rotateOp :: forall l. + (VMonadLazy l, Show (Extra l)) => + BasePrims l -> + (Vector (Thunk l) -> Integer -> Vector (Thunk l)) -> + (VWord l -> Integer -> MWord l) -> + (VWord l -> VWord l -> MWord l) -> + Value l +rotateOp bp vecOp wordIntOp wordOp = + constFun $ + constFun $ + strictFun $ \xs -> return $ + strictFun $ \y -> + case y of + VNat i -> + case xs of + VVector xv -> return $ VVector (vecOp xv (toInteger i)) + VWord xw -> VWord <$> wordIntOp xw (toInteger i) + _ -> panic $ "rotateOp: " ++ show xs + VToNat (VVector iv) -> do + bs <- V.toList <$> traverse (fmap toBool . force) iv + case xs of + VVector xv -> VVector <$> shifter muxVector (\v i -> return (vecOp v i)) xv bs + VWord xw -> VWord <$> shifter (bpMuxWord bp) wordIntOp xw bs + _ -> panic $ "rotateOp: " ++ show xs + VToNat (VWord iw) -> + case xs of + VVector xv -> do + bs <- V.toList <$> bpUnpack bp iw + VVector <$> shifter muxVector (\v i -> return (vecOp v i)) xv bs + VWord xw -> do + VWord <$> wordOp xw iw + _ -> panic $ "rotateOp: " ++ show xs + _ -> panic $ "rotateOp: " ++ show y + where + muxVector :: VBool l -> Vector (Thunk l) -> Vector (Thunk l) -> EvalM l (Vector (Thunk l)) + muxVector b v1 v2 = toVector (bpUnpack bp) =<< muxVal b (VVector v1) (VVector v2) + + muxVal :: VBool l -> Value l -> Value l -> MValue l + muxVal = muxValue bp + +vRotateL :: Vector a -> Integer -> Vector a +vRotateL xs i + | V.null xs = xs + | otherwise = (V.++) (V.drop j xs) (V.take j xs) + where j = fromInteger (i `mod` toInteger (V.length xs)) + +vRotateR :: Vector a -> Integer -> Vector a +vRotateR xs i = vRotateL xs (- i) + +vShiftL :: a -> Vector a -> Integer -> Vector a +vShiftL x xs i = (V.++) (V.drop j xs) (V.replicate j x) + where j = fromInteger (i `min` toInteger (V.length xs)) + +vShiftR :: a -> Vector a -> Integer -> Vector a +vShiftR x xs i = (V.++) (V.replicate j x) (V.take (V.length xs - j) xs) + where j = fromInteger (i `min` toInteger (V.length xs)) + +rotateLOp :: (VMonadLazy l, Show (Extra l)) => BasePrims l -> Value l +rotateLOp bp = rotateOp bp vRotateL (bpBvRolInt bp) (bpBvRol bp) + +rotateROp :: (VMonadLazy l, Show (Extra l)) => BasePrims l -> Value l +rotateROp bp = rotateOp bp vRotateR (bpBvRorInt bp) (bpBvRor bp) + +shiftLOp :: (VMonadLazy l, Show (Extra l)) => BasePrims l -> Value l +shiftLOp bp = shiftOp bp vShiftL (bpBvShlInt bp) (bpBvShl bp) + +shiftROp :: (VMonadLazy l, Show (Extra l)) => BasePrims l -> Value l +shiftROp bp = shiftOp bp vShiftR (bpBvShrInt bp) (bpBvShr bp) + +{- +-- rotate{L,R} :: (n :: Nat) -> (a :: sort 0) -> Vec n a -> Nat -> Vec n a; +shiftValue :: forall l. + (VMonadLazy l, Show (Extra l)) => + BasePrims l -> + (Vector (Thunk l) -> Integer -> Vector (Thunk l)) -> + (VWord l -> Integer -> MWord l) -> + (VWord l -> VWord l -> MWord l) -> + Value l -> Value l -> MValue l +shiftValue bp vecOp wordIntOp wordOp xs y = + case y of + VNat i -> + case xs of + VVector xv -> return $ VVector (vecOp xv i) + VWord xw -> VWord <$> wordIntOp xw i + _ -> panic $ "shift/rotate: " ++ show xs + VToNat (VVector iv) -> + do bs <- V.toList <$> traverse (fmap toBool . force) iv + case xs of + VVector xv -> VVector <$> shifter muxVector (\v i -> return (vecOp v i)) xv bs + VWord xw -> VWord <$> shifter (bpMuxWord bp) wordIntOp xw bs + _ -> panic $ "shift/rotate: " ++ show xs + VToNat (VWord iw) -> + case xs of + VVector xv -> + do bs <- V.toList <$> bpUnpack bp iw + VVector <$> shifter muxVector (\v i -> return (vecOp v i)) xv bs + VWord xw -> + do VWord <$> wordOp xw iw + _ -> panic $ "shift/rotate: " ++ show xs + _ -> panic $ "shift/rotate: " ++ show y + where + muxVector :: VBool l -> Vector (Thunk l) -> Vector (Thunk l) -> EvalM l (Vector (Thunk l)) + muxVector b v1 v2 = toVector (bpUnpack bp) =<< muxVal b (VVector v1) (VVector v2) + + muxVal :: VBool l -> Value l -> Value l -> MValue l + muxVal = muxValue bp +-} + +{------------- + +-- Concrete -- + +-- shiftR :: (n :: Nat) -> (a :: sort 0) -> a -> Vec n a -> Nat -> Vec n a; +shiftROp :: CValue +shiftROp = + constFun $ + constFun $ + VFun $ \x -> return $ + pureFun $ \xs -> + Prims.natFun $ \i -> return $ + case xs of + VVector xv -> VVector (vShiftR x xv (fromIntegral i)) + VWord w -> vWord (bvShiftR c w (fromIntegral i)) + where c = toBool (runIdentity (force x)) + _ -> panic $ "Verifier.SAW.Simulator.Concrete.shiftROp: " ++ show xs + + +-- SBV -- + +-- shiftR :: (n :: Nat) -> (a :: sort 0) -> Vec n a -> Nat -> Vec n a; +shiftROp :: SValue +shiftROp = shiftOp vShiftR undefined shr + where shr b x i = svIte b (svNot (svShiftRight (svNot x) i)) (svShiftRight x i) + +-- shift{L,R} :: (n :: Nat) -> (a :: sort 0) -> a -> Vec n a -> Nat -> Vec n a; +shiftOp :: (SThunk -> Vector SThunk -> Integer -> Vector SThunk) + -> (SBool -> SWord -> Integer -> SWord) + -> (SBool -> SWord -> SWord -> SWord) + -> SValue +shiftOp vecOp wordOp svOp = + constFun $ + constFun $ + VFun $ \z -> return $ + strictFun $ \xs -> return $ + strictFun $ \y -> + case y of + VNat i -> + case xs of + VVector xv -> return $ VVector (vecOp z xv i) + VWord xw -> do + zv <- toBool <$> force z + let i' = fromInteger (i `min` toInteger (intSizeOf xw)) + return $ vWord (wordOp zv xw i') + _ -> panic $ "shiftOp: " ++ show xs + VToNat (VVector iv) -> do + bs <- V.toList <$> traverse (fmap toBool . force) iv + case xs of + VVector xv -> VVector <$> shifter muxVector (vecOp z) xv bs + VWord xw -> do + zv <- toBool <$> force z + vWord <$> shifter muxWord (wordOp zv) xw bs + _ -> panic $ "shiftOp: " ++ show xs + VToNat (VWord iw) -> + case xs of + VVector xv -> do + bs <- V.toList <$> svUnpack iw + VVector <$> shifter muxVector (vecOp z) xv bs + VWord xw -> do + zv <- toBool <$> force z + return $ vWord (svOp zv xw iw) + _ -> panic $ "shiftOp: " ++ show xs + _ -> panic $ "shiftOp: " ++ show y + + +-- RME -- + +-- | op :: (n :: Nat) -> (a :: sort 0) -> a -> Vec n a -> Nat -> Vec n a; +shiftOp :: (RValue -> Vector RValue -> Integer -> Vector RValue) -> RValue +shiftOp op = + constFun $ + constFun $ + pureFun $ \z -> + pureFun $ \(toVector -> x) -> + pureFun $ \y -> + case y of + VNat n -> vVector (op z x n) + VToNat v -> vVector (genShift (V.zipWith . muxRValue) (op z) x (toWord v)) + _ -> panic $ unwords ["Verifier.SAW.Simulator.RME.shiftOp", show y] + +-- BitBlast -- + +-- shift{L,R} :: (n :: Nat) -> (a :: sort 0) -> a -> Vec n a -> Nat -> Vec n a; +shiftOp :: AIG.IsAIG l g => g s + -> (BThunk (l s) -> Vector (BThunk (l s)) -> Int -> Vector (BThunk (l s))) + -> (l s -> AIG.BV (l s) -> Int -> LitVector (l s)) + -> BValue (l s) +shiftOp be vecOp wordOp = + constFun $ + constFun $ + VFun $ \x -> return $ + strictFun $ \xs -> return $ + strictFun $ \y -> do + (n, f) <- case xs of + VVector xv -> return (V.length xv, VVector . vecOp x xv) + VWord xlv -> do l <- toBool <$> force x + return (AIG.length xlv, VWord . wordOp l xlv) + _ -> panic $ "Verifier.SAW.Simulator.BitBlast.shiftOp: " ++ show xs + case y of + VNat i -> return (f (fromInteger (i `min` toInteger n))) + VToNat v -> do + ilv <- toWord v + AIG.muxInteger (lazyMux be (muxBVal be)) n ilv (return . f) + _ -> panic $ "Verifier.SAW.Simulator.BitBlast.shiftOp: " ++ show y + +---------------} + +-- foldr :: (a b :: sort 0) -> (n :: Nat) -> (a -> b -> b) -> b -> Vec n a -> b; +foldrOp :: (VMonadLazy l, Show (Extra l)) => Unpack l -> Value l +foldrOp unpack = + constFun $ + constFun $ + constFun $ + strictFun $ \f -> return $ + VFun $ \z -> return $ + strictFun $ \xs -> do + let g x m = do fx <- apply f x + y <- delay m + apply fx y + xv <- toVector unpack xs + V.foldr g (force z) xv + +-- op :: Integer -> Integer; +intUnOp :: VMonad l => String -> (VInt l -> MInt l) -> Value l +intUnOp nm f = + intFun nm $ \x -> + VInt <$> f x + +-- op :: Integer -> Integer -> Integer; +intBinOp :: VMonad l => String -> (VInt l -> VInt l -> MInt l) -> Value l +intBinOp nm f = + intFun (nm++" x") $ \x -> return $ + intFun (nm++" y") $ \y -> + VInt <$> f x y + +-- op :: Integer -> Integer -> Bool; +intBinCmp :: VMonad l => + String -> (VInt l -> VInt l -> MBool l) -> Value l +intBinCmp nm f = + intFun (nm++" x") $ \x -> return $ + intFun (nm++" y") $ \y -> + VBool <$> f x y + +{- +-- primitive intAdd :: Integer -> Integer -> Integer; +intAddOp :: (VMonad l, VInt l ~ Integer) => Value l +intAddOp = intBinOp "intAdd" (+) + +-- primitive intSub :: Integer -> Integer -> Integer; +intSubOp :: (VMonad l, VInt l ~ Integer) => Value l +intSubOp = intBinOp "intSub" (-) + +-- primitive intMul :: Integer -> Integer -> Integer; +intMulOp :: (VMonad l, VInt l ~ Integer) => Value l +intMulOp = intBinOp "intMul" (*) + +-- primitive intDiv :: Integer -> Integer -> Integer; +intDivOp :: (VMonad l, VInt l ~ Integer) => Value l +intDivOp = intBinOp "intDiv" div + +-- primitive intMod :: Integer -> Integer -> Integer; +intModOp :: (VMonad l, VInt l ~ Integer) => Value l +intModOp = intBinOp "intMod" mod + +-- primitive intMin :: Integer -> Integer -> Integer; +intMinOp :: (VMonad l, VInt l ~ Integer) => Value l +intMinOp = intBinOp "intMin" min + +-- primitive intMax :: Integer -> Integer -> Integer; +intMaxOp :: (VMonad l, VInt l ~ Integer) => Value l +intMaxOp = intBinOp "intMax" max + +-- primitive intNeg :: Integer -> Integer; +intNegOp :: (VMonad l, VInt l ~ Integer) => Value l +intNegOp = intUnOp "intNeg x" negate + +-- primitive intEq :: Integer -> Integer -> Bool; +intEqOp :: (VMonad l, VInt l ~ Integer) => (Bool -> VBool l) -> Value l +intEqOp = intBinCmp "intEq" (==) + +-- primitive intLe :: Integer -> Integer -> Bool; +intLeOp :: (VMonad l, VInt l ~ Integer) => (Bool -> VBool l) -> Value l +intLeOp = intBinCmp "intLe" (<=) + +-- primitive intLt :: Integer -> Integer -> Bool; +intLtOp :: (VMonad l, VInt l ~ Integer) => (Bool -> VBool l) -> Value l +intLtOp = intBinCmp "intLt" (<) +-} + +-- primitive intToNat :: Integer -> Nat; +intToNatOp :: (VMonad l, VInt l ~ Integer) => Value l +intToNatOp = + intFun "intToNat" $ \x -> return $! + if x >= 0 then VNat (fromInteger x) else VNat 0 + +-- primitive natToInt :: Nat -> Integer; +natToIntOp :: (VMonad l, VInt l ~ Integer) => Value l +natToIntOp = natFun' "natToInt" $ \x -> return $ VInt (toInteger x) + +-- primitive bvLg2 : (n : Nat) -> Vec n Bool -> Vec n Bool; +bvLg2Op :: VMonad l => (Value l -> MWord l) -> (VWord l -> MWord l) -> Value l +bvLg2Op asWord wordLg2 = + natFun' "bvLg2 1" $ \_n -> return $ + strictFun $ \w -> (return . VWord) =<< (wordLg2 =<< asWord w) + +-- primitive error :: (a :: sort 0) -> String -> a; +errorOp :: VMonad l => Value l +errorOp = + constFun $ + strictFun $ \x -> + case x of + VString s -> Prim.userError (Text.unpack s) + _ -> Prim.userError "unknown error" + +------------------------------------------------------------ +-- Conditionals + +iteOp :: (VMonadLazy l, Show (Extra l)) => BasePrims l -> Value l +iteOp bp = + constFun $ + strictFun $ \b -> return $ + VFun $ \x -> return $ + VFun $ \y -> lazyMuxValue bp (toBool b) (force x) (force y) + +lazyMuxValue :: + (VMonadLazy l, Show (Extra l)) => + BasePrims l -> VBool l -> MValue l -> MValue l -> MValue l +lazyMuxValue bp b x y = + case bpAsBool bp b of + Just True -> x + Just False -> y + Nothing -> + do x' <- x + y' <- y + muxValue bp b x' y' + +muxValue :: forall l. + (VMonadLazy l, Show (Extra l)) => + BasePrims l -> VBool l -> Value l -> Value l -> MValue l +muxValue bp b = value + where + value :: Value l -> Value l -> MValue l + value (VFun f) (VFun g) = return $ VFun $ \a -> do + x <- f a + y <- g a + value x y + value VUnit VUnit = return VUnit + value (VPair x1 x2) (VPair y1 y2) = VPair <$> thunk x1 y1 <*> thunk x2 y2 + value (VRecordValue elems1) (VRecordValue + (alistAllFields (map fst elems1) -> + Just elems2)) = + VRecordValue <$> + zipWithM (\(f,th1) th2 -> (f,) <$> thunk th1 th2) elems1 elems2 + value (VCtorApp i xv) (VCtorApp j yv) | i == j = VCtorApp i <$> thunks xv yv + value (VVector xv) (VVector yv) = VVector <$> thunks xv yv + value (VBool x) (VBool y) = VBool <$> bpMuxBool bp b x y + value (VWord x) (VWord y) = VWord <$> bpMuxWord bp b x y + value (VInt x) (VInt y) = VInt <$> bpMuxInt bp b x y + value (VIntMod n x) (VIntMod _ y) = VIntMod n <$> bpMuxInt bp b x y + value (VNat m) (VNat n) | m == n = return $ VNat m + value (VString x) (VString y) | x == y = return $ VString x + value (VFloat x) (VFloat y) | x == y = return $ VFloat x + value (VDouble x) (VDouble y) | x == y = return $ VDouble y + value (VExtra x) (VExtra y) = VExtra <$> bpMuxExtra bp b x y + value x@(VWord _) y = toVector (bpUnpack bp) x >>= \xv -> value (VVector xv) y + value x y@(VWord _) = toVector (bpUnpack bp) y >>= \yv -> value x (VVector yv) + value x@(VNat _) y = nat x y + value x@(VToNat _) y = nat x y + value (TValue x) (TValue y) = TValue <$> tvalue x y + value x y = + panic $ "Verifier.SAW.Simulator.Prims.iteOp: malformed arguments: " + ++ show x ++ " " ++ show y + + tvalue :: TValue l -> TValue l -> EvalM l (TValue l) + tvalue (VSort x) (VSort y) | x == y = return $ VSort y + tvalue x y = + panic $ "Verifier.SAW.Simulator.Prims.iteOp: malformed arguments: " + ++ show x ++ " " ++ show y + + thunks :: Vector (Thunk l) -> Vector (Thunk l) -> EvalM l (Vector (Thunk l)) + thunks xv yv + | V.length xv == V.length yv = V.zipWithM thunk xv yv + | otherwise = panic "Verifier.SAW.Simulator.Prims.iteOp: malformed arguments" + + thunk :: Thunk l -> Thunk l -> EvalM l (Thunk l) + thunk x y = delay $ do x' <- force x; y' <- force y; value x' y' + + nat :: Value l -> Value l -> MValue l + nat v1 v2 = + do let w = toInteger (max (natSize bp v1) (natSize bp v2)) + unless (w <= toInteger (maxBound :: Int)) + (panic "muxValue" ["width too large", show w]) + x1 <- natToWord bp (fromInteger w) v1 + x2 <- natToWord bp (fromInteger w) v2 + VToNat . VWord <$> bpMuxWord bp b x1 x2 + +-- fix :: (a :: sort 0) -> (a -> a) -> a; +fixOp :: (VMonadLazy l, MonadFix (EvalM l), Show (Extra l)) => Value l +fixOp = + constFun $ + strictFun $ \f -> + force =<< mfix (\x -> delay (apply f x)) + +------------------------------------------------------------ +-- SMT Array + +-- Array :: sort 0 -> sort 0 -> sort 0 +arrayTypeOp :: VMonad l => Value l +arrayTypeOp = pureFun $ \a -> pureFun $ \b -> TValue (VArrayType (toTValue a) (toTValue b)) + +-- arrayConstant :: (a b :: sort 0) -> b -> (Array a b); +arrayConstantOp :: VMonad l => BasePrims l -> Value l +arrayConstantOp bp = + pureFun $ \a -> + constFun $ + strictFun $ \e -> + VArray <$> (bpArrayConstant bp) (toTValue a) e + +-- arrayLookup :: (a b :: sort 0) -> (Array a b) -> a -> b; +arrayLookupOp :: (VMonad l, Show (Extra l)) => BasePrims l -> Value l +arrayLookupOp bp = + constFun $ + constFun $ + pureFun $ \f -> + strictFun $ \i -> do + f' <- toArray f + (bpArrayLookup bp) f' i + +-- arrayUpdate :: (a b :: sort 0) -> (Array a b) -> a -> b -> (Array a b); +arrayUpdateOp :: (VMonad l, Show (Extra l)) => BasePrims l -> Value l +arrayUpdateOp bp = + constFun $ + constFun $ + pureFun $ \f -> + pureFun $ \i -> + strictFun $ \e -> do + f' <- toArray f + VArray <$> (bpArrayUpdate bp) f' i e + +-- arrayEq : (a b : sort 0) -> (Array a b) -> (Array a b) -> Bool; +arrayEqOp :: (VMonad l, Show (Extra l)) => BasePrims l -> Value l +arrayEqOp bp = + constFun $ + constFun $ + pureFun $ \x -> + strictFun $ \y -> do + x' <- toArray x + y' <- toArray y + VBool <$> bpArrayEq bp x' y' diff --git a/saw-core/src/Verifier/SAW/Simulator/RME.hs b/saw-core/src/Verifier/SAW/Simulator/RME.hs new file mode 100644 index 0000000000..6b86e5f6ed --- /dev/null +++ b/saw-core/src/Verifier/SAW/Simulator/RME.hs @@ -0,0 +1,424 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DoAndIfThenElse #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE TypeFamilies #-} + +{- | +Module : Verifier.SAW.Simulator.RME +Copyright : Galois, Inc. 2012-2015 +License : BSD3 +Maintainer : huffman@galois.com +Stability : experimental +Portability : non-portable (language extensions) +-} + +module Verifier.SAW.Simulator.RME + ( evalSharedTerm + , RValue, Value(..) + , RExtra(..) + , toBool + , toWord + , runIdentity + , withBitBlastedSATQuery + ) where + +import Control.Monad.Identity +import Control.Monad.State +import Data.Bits +import Data.IntTrie (IntTrie) +import qualified Data.IntTrie as IntTrie +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Data.Set as Set +import Data.Vector (Vector) +import qualified Data.Vector as V + +import Data.RME (RME) +import qualified Data.RME as RME +import qualified Data.RME.Vector as RMEV + +import qualified Verifier.SAW.Prim as Prim +import qualified Verifier.SAW.Simulator as Sim +import Verifier.SAW.Simulator.Value +import qualified Verifier.SAW.Simulator.Prims as Prims +import Verifier.SAW.FiniteValue (FiniteType(..), FirstOrderType, toFiniteType) +import Verifier.SAW.SharedTerm +import Verifier.SAW.TypedAST (ModuleMap) +import Verifier.SAW.Utils (panic) +import Verifier.SAW.SATQuery + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +import Data.Traversable +#endif + +------------------------------------------------------------ + +-- | Evaluator for shared terms. +evalSharedTerm :: ModuleMap -> Map Ident RValue -> Term -> RValue +evalSharedTerm m addlPrims t = + runIdentity $ do + cfg <- Sim.evalGlobal m (Map.union constMap addlPrims) + extcns (const Nothing) + Sim.evalSharedTerm cfg t + where + extcns ec = return $ Prim.userError $ "Unimplemented: external constant " ++ show (ecName ec) + +------------------------------------------------------------ +-- Values + +data ReedMuller + +type instance EvalM ReedMuller = Identity +type instance VBool ReedMuller = RME +type instance VWord ReedMuller = Vector RME +type instance VInt ReedMuller = Integer +type instance VArray ReedMuller = () +type instance Extra ReedMuller = RExtra + +type RValue = Value ReedMuller +type RThunk = Thunk ReedMuller + +data RExtra = AStream (IntTrie RValue) + +instance Show RExtra where + show (AStream _) = "" + +vBool :: RME -> RValue +vBool b = VBool b + +toBool :: RValue -> RME +toBool (VBool b) = b +toBool x = error $ unwords ["Verifier.SAW.Simulator.RME.toBool", show x] + +vWord :: Vector RME -> RValue +vWord x = VWord x + +toWord :: RValue -> Vector RME +toWord (VWord x) = x +toWord (VVector vv) = fmap (toBool . runIdentity . force) vv +toWord x = error $ unwords ["Verifier.SAW.Simulator.RME.toWord", show x] + +vStream :: IntTrie RValue -> RValue +vStream x = VExtra (AStream x) + +toStream :: RValue -> IntTrie RValue +toStream (VExtra (AStream x)) = x +toStream x = error $ unwords ["Verifier.SAW.Simulator.RME.toStream", show x] + +wordFun :: (Vector RME -> RValue) -> RValue +wordFun f = pureFun (\x -> f (toWord x)) + +genShift :: (a -> b -> b -> b) -> (b -> Integer -> b) -> b -> Vector a -> b +genShift cond f x0 v = go x0 (V.toList v) + where + go x [] = x + go x (y : ys) = go (cond y (f x (2 ^ length ys)) x) ys + +-- | op : (w : Nat) -> Vec w Bool -> Nat -> Vec w Bool; +bvShiftOp :: (Vector RME -> Integer -> Vector RME) -> RValue +bvShiftOp op = + constFun $ + wordFun $ \x -> + pureFun $ \y -> + case y of + VNat n -> vWord (op x (toInteger n)) + VToNat v -> vWord (genShift muxRMEV op x (toWord v)) + _ -> error $ unwords ["Verifier.SAW.Simulator.RME.shiftOp", show y] + +------------------------------------------------------------ + +pure1 :: Applicative f => (a -> b) -> a -> f b +pure1 f x = pure (f x) + +pure2 :: Applicative f => (a -> b -> c) -> a -> b -> f c +pure2 f x y = pure (f x y) + +pure3 :: Applicative f => (a -> b -> c -> d) -> a -> b -> c -> f d +pure3 f x y z = pure (f x y z) + +prims :: Prims.BasePrims ReedMuller +prims = + Prims.BasePrims + { Prims.bpAsBool = RME.isBool + , Prims.bpUnpack = Identity + , Prims.bpPack = Identity + , Prims.bpBvAt = pure2 (V.!) + , Prims.bpBvLit = pure2 RMEV.integer + , Prims.bpBvSize = V.length + , Prims.bpBvJoin = pure2 (V.++) + , Prims.bpBvSlice = pure3 V.slice + -- Conditionals + , Prims.bpMuxBool = pure3 RME.mux + , Prims.bpMuxWord = pure3 muxRMEV + , Prims.bpMuxInt = pure3 muxInt + , Prims.bpMuxExtra = pure3 muxExtra + -- Booleans + , Prims.bpTrue = RME.true + , Prims.bpFalse = RME.false + , Prims.bpNot = pure1 RME.compl + , Prims.bpAnd = pure2 RME.conj + , Prims.bpOr = pure2 RME.disj + , Prims.bpXor = pure2 RME.xor + , Prims.bpBoolEq = pure2 RME.iff + -- Bitvector logical + , Prims.bpBvNot = pure1 (V.map RME.compl) + , Prims.bpBvAnd = pure2 (V.zipWith RME.conj) + , Prims.bpBvOr = pure2 (V.zipWith RME.disj) + , Prims.bpBvXor = pure2 (V.zipWith RME.xor) + -- Bitvector arithmetic + , Prims.bpBvNeg = pure1 RMEV.neg + , Prims.bpBvAdd = pure2 RMEV.add + , Prims.bpBvSub = pure2 RMEV.sub + , Prims.bpBvMul = pure2 RMEV.mul + , Prims.bpBvUDiv = pure2 RMEV.udiv + , Prims.bpBvURem = pure2 RMEV.urem + , Prims.bpBvSDiv = pure2 RMEV.sdiv + , Prims.bpBvSRem = pure2 RMEV.srem + , Prims.bpBvLg2 = unsupportedRMEPrimitive "bpBvLg2" + -- Bitvector comparisons + , Prims.bpBvEq = pure2 RMEV.eq + , Prims.bpBvsle = pure2 RMEV.sle + , Prims.bpBvslt = pure2 RMEV.sle + , Prims.bpBvule = pure2 RMEV.ule + , Prims.bpBvult = pure2 RMEV.ult + , Prims.bpBvsge = pure2 (flip RMEV.sle) + , Prims.bpBvsgt = pure2 (flip RMEV.slt) + , Prims.bpBvuge = pure2 (flip RMEV.ule) + , Prims.bpBvugt = pure2 (flip RMEV.ult) + -- Bitvector shift/rotate + , Prims.bpBvRolInt = pure2 Prims.vRotateL + , Prims.bpBvRorInt = pure2 Prims.vRotateR + , Prims.bpBvShlInt = pure3 Prims.vShiftL + , Prims.bpBvShrInt = pure3 Prims.vShiftR + , Prims.bpBvRol = pure2 (genShift muxRMEV Prims.vRotateL) + , Prims.bpBvRor = pure2 (genShift muxRMEV Prims.vRotateR) + , Prims.bpBvShl = pure3 (genShift muxRMEV . Prims.vShiftL) + , Prims.bpBvShr = pure3 (genShift muxRMEV . Prims.vShiftR) + -- Bitvector misc + , Prims.bpBvPopcount = pure1 RMEV.popcount + , Prims.bpBvCountLeadingZeros = pure1 RMEV.countLeadingZeros + , Prims.bpBvCountTrailingZeros = pure1 RMEV.countTrailingZeros + , Prims.bpBvForall = unsupportedRMEPrimitive "bvForall" + -- Integer operations + , Prims.bpIntAdd = pure2 (+) + , Prims.bpIntSub = pure2 (-) + , Prims.bpIntMul = pure2 (*) + , Prims.bpIntDiv = pure2 div + , Prims.bpIntMod = pure2 mod + , Prims.bpIntNeg = pure1 negate + , Prims.bpIntAbs = pure1 abs + , Prims.bpIntEq = pure2 (\x y -> RME.constant (x == y)) + , Prims.bpIntLe = pure2 (\x y -> RME.constant (x <= y)) + , Prims.bpIntLt = pure2 (\x y -> RME.constant (x < y)) + , Prims.bpIntMin = pure2 min + , Prims.bpIntMax = pure2 max + -- Array operations + , Prims.bpArrayConstant = unsupportedRMEPrimitive "bpArrayConstant" + , Prims.bpArrayLookup = unsupportedRMEPrimitive "bpArrayLookup" + , Prims.bpArrayUpdate = unsupportedRMEPrimitive "bpArrayUpdate" + , Prims.bpArrayEq = unsupportedRMEPrimitive "bpArrayEq" + } + +unsupportedRMEPrimitive :: String -> a +unsupportedRMEPrimitive = Prim.unsupportedPrimitive "RME" + +constMap :: Map Ident RValue +constMap = + Map.union (Prims.constMap prims) $ + Map.fromList + [ ("Prelude.bvShl" , bvShiftOp (Prims.vShiftL RME.false)) + , ("Prelude.bvShr" , bvShiftOp (Prims.vShiftR RME.false)) + , ("Prelude.bvSShr", bvShiftOp vSignedShiftR) + -- Integers + , ("Prelude.intToNat", Prims.intToNatOp) + , ("Prelude.natToInt", Prims.natToIntOp) + , ("Prelude.intToBv" , intToBvOp) + , ("Prelude.bvToInt" , bvToIntOp) + , ("Prelude.sbvToInt", sbvToIntOp) + -- Integers mod n + , ("Prelude.toIntMod" , toIntModOp) + , ("Prelude.fromIntMod", fromIntModOp) + , ("Prelude.intModEq" , intModEqOp) + , ("Prelude.intModAdd" , intModBinOp (+)) + , ("Prelude.intModSub" , intModBinOp (-)) + , ("Prelude.intModMul" , intModBinOp (*)) + , ("Prelude.intModNeg" , intModUnOp negate) + -- Streams + , ("Prelude.MkStream", mkStreamOp) + , ("Prelude.streamGet", streamGetOp) + + -- Misc + , ("Prelude.expByNat", Prims.expByNatOp prims) + ] + +-- primitive bvToInt : (n : Nat) -> Vec n Bool -> Integer; +bvToIntOp :: RValue +bvToIntOp = unsupportedRMEPrimitive "bvToIntOp" + +-- primitive sbvToInt : (n : Nat) -> Vec n Bool -> Integer; +sbvToIntOp :: RValue +sbvToIntOp = unsupportedRMEPrimitive "sbvToIntOp" + +-- primitive intToBv : (n : Nat) -> Integer -> Vec n Bool; +intToBvOp :: RValue +intToBvOp = + Prims.natFun' "intToBv n" $ \n -> return $ + Prims.intFun "intToBv x" $ \x -> return $ + VWord (V.reverse (V.generate (fromIntegral n) (RME.constant . testBit x))) + +muxRMEV :: RME -> Vector RME -> Vector RME -> Vector RME +muxRMEV b = V.zipWith (RME.mux b) + +muxInt :: RME -> Integer -> Integer -> Integer +muxInt b x y = + case RME.isBool b of + Just c -> if c then x else y + Nothing -> if x == y then x else error $ "muxRValue: VInt " ++ show (x, y) + +muxExtra :: RME -> RExtra -> RExtra -> RExtra +muxExtra b (AStream xs) (AStream ys) = AStream (muxRValue b <$> xs <*> ys) + +muxRValue :: RME -> RValue -> RValue -> RValue +muxRValue b x y = runIdentity $ Prims.muxValue prims b x y + +-- | Signed shift right simply copies the high order bit +-- into the shifted places. We special case the zero +-- length vector to avoid a possible out-of-bounds error. +vSignedShiftR :: V.Vector a -> Integer -> V.Vector a +vSignedShiftR xs i + | V.length xs > 0 = Prims.vShiftR x xs i + | otherwise = xs + where x = xs V.! 0 + +------------------------------------------------------------ + +toIntModOp :: RValue +toIntModOp = + Prims.natFun $ \n -> return $ + Prims.intFun "toIntModOp" $ \x -> return $ + VIntMod n (x `mod` toInteger n) + +fromIntModOp :: RValue +fromIntModOp = + constFun $ + Prims.intModFun "fromIntModOp" $ \x -> return $ + VInt x + +intModEqOp :: RValue +intModEqOp = + constFun $ + Prims.intModFun "intModEqOp" $ \x -> return $ + Prims.intModFun "intModEqOp" $ \y -> return $ + VBool (RME.constant (x == y)) + +intModBinOp :: (Integer -> Integer -> Integer) -> RValue +intModBinOp f = + Prims.natFun $ \n -> return $ + Prims.intModFun "intModBinOp x" $ \x -> return $ + Prims.intModFun "intModBinOp y" $ \y -> return $ + VIntMod n (f x y `mod` toInteger n) + +intModUnOp :: (Integer -> Integer) -> RValue +intModUnOp f = + Prims.natFun $ \n -> return $ + Prims.intModFun "intModUnOp" $ \x -> return $ + VIntMod n (f x `mod` toInteger n) + +---------------------------------------- + +-- MkStream :: (a :: sort 0) -> (Nat -> a) -> Stream a; +mkStreamOp :: RValue +mkStreamOp = + constFun $ + pureFun $ \f -> + vStream (fmap (\n -> runIdentity (apply f (ready (VNat n)))) IntTrie.identity) + +-- streamGet :: (a :: sort 0) -> Stream a -> Nat -> a; +streamGetOp :: RValue +streamGetOp = + constFun $ + pureFun $ \xs -> + strictFun $ \case + VNat n -> pure $ IntTrie.apply (toStream xs) (toInteger n) + VToNat bv -> + do let trie = toStream xs + loop k [] = IntTrie.apply trie k + loop k (b:bs) + | Just True <- RME.isBool b + = loop k1 bs + | Just False <- RME.isBool b + = loop k0 bs + | otherwise + = muxRValue b (loop k1 bs) (loop k0 bs) + where + k0 = k `shiftL` 1 + k1 = k0 + 1 + pure $ loop (0::Integer) (V.toList (toWord bv)) + + v -> panic "Verifer.SAW.Simulator.RME.streamGetOp" + [ "Expected Nat value", show v ] + + +------------------------------------------------------------ +-- Generating variables for arguments + +newVars :: FiniteType -> State Int RValue +newVars FTBit = do + i <- get + put (i + 1) + return (vBool (RME.lit i)) +newVars (FTVec n t) = VVector <$> V.replicateM (fromIntegral n) (newVars' t) +newVars (FTTuple ts) = vTuple <$> traverse newVars' ts +newVars (FTRec tm) = vRecord <$> traverse newVars' tm + +newVars' :: FiniteType -> State Int RThunk +newVars' shape = ready <$> newVars shape + +------------------------------------------------------------ +-- Bit-blasting primitives. + +bitBlastBasic :: ModuleMap + -> Map Ident RValue + -> Map VarIndex RValue + -> Term + -> RValue +bitBlastBasic m addlPrims ecMap t = runIdentity $ do + cfg <- Sim.evalGlobal m (Map.union constMap addlPrims) + (\ec -> case Map.lookup (ecVarIndex ec) ecMap of + Just v -> pure v + Nothing -> error ("RME: unknown ExtCns: " ++ show (ecName ec))) + (const Nothing) + Sim.evalSharedTerm cfg t + + +processVar :: + (ExtCns Term, FirstOrderType) -> + IO (ExtCns Term, FiniteType) +processVar (ec, fot) = + case toFiniteType fot of + Nothing -> fail ("RME solver does not support variables of type " ++ show fot) + Just ft -> pure (ec, ft) + +withBitBlastedSATQuery :: + SharedContext -> + Map Ident RValue -> + SATQuery -> + (RME -> [(ExtCns Term, FiniteType)] -> IO a) -> + IO a +withBitBlastedSATQuery sc addlPrims satq cont = + do unless (Set.null (satUninterp satq)) $ fail + "RME prover does not support uninterpreted symbols" + t <- satQueryAsTerm sc satq + varShapes <- mapM processVar (Map.toList (satVariables satq)) + modmap <- scGetModuleMap sc + let vars = evalState (traverse (traverse newVars) varShapes) 0 + let varMap = Map.fromList [ (ecVarIndex ec, v) | (ec,v) <- vars ] + let bval = bitBlastBasic modmap addlPrims varMap t + case bval of + VBool anf -> cont anf varShapes + _ -> panic "Verifier.SAW.Simulator.RME.bitBlast" ["non-boolean result type."] diff --git a/saw-core/src/Verifier/SAW/Simulator/Value.hs b/saw-core/src/Verifier/SAW/Simulator/Value.hs new file mode 100644 index 0000000000..377d180fa7 --- /dev/null +++ b/saw-core/src/Verifier/SAW/Simulator/Value.hs @@ -0,0 +1,324 @@ +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} -- For `Show` instance, it's OK. +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE TupleSections #-} + +{- | +Module : Verifier.SAW.Simulator.Value +Copyright : Galois, Inc. 2012-2015 +License : BSD3 +Maintainer : jhendrix@galois.com +Stability : experimental +Portability : non-portable (language extensions) +-} + +module Verifier.SAW.Simulator.Value + ( module Verifier.SAW.Simulator.Value + , module Verifier.SAW.Simulator.MonadLazy + ) where + +import Prelude hiding (mapM) + +import Control.Monad (foldM, liftM, mapM) +import Data.Kind (Type) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Vector (Vector) +import qualified Data.Vector as V +import Numeric.Natural +import GHC.Stack + +import Verifier.SAW.FiniteValue (FiniteType(..), FirstOrderType(..)) +import Verifier.SAW.SharedTerm +import Verifier.SAW.TypedAST +import Verifier.SAW.Utils (panic) + +import Verifier.SAW.Simulator.MonadLazy + +------------------------------------------------------------ +-- Values and Thunks + +{- | The type of values. +Values are parameterized by the /name/ of an instantiation. +The concrete parameters to use are computed from the name using +a collection of type families (e.g., 'EvalM', 'VBool', etc.). -} +data Value l + = VFun !(Thunk l -> MValue l) + | VUnit + | VPair (Thunk l) (Thunk l) -- TODO: should second component be strict? + | VCtorApp !Ident !(Vector (Thunk l)) + | VVector !(Vector (Thunk l)) + | VBool (VBool l) + | VWord (VWord l) + | VToNat (Value l) + | VNat !Natural + | VInt (VInt l) + | VIntMod !Natural (VInt l) + | VArray (VArray l) + | VString !Text + | VFloat !Float + | VDouble !Double + | VRecordValue ![(FieldName, Thunk l)] + | VExtra (Extra l) + | TValue (TValue l) + +-- | The subset of values that represent types. +data TValue l + = VVecType !Natural !(TValue l) + | VBoolType + | VIntType + | VIntModType !Natural + | VArrayType !(TValue l) !(TValue l) + | VPiType !(TValue l) !(Thunk l -> EvalM l (TValue l)) + | VUnitType + | VPairType !(TValue l) !(TValue l) + | VDataType !Ident ![Value l] + | VRecordType ![(FieldName, TValue l)] + | VSort !Sort + +type Thunk l = Lazy (EvalM l) (Value l) + +-- | Evaluation monad for value instantiation 'l' +type family EvalM l :: Type -> Type +-- | Booleans for value instantiation 'l' +type family VBool l :: Type +-- | Words for value instantiation 'l' +type family VWord l :: Type +-- | Integers for value instantiation 'l' +type family VInt l :: Type +-- | SMT arrays for value instantiation 'l' +type family VArray l :: Type +-- | Additional constructors for instantiation 'l' +type family Extra l :: Type + +-- | Short-hand for a monadic value. +type MValue l = EvalM l (Value l) + +-- | Short-hand for a monadic boolean. +type MBool l = EvalM l (VBool l) + +-- | Short-hand for a monadic word. +type MWord l = EvalM l (VWord l) + +-- | Short-hand for a monadic integer. +type MInt l = EvalM l (VInt l) + +-- | Short-hand for a monadic array. +type MArray l = EvalM l (VArray l) + +-- | Short hand to specify that the evaluation monad is a monad (very common) +type VMonad l = Monad (EvalM l) + +-- | Short hand to specify that the evaluation monad is a lazy monad. +type VMonadLazy l = MonadLazy (EvalM l) + + + + +-- | Language instantiations with a specific monad. +data WithM (m :: Type -> Type) l +type instance EvalM (WithM m l) = m +type instance VBool (WithM m l) = VBool l +type instance VWord (WithM m l) = VWord l +type instance VInt (WithM m l) = VInt l +type instance VArray (WithM m l) = VArray l +type instance Extra (WithM m l) = Extra l + +-------------------------------------------------------------------------------- + +strictFun :: VMonad l => (Value l -> MValue l) -> Value l +strictFun f = VFun (\x -> force x >>= f) + +pureFun :: VMonad l => (Value l -> Value l) -> Value l +pureFun f = VFun (\x -> liftM f (force x)) + +constFun :: VMonad l => Value l -> Value l +constFun x = VFun (\_ -> return x) + +toTValue :: HasCallStack => Value l -> TValue l +toTValue (TValue x) = x +toTValue _ = panic "Verifier.SAW.Simulator.Value.toTValue" ["Not a type value"] + +instance Show (Extra l) => Show (Value l) where + showsPrec p v = + case v of + VFun {} -> showString "<>" + VUnit -> showString "()" + VPair{} -> showString "<>" + VCtorApp s xv + | V.null xv -> shows s + | otherwise -> shows s . showList (toList xv) + VVector xv -> showList (toList xv) + VBool _ -> showString "<>" + VWord _ -> showString "<>" + VToNat x -> showString "bvToNat " . showParen True (shows x) + VNat n -> shows n + VInt _ -> showString "<>" + VIntMod n _ -> showString ("<>") + VArray{} -> showString "<>" + VFloat float -> shows float + VDouble double -> shows double + VString s -> shows s + VRecordValue [] -> showString "{}" + VRecordValue ((fld,_):_) -> + showString "{" . showString (Text.unpack fld) . showString " = _, ...}" + VExtra x -> showsPrec p x + TValue x -> showsPrec p x + where + toList = map (const Nil) . V.toList + +instance Show (Extra l) => Show (TValue l) where + showsPrec p v = + case v of + VBoolType -> showString "Bool" + VIntType -> showString "Integer" + VIntModType n -> showParen True (showString "IntMod " . shows n) + VArrayType{} -> showString "Array" + VPiType t _ -> showParen True + (shows t . showString " -> ...") + VUnitType -> showString "#()" + VPairType x y -> showParen True (shows x . showString " * " . shows y) + VDataType s vs + | null vs -> shows s + | otherwise -> shows s . showList vs + VRecordType [] -> showString "{}" + VRecordType ((fld,_):_) -> + showString "{" . showString (Text.unpack fld) . showString " :: _, ...}" + VVecType n a -> showString "Vec " . shows n + . showString " " . showParen True (showsPrec p a) + VSort s -> shows s + +data Nil = Nil + +instance Show Nil where + show Nil = "_" + +------------------------------------------------------------ +-- Basic operations on values + +vTuple :: VMonad l => [Thunk l] -> Value l +vTuple [] = VUnit +vTuple [_] = error "vTuple: unsupported 1-tuple" +vTuple [x, y] = VPair x y +vTuple (x : xs) = VPair x (ready (vTuple xs)) + +vTupleType :: VMonad l => [TValue l] -> TValue l +vTupleType [] = VUnitType +vTupleType [t] = t +vTupleType (t : ts) = VPairType t (vTupleType ts) + +valPairLeft :: (HasCallStack, VMonad l, Show (Extra l)) => Value l -> MValue l +valPairLeft (VPair t1 _) = force t1 +valPairLeft v = panic "Verifier.SAW.Simulator.Value.valPairLeft" ["Not a pair value:", show v] + +valPairRight :: (HasCallStack, VMonad l, Show (Extra l)) => Value l -> MValue l +valPairRight (VPair _ t2) = force t2 +valPairRight v = panic "Verifier.SAW.Simulator.Value.valPairRight" ["Not a pair value:", show v] + +vRecord :: Map FieldName (Thunk l) -> Value l +vRecord m = VRecordValue (Map.assocs m) + +valRecordProj :: (HasCallStack, VMonad l, Show (Extra l)) => Value l -> FieldName -> MValue l +valRecordProj (VRecordValue fld_map) fld + | Just t <- lookup fld fld_map = force t +valRecordProj v@(VRecordValue _) fld = + panic "Verifier.SAW.Simulator.Value.valRecordProj" + ["Record field not found:", show fld, "in value:", show v] +valRecordProj v _ = + panic "Verifier.SAW.Simulator.Value.valRecordProj" + ["Not a record value:", show v] + +apply :: (HasCallStack, VMonad l, Show (Extra l)) => Value l -> Thunk l -> MValue l +apply (VFun f) x = f x +apply (TValue (VPiType _ f)) x = TValue <$> f x +apply v _x = panic "Verifier.SAW.Simulator.Value.apply" ["Not a function value:", show v] + +applyAll :: (VMonad l, Show (Extra l)) => Value l -> [Thunk l] -> MValue l +applyAll = foldM apply + +asFiniteTypeValue :: Value l -> Maybe FiniteType +asFiniteTypeValue v = + case v of + TValue tv -> asFiniteTypeTValue tv + _ -> Nothing + +asFiniteTypeTValue :: TValue l -> Maybe FiniteType +asFiniteTypeTValue v = + case v of + VBoolType -> return FTBit + VVecType n v1 -> do + t1 <- asFiniteTypeTValue v1 + return (FTVec n t1) + VUnitType -> return (FTTuple []) + VPairType v1 v2 -> do + t1 <- asFiniteTypeTValue v1 + t2 <- asFiniteTypeTValue v2 + case t2 of + FTTuple ts -> return (FTTuple (t1 : ts)) + _ -> return (FTTuple [t1, t2]) + VRecordType elem_tps -> + FTRec <$> Map.fromList <$> + mapM (\(fld,tp) -> (fld,) <$> asFiniteTypeTValue tp) elem_tps + _ -> Nothing + +asFirstOrderTypeValue :: Value l -> Maybe FirstOrderType +asFirstOrderTypeValue v = + case v of + TValue tv -> asFirstOrderTypeTValue tv + _ -> Nothing + +asFirstOrderTypeTValue :: TValue l -> Maybe FirstOrderType +asFirstOrderTypeTValue v = + case v of + VBoolType -> return FOTBit + VVecType n v1 -> FOTVec n <$> asFirstOrderTypeTValue v1 + VIntType -> return FOTInt + VIntModType m -> return (FOTIntMod m) + VArrayType a b -> + FOTArray <$> asFirstOrderTypeTValue a <*> asFirstOrderTypeTValue b + VUnitType -> return (FOTTuple []) + VPairType v1 v2 -> do + t1 <- asFirstOrderTypeTValue v1 + t2 <- asFirstOrderTypeTValue v2 + case t2 of + FOTTuple ts -> return (FOTTuple (t1 : ts)) + _ -> return (FOTTuple [t1, t2]) + VRecordType elem_tps -> + FOTRec . Map.fromList <$> + mapM (traverse asFirstOrderTypeTValue) elem_tps + + VPiType{} -> Nothing + VDataType{} -> Nothing + VSort{} -> Nothing + +-- | A (partial) injective mapping from type values to strings. These +-- are intended to be useful as suffixes for names of type instances +-- of uninterpreted constants. +suffixTValue :: TValue sym -> Maybe String +suffixTValue tv = + case tv of + VVecType n a -> + do a' <- suffixTValue a + Just ("_Vec_" ++ show n ++ a') + VBoolType -> Just "_Bool" + VIntType -> Just "_Int" + VIntModType n -> Just ("_IntMod_" ++ show n) + VArrayType a b -> + do a' <- suffixTValue a + b' <- suffixTValue b + Just ("_Array" ++ a' ++ b') + VPiType _ _ -> Nothing + VUnitType -> Just "_Unit" + VPairType a b -> + do a' <- suffixTValue a + b' <- suffixTValue b + Just ("_Pair" ++ a' ++ b') + VDataType {} -> Nothing + VRecordType {} -> Nothing + VSort {} -> Nothing diff --git a/saw-core/src/Verifier/SAW/Term/CtxTerm.hs b/saw-core/src/Verifier/SAW/Term/CtxTerm.hs new file mode 100644 index 0000000000..52d5c4fdb7 --- /dev/null +++ b/saw-core/src/Verifier/SAW/Term/CtxTerm.hs @@ -0,0 +1,1150 @@ +{- | +Module : Verifier.SAW.Term.CtxTerm +Copyright : Galois, Inc. 2018 +License : BSD3 +Stability : experimental +Portability : non-portable (language extensions) + +The purpose of this module is to define a dependently-typed / GADT approach +to representing SAW core terms, that reflects (to some degree) the typing +and context information in the Haskell type of a term. + +Why are we doing this, when GADT programming can be so gross? The point of all +this is to get all the deBruijn indices right. Doing deBruijn index math when +manipulating open terms can be error prone and hard to read, and those bugs are +really hard to track down. Although GADT programming can be a pain sometimes, +this file is organized so at least you will always get the deBruijn indices +right when you finally get GHC to accept your code. :) +-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Verifier.SAW.Term.CtxTerm + ( + -- * Re-exports from "Data.Parameterized.Context" + -- | We use DataKinds to represent contexts of free variables at the type level. + -- These contexts are "inside-out", meaning that the most recently-bound + -- variable is listed on the outside. We reflect this by having that most + -- recently-bound variable to the right in '::>'. + Ctx(..), EmptyCtx, (::>), type (<+>) + -- * Contexts and Bindings + , Typ + , CtxInvApp, CtxInv + , Bindings(..), bindingsLength, InvBindings(..), InBindings(..) + , invAppendBindings, invertBindings + -- * Terms in Context + , Arrows + , CtxTerm(..), CtxTerms(..), CtxTermsCtx(..) + , mkClosedTerm, mkClosedTyp, elimClosedTerm + , ExistsTp(..), ctxBindingsOfTerms + , ctxTermsForBindings + -- * Operations on Terms-in-Context + , MonadTerm(..) + , ctxLambda, ctxPi, ctxPi1 + -- * Generalized Lifting and Substitution + , CtxLiftSubst(..), ctxLift1, ctxLiftInBindings + , mkLiftedClosedTerm + -- * Constructor Argument Types + , CtorArg(..), CtorArgStruct(..), ctxCtorArgType, ctxCtorType + -- * Computing with Eliminators + , mkPRetTp + , ctxCtorElimType, mkCtorElimTypeFun, ctxReduceRecursor + -- * Parsing and Building Constructor Types + , mkCtorArgStruct + ) where + +import Data.Kind(Type) +import Data.Proxy +import Data.Type.Equality +import Control.Monad + +import Data.Parameterized.Context + +import Verifier.SAW.Term.Functor + + +-- +-- * Contexts and Bindings +-- + +-- | A representation of the type of SAW types as a Haskell type. This is +-- actually a singleton type, meaning that a 'CtxTerm' with type @'Typ' a@ is a +-- SAW type that is represented by Haskell type @a@. Of course, the Haskell type +-- system is not rich enough to capture SAW types in complete detail, but we do +-- our best, and capture at least the types and functions. +data Typ (a :: Type) + +-- | An identifier for a datatype that is statically associated with Haskell +-- type @d@. Again, we cannot capture all of the SAW type system in Haskell, so +-- we simplify datatypes to arbitrary Haskell types. +newtype DataIdent d = DataIdent Ident + +-- | Append a list of types to a context, i.e., "invert" the list of types, +-- putting the last type on the "outside", and append it. The way to think of +-- this operation is that we are already "inside" @ctx@, and we are moving +-- further "inside" of @as@, one type at a time, to yield a combined context +-- where the last type of @as@ is bound last, i.e., most recently. +type family CtxInvApp ctx as where + CtxInvApp ctx '[] = ctx + CtxInvApp ctx (a ': as) = CtxInvApp (ctx ::> a) as + +-- | Invert a type list to make a context +type CtxInv as = CtxInvApp EmptyCtx as + +-- | A sequence of bindings of pairs of a variable name and a type of some form +-- for that variable. These bindings are relative to ambient context @ctx@, use +-- @tp@ for the variable types, and bind variables whose types are listed in +-- @as@. +-- +-- Note that each type in a bindings list has type 'Typ', but is "represented" +-- by a Haskell type @a@ in the 'Bind' constructor. There is no way to actually +-- related the Haskell type @a@ to the type it "represents", so we do not try, +-- and just write "represent" in quotes. +data Bindings (tp :: Ctx Type -> Type -> Type) (ctx :: Ctx Type) (as :: [Type]) where + NoBind :: Bindings tp ctx '[] + Bind :: LocalName -> tp ctx (Typ a) -> Bindings tp (ctx ::> a) as -> + Bindings tp ctx (a ': as) + +-- | Compute the number of bindings in a bindings list +bindingsLength :: Bindings tp ctx as -> Int +bindingsLength NoBind = 0 +bindingsLength (Bind _ _ bs) = 1 + bindingsLength bs + +-- | An inverted list of bindings, seen from the "inside out" +data InvBindings (tp :: Ctx Type -> Type -> Type) (ctx :: Ctx Type) (as :: Ctx Type) where + InvNoBind :: InvBindings tp ctx EmptyCtx + InvBind :: InvBindings tp ctx as -> LocalName -> tp (ctx <+> as) (Typ a) -> + InvBindings tp ctx (as ::> a) + +-- | Compute the number of bindings in an inverted bindings list +invBindingsLength :: InvBindings tp ctx as -> Int +invBindingsLength InvNoBind = 0 +invBindingsLength (InvBind bs _ _) = 1 + invBindingsLength bs + +-- | Map over all types in an inverted bindings list +mapInvBindings :: (forall ctx a. f ctx a -> g ctx a) -> + InvBindings f c1 c2 -> InvBindings g c1 c2 +mapInvBindings _ InvNoBind = InvNoBind +mapInvBindings f (InvBind ctx x tp) = + InvBind (mapInvBindings f ctx) x (f tp) + +-- | Typeclass for things from which we can build proofs that 'EmptyCtx' is the left +-- unit of '(<+>)', i.e., that @'EmptyCtx' '<+>' ctx ~ ctx@ +class CtxAppNilEq f where + ctxAppNilEq :: f ctx -> EmptyCtx <+> ctx :~: ctx + +instance CtxAppNilEq (InvBindings tp ctx') where + ctxAppNilEq InvNoBind = Refl + ctxAppNilEq (InvBind ctx _ _) = + case ctxAppNilEq ctx of + Refl -> Refl + +instance CtxAppNilEq (CtxTermsCtx ctx') where + ctxAppNilEq CtxTermsCtxNil = Refl + ctxAppNilEq (CtxTermsCtxCons ts _) = + case ctxAppNilEq ts of + Refl -> Refl + +-- | Use 'ctxAppNilEq' to lift from @ctx@ to @'EmptyCtx' '<+>' ctx@ +ctxLiftNil :: InvBindings tp EmptyCtx ctx -> f ctx a -> f (EmptyCtx <+> ctx) a +ctxLiftNil ctx f = case ctxAppNilEq ctx of Refl -> f + +-- | Append a 'Bindings' list to an inverted 'InvBindings' list, inverting the +-- former as we go to yield an inverted 'InvBindings' list. Intuitively, this +-- means we are already "inside" the inverted bindings lists, and we are moving +-- further "inside" the regular bindings list; at the end we will be "inside" +-- both, meaning that we will see the combination "from the inside". +invAppendBindings :: InvBindings tp ctx as -> + Bindings tp (ctx <+> as) bs -> + InvBindings tp ctx (CtxInvApp as bs) +invAppendBindings as NoBind = as +invAppendBindings as (Bind y y_tp bs) = + (invAppendBindings (InvBind as y y_tp) bs) + +-- | Invert a 'Bindings' list; i.e., move "inside" those bindings +invertBindings :: Bindings tp ctx as -> InvBindings tp ctx (CtxInv as) +invertBindings = invAppendBindings InvNoBind + +-- | Append two inverted contexts, where the first one is top-level. This +-- restriction allows us to avoid writing a proof of associativity of '(<+>)', +-- and instead just using 'ctxAppNilEq' +appendTopInvBindings :: InvBindings tp EmptyCtx ctx1 -> + InvBindings tp ctx1 ctx2 -> + InvBindings tp EmptyCtx (ctx1 <+> ctx2) +appendTopInvBindings ctx1 InvNoBind = ctx1 +appendTopInvBindings ctx1 (InvBind ctx2 x tp) = + let ret = appendTopInvBindings ctx1 ctx2 in + InvBind ret x (ctxLiftNil ret tp) + +-- | A sequence of bindings bundled with something that is relative to those +-- bindings +data InBindings tp (f :: Ctx Type -> k -> Type) ctx (a::k) where + InBindings :: Bindings tp ctx as -> f (CtxInvApp ctx as) a -> + InBindings tp f ctx a + + +-- +-- * Terms In Context +-- + +-- | Abstract a type list using Haskell arrows. This is done "outside-in", since +-- type-level lists represent bindings from the outside in. +type family Arrows as b where + Arrows '[] b = b + Arrows (a ': as) b = a -> Arrows as b + +-- | A 'Term' with a given "type" relative to a given context. Since we cannot +-- hope to represent dependent type theory in Haskell types anyway, these +-- "types" are usually instantiated with a dummy, such as '()', but the code +-- that consumes them cannot know that and has to be agnostic to what type it +-- is. +newtype CtxTerm (ctx :: Ctx Type) (a :: Type) = CtxTerm Term + +-- | Convert a 'CtxTerm' to an untyped term. This is "unsafe" because it throws +-- away our typing information. +unCtxTermUnsafe :: CtxTerm ctx a -> Term +unCtxTermUnsafe (CtxTerm t) = t + +-- | Because we cannot capture the SAW type system in Haskell, sometimes we have +-- to cast our terms. We try not to use this very often, and we only allow +-- casting the output type, not the context, since the latter could screw up our +-- deBruijn indices. +castCtxTerm :: Proxy a -> Proxy b -> CtxTerm ctx a -> CtxTerm ctx b +castCtxTerm _ _ (CtxTerm t) = CtxTerm t + +-- | Build a term in the empty context +mkClosedTerm :: Term -> CtxTerm EmptyCtx a +mkClosedTerm = CtxTerm + +-- | Build a term to represent a type in the empty context +mkClosedTyp :: Term -> CtxTerm EmptyCtx (Typ a) +mkClosedTyp = mkClosedTerm + +-- | Take a term out of the empty context +elimClosedTerm :: CtxTerm EmptyCtx a -> Term +elimClosedTerm (CtxTerm t) = t + +-- | Existentially quantify over the "type" of an object +data ExistsTp tp ctx = forall a. ExistsTp (tp ctx a) + +-- | Build a 'Bindings' list from a list of variable names and types, assuming +-- that each variable is free in the remaining types and that @ctx@ describes +-- the ambient context of the top-level type in the context. Note that nothing +-- here ensures that the Haskell-level types used to "represent" the bindings +-- created by this function have anything to do with the actual SAW types, but +-- the Haskell type system is not powerful enough to represent all the SAW types +-- anyway, and any code that consumes this 'Bindings' list cannot know that +-- anyway. See also the comments for 'CtxTerm'. +ctxBindingsOfTerms :: [(LocalName, Term)] -> ExistsTp (Bindings CtxTerm) ctx +ctxBindingsOfTerms [] = ExistsTp NoBind +ctxBindingsOfTerms ((x,tp):ctx) = + case ctxBindingsOfTerms ctx of + ExistsTp rest -> ExistsTp (Bind x (CtxTerm tp) rest) + +-- | A dummy unit type that takes in a context +data CtxUnit ctx a = CtxUnit + +-- | An 'Either' type relative to a context and type +newtype CtxEither f g ctx a = CtxEither (Either (f ctx a) (g ctx a)) + +-- | A list of terms in a given context +data CtxTerms ctx as where + CtxTermsNil :: CtxTerms ctx '[] + CtxTermsCons :: CtxTerm ctx a -> CtxTerms ctx as -> CtxTerms ctx (a ': as) + +-- | A list of terms in a given context, stored "inside-out" +data CtxTermsCtx ctx term_ctx where + CtxTermsCtxNil :: CtxTermsCtx ctx EmptyCtx + CtxTermsCtxCons :: CtxTermsCtx ctx as -> CtxTerm ctx a -> + CtxTermsCtx ctx (as ::> a) + +{- +-- | Get the head and tail of a non-empty 'CtxTerms' list +ctxTermsHeadTail :: CtxTerms ctx (a ': as) -> (CtxTerm ctx a, CtxTerms ctx as) +ctxTermsHeadTail (CtxTermsCons a as) = (a, as) +-} + +-- | Get the head and tail of a non-empty 'CtxTermsCtx' list +ctxTermsCtxHeadTail :: CtxTermsCtx ctx (as ::> a) -> + (CtxTermsCtx ctx as, CtxTerm ctx a) +ctxTermsCtxHeadTail (CtxTermsCtxCons as a) = (as, a) + +-- | Convert a typed list of terms to a list of untyped terms; this is "unsafe" +-- because it throws away our typing information +ctxTermsToListUnsafe :: CtxTerms ctx as -> [Term] +ctxTermsToListUnsafe CtxTermsNil = [] +ctxTermsToListUnsafe (CtxTermsCons (CtxTerm t) ts) = + t : ctxTermsToListUnsafe ts + +-- | Convert a typed list of terms to a list of untyped terms; this is "unsafe" +-- because it throws away our typing information +ctxTermsCtxToListUnsafe :: CtxTermsCtx ctx as -> [Term] +ctxTermsCtxToListUnsafe CtxTermsCtxNil = [] +ctxTermsCtxToListUnsafe (CtxTermsCtxCons ts (CtxTerm t)) = + ctxTermsCtxToListUnsafe ts ++ [t] + +-- | Like 'ctxTermsForBindings' but can return a 'CtxTerms' in an arbitrary +-- context. We consider this "unsafe" because it associates an arbitrary context +-- with these terms, and so we do not export this function. +ctxTermsForBindingsOpen :: Bindings tp ctx_in as -> [Term] -> + Maybe (CtxTerms ctx as) +ctxTermsForBindingsOpen NoBind [] = Just CtxTermsNil +ctxTermsForBindingsOpen (Bind _ _ bs) (t : ts) = + CtxTermsCons (CtxTerm t) <$> ctxTermsForBindingsOpen bs ts +ctxTermsForBindingsOpen _ _ = Nothing + +-- | Take a list of terms and match them up with a sequence of bindings, +-- returning a structured 'CtxTerms' list. Note that the bindings themselves can +-- be in an arbitrary context, but the terms passed in are assumed to be closed, +-- i.e., in the empty context. +ctxTermsForBindings :: Bindings tp ctx as -> [Term] -> Maybe (CtxTerms EmptyCtx as) +ctxTermsForBindings NoBind [] = Just CtxTermsNil +ctxTermsForBindings (Bind _ _ bs) (t : ts) = + CtxTermsCons (mkClosedTerm t) <$> ctxTermsForBindings bs ts +ctxTermsForBindings _ _ = Nothing + +-- | Invert a 'CtxTerms' list and append it to an already-inverted 'CtxTermsCtx' +-- list +invertAppendCtxTerms :: CtxTermsCtx ctx as -> CtxTerms ctx bs -> + CtxTermsCtx ctx (CtxInvApp as bs) +invertAppendCtxTerms as CtxTermsNil = as +invertAppendCtxTerms as (CtxTermsCons b bs) = + invertAppendCtxTerms (CtxTermsCtxCons as b) bs + +-- | Invert a 'CtxTerms' list +invertCtxTerms :: CtxTerms ctx as -> CtxTermsCtx ctx (CtxInv as) +invertCtxTerms = invertAppendCtxTerms CtxTermsCtxNil + +splitCtxTermsCtx :: InvBindings tp any_ctx ctx2 -> + CtxTermsCtx ctx (ctx1 <+> ctx2) -> + (CtxTermsCtx ctx ctx1, CtxTermsCtx ctx ctx2) +splitCtxTermsCtx InvNoBind terms = (terms, CtxTermsCtxNil) +splitCtxTermsCtx (InvBind ctx _ _) (CtxTermsCtxCons ts t) = + let (ts1, ts2) = splitCtxTermsCtx ctx ts in + (ts1, CtxTermsCtxCons ts2 t) + + +-- +-- * Operations on Terms-in-Context +-- + +-- | The class of monads that can build terms and substitute into them +class Monad m => MonadTerm m where + mkTermF :: TermF Term -> m Term + liftTerm :: DeBruijnIndex -> DeBruijnIndex -> Term -> m Term + substTerm :: DeBruijnIndex -> [Term] -> Term -> m Term + -- ^ NOTE: the first term in the list is substituted for the most + -- recently-bound variable, i.e., deBruijn index 0 + +-- | Build a 'Term' from a 'FlatTermF' in a 'MonadTerm' +mkFlatTermF :: MonadTerm m => FlatTermF Term -> m Term +mkFlatTermF = mkTermF . FTermF + +-- | Build a free variable as a 'CtxTerm' +ctxVar :: MonadTerm m => Bindings tp (ctx1 ::> a) ctx2 -> + m (CtxTerm (CtxInvApp (ctx1 ::> a) ctx2) a) +ctxVar ctx = CtxTerm <$> mkTermF (LocalVar $ bindingsLength ctx) + +-- | Build a list of all the free variables as 'CtxTerm's +-- +-- FIXME: there should be a nicer way to do this that does not require +-- ctxAppNilEq +ctxVars :: MonadTerm m => InvBindings tp EmptyCtx ctx -> m (CtxTermsCtx ctx ctx) +ctxVars ctx_top = + case ctxAppNilEq ctx_top of + Refl -> helper ctx_top NoBind + where + helper :: MonadTerm m => InvBindings tp EmptyCtx ctx -> + Bindings tp (EmptyCtx <+> ctx) as -> + m (CtxTermsCtx (CtxInvApp (EmptyCtx <+> ctx) as) ctx) + helper InvNoBind _ = return CtxTermsCtxNil + helper (InvBind vars_ctx x tp) ctx = + CtxTermsCtxCons <$> helper vars_ctx (Bind x tp ctx) <*> ctxVar ctx + +-- | Build two lists of the free variables, split at a specific point +-- +-- FIXME: there should be a nicer way to do this that does not require +-- splitCtxTermsCtx and appendTopInvBindings (the latter of which requires +-- ctxAppNilEq) +ctxVars2 :: MonadTerm m => InvBindings tp EmptyCtx ctx1 -> + InvBindings tp ctx1 ctx2 -> + m (CtxTermsCtx (ctx1 <+> ctx2) ctx1, + CtxTermsCtx (ctx1 <+> ctx2) ctx2) +ctxVars2 vars1 vars2 = + splitCtxTermsCtx vars2 <$> ctxVars (appendTopInvBindings vars1 vars2) + +-- | Build a 'CtxTerm' for a 'Sort' +ctxSort :: MonadTerm m => Sort -> m (CtxTerm ctx (Typ a)) +ctxSort s = CtxTerm <$> mkFlatTermF (Sort s) + +-- | Apply two 'CtxTerm's +ctxApply :: MonadTerm m => m (CtxTerm ctx (a -> b)) -> m (CtxTerm ctx a) -> + m (CtxTerm ctx b) +ctxApply fm argm = + do CtxTerm f <- fm + CtxTerm arg <- argm + CtxTerm <$> mkTermF (App f arg) + +-- | Apply two 'CtxTerm's, using a 'Proxy' to tell GHC the types +ctxApplyProxy :: MonadTerm m => Proxy a -> Proxy b -> + m (CtxTerm ctx (a -> b)) -> m (CtxTerm ctx a) -> + m (CtxTerm ctx b) +ctxApplyProxy _ _ = ctxApply + +-- | Apply a 'CtxTerm' to a list of arguments +ctxApplyMulti :: MonadTerm m => + m (CtxTerm ctx (Arrows as b)) -> + m (CtxTerms ctx as) -> + m (CtxTerm ctx b) +ctxApplyMulti fm argsm = + fm >>= \f -> argsm >>= \args -> helper f args + where + helper :: MonadTerm m => CtxTerm ctx (Arrows as b) -> + CtxTerms ctx as -> m (CtxTerm ctx b) + helper f CtxTermsNil = return f + helper f (CtxTermsCons arg args) = + do f' <- ctxApply (return f) (return arg) + helper f' args + +-- | Form a lambda-abstraction as a 'CtxTerm' +ctxLambda1 :: MonadTerm m => LocalName -> CtxTerm ctx (Typ a) -> + (CtxTerm (ctx ::> a) a -> m (CtxTerm (ctx ::> a) b)) -> + m (CtxTerm ctx (a -> b)) +ctxLambda1 x (CtxTerm tp) body_f = + do var <- ctxVar NoBind + CtxTerm body <- body_f var + CtxTerm <$> mkTermF (Lambda x tp body) + +-- | Form a multi-arity lambda-abstraction as a 'CtxTerm' +ctxLambda :: MonadTerm m => Bindings CtxTerm ctx as -> + (CtxTerms (CtxInvApp ctx as) as -> + m (CtxTerm (CtxInvApp ctx as) a)) -> + m (CtxTerm ctx (Arrows as a)) +ctxLambda NoBind body_f = body_f CtxTermsNil +ctxLambda (Bind x tp xs) body_f = + ctxLambda1 x tp $ \_ -> + ctxLambda xs $ \vars -> + do var <- ctxVar xs + body_f (CtxTermsCons var vars) + +-- | Form a pi-abstraction as a 'CtxTerm' +ctxPi1 :: MonadTerm m => LocalName -> CtxTerm ctx (Typ a) -> + (CtxTerm (ctx ::> a) a -> + m (CtxTerm (ctx ::> a) (Typ b))) -> + m (CtxTerm ctx (Typ (a -> b))) +ctxPi1 x (CtxTerm tp) body_f = + do var <- ctxVar NoBind + CtxTerm body <- body_f var + CtxTerm <$> mkTermF (Pi x tp body) + +-- | Form a multi-arity pi-abstraction as a 'CtxTerm' +ctxPi :: MonadTerm m => Bindings CtxTerm ctx as -> + (CtxTerms (CtxInvApp ctx as) as -> + m (CtxTerm (CtxInvApp ctx as) (Typ b))) -> + m (CtxTerm ctx (Typ (Arrows as b))) +ctxPi NoBind body_f = body_f CtxTermsNil +ctxPi (Bind x tp xs) body_f = + ctxPi1 x tp $ \_ -> + ctxPi xs $ \vars -> + do var <- ctxVar xs + body_f (CtxTermsCons var vars) + +-- | Form a multi-arity pi-abstraction as a 'CtxTerm', using a 'Proxy' to tell +-- stupid GHC what the result type should be +ctxPiProxy :: MonadTerm m => Proxy (Typ b) -> Bindings CtxTerm ctx as -> + (CtxTerms (CtxInvApp ctx as) as -> + m (CtxTerm (CtxInvApp ctx as) (Typ b))) -> + m (CtxTerm ctx (Typ (Arrows as b))) +ctxPiProxy _ = ctxPi + +-- | Existential return type of 'ctxAsPi' +data CtxPi ctx = + forall b c. + CtxPi LocalName (CtxTerm ctx (Typ b)) (CtxTerm (ctx ::> b) (Typ c)) + +-- | Test if a 'CtxTerm' is a pi-abstraction, returning its components if so. +-- Note that we are not returning any equality constraints on the input type, +-- @a@; i.e., if a term is a pi-abstraction, one would expect @a@ to have the +-- form @b -> c@, but this would require a /lot/ more work... +ctxAsPi :: CtxTerm ctx (Typ a) -> Maybe (CtxPi ctx) +ctxAsPi (CtxTerm (unwrapTermF -> Pi x tp body)) = + Just (CtxPi x (CtxTerm tp) (CtxTerm body)) +ctxAsPi _ = Nothing + +-- | Existential return type of 'ctxAsPiMulti' +data CtxMultiPi ctx = + forall as b. + CtxMultiPi (Bindings CtxTerm ctx as) (CtxTerm (CtxInvApp ctx as) (Typ b)) + +-- | Repeatedly apply 'ctxAsPi', returning the 'Bindings' list of 0 or more +-- pi-abstraction bindings in the given term +ctxAsPiMulti :: CtxTerm ctx (Typ a) -> CtxMultiPi ctx +ctxAsPiMulti (ctxAsPi -> Just (CtxPi x tp body)) = + case ctxAsPiMulti body of + CtxMultiPi as body' -> CtxMultiPi (Bind x tp as) body' +ctxAsPiMulti t = CtxMultiPi NoBind t + +-- | Build an application of a datatype as a 'CtxTerm' +ctxDataTypeM :: MonadTerm m => DataIdent d -> m (CtxTermsCtx ctx params) -> + m (CtxTermsCtx ctx ixs) -> m (CtxTerm ctx (Typ d)) +ctxDataTypeM (DataIdent d) paramsM ixsM = + CtxTerm <$> + (mkFlatTermF =<< + (DataTypeApp d <$> (ctxTermsCtxToListUnsafe <$> paramsM) <*> + (ctxTermsCtxToListUnsafe <$> ixsM))) + + +-- | Test if a 'CtxTerm' is an application of a specific datatype with the +-- supplied context of parameters and indices +ctxAsDataTypeApp :: DataIdent d -> Bindings tp1 EmptyCtx params -> + Bindings tp2 (CtxInv params) ixs -> + CtxTerm ctx (Typ a) -> + Maybe (CtxTerms ctx params, CtxTerms ctx ixs) +ctxAsDataTypeApp (DataIdent d) params ixs (CtxTerm + (unwrapTermF -> + FTermF (DataTypeApp d' params' ixs'))) + | d == d' + = do params_ret <- ctxTermsForBindingsOpen params params' + ixs_ret <- ctxTermsForBindingsOpen ixs ixs' + return (params_ret, ixs_ret) +ctxAsDataTypeApp _ _ _ _ = Nothing + + +-- | Build an application of a constructor as a 'CtxTerm' +ctxCtorAppM :: MonadTerm m => DataIdent d -> Ident -> + m (CtxTermsCtx ctx params) -> + m (CtxTermsCtx ctx args) -> m (CtxTerm ctx d) +ctxCtorAppM _d c paramsM argsM = + CtxTerm <$> + (mkFlatTermF =<< + (CtorApp c <$> (ctxTermsCtxToListUnsafe <$> paramsM) <*> + (ctxTermsCtxToListUnsafe <$> argsM))) + +-- | Build an application of a recursor as a 'CtxTerm' +ctxRecursorAppM :: MonadTerm m => Ident -> m (CtxTermsCtx ctx params) -> + m (CtxTerm ctx p_ret) -> m [(Ident, CtxTerm ctx elim)] -> + m (CtxTermsCtx ctx ixs) -> m (CtxTerm ctx arg) -> + m (CtxTerm ctx a) +ctxRecursorAppM d paramsM pretM cs_fsM ixsM argM = + CtxTerm <$> + (mkFlatTermF =<< + (RecursorApp d <$> (ctxTermsCtxToListUnsafe <$> paramsM) <*> + (unCtxTermUnsafe <$> pretM) <*> + (map (\(c,f) -> (c, unCtxTermUnsafe f)) <$> cs_fsM) <*> + (ctxTermsCtxToListUnsafe <$> ixsM) <*> + (unCtxTermUnsafe <$> argM))) + + +-- +-- * Generalized Lifting and Substitution +-- + +-- | The class of "in-context" types that support lifting and substitution +class Monad m => CtxLiftSubst f m where + -- | Lift an @f@ into an extended context + ctxLift :: InvBindings tp1 ctx ctx' -> Bindings tp2 ctx as -> + f (ctx <+> ctx') a -> + m (f (CtxInvApp ctx as <+> ctx') a) + -- | Substitute a list of terms into an @f@ + ctxSubst :: CtxTermsCtx ctx1 subst -> + InvBindings tp (ctx1 <+> subst) ctx2 -> + f ((ctx1 <+> subst) <+> ctx2) a -> + m (f (ctx1 <+> ctx2) a) + +-- | Lift an @f@ into a context extended with one type +ctxLift1 :: CtxLiftSubst f m => f ctx b -> m (f (ctx ::> a) b) +ctxLift1 = ctxLift InvNoBind (Bind "_" CtxUnit NoBind) + +-- | Lift an @f@ that is in an extended list of 'Bindings' +ctxLiftInBindings :: CtxLiftSubst f m => InvBindings tp1 ctx ctx1 -> + Bindings tp2 (ctx <+> ctx1) ctx2 -> + Bindings tp3 ctx as -> + f (CtxInvApp (ctx <+> ctx1) ctx2) a -> + m (f (CtxInvApp (CtxInvApp ctx as <+> ctx1) ctx2) a) +ctxLiftInBindings = helper . mapInvBindings (CtxEither . Left) + where + helper :: CtxLiftSubst f m => InvBindings (CtxEither tp1 tp2) ctx ctx1 -> + Bindings tp2 (ctx <+> ctx1) ctx2 -> + Bindings tp3 ctx as -> + f (CtxInvApp (ctx <+> ctx1) ctx2) a -> + m (f (CtxInvApp (CtxInvApp ctx as <+> ctx1) ctx2) a) + helper ctx1 NoBind as = ctxLift ctx1 as + helper ctx1 (Bind str tp ctx2) as = + helper (InvBind ctx1 str (CtxEither $ Right tp)) ctx2 as + +-- | Substitute into an @f@ that is in an extended list of 'Bindings' +ctxSubstInBindings :: CtxLiftSubst f m => CtxTermsCtx ctx1 subst -> + InvBindings tp1 (ctx1 <+> subst) ctx2 -> + Bindings tp2 ((ctx1 <+> subst) <+> ctx2) ctx3 -> + f (CtxInvApp ((ctx1 <+> subst) <+> ctx2) ctx3) a -> + m (f (CtxInvApp (ctx1 <+> ctx2) ctx3) a) +ctxSubstInBindings subst = + helper subst . mapInvBindings (CtxEither . Left) where + helper :: CtxLiftSubst f m => CtxTermsCtx ctx1 s -> + InvBindings (CtxEither tp1 tp2) (ctx1 <+> s) ctx2 -> + Bindings tp2 ((ctx1 <+> s) <+> ctx2) ctx3 -> + f (CtxInvApp ((ctx1 <+> s) <+> ctx2) ctx3) a -> + m (f (CtxInvApp (ctx1 <+> ctx2) ctx3) a) + helper s ctx2 NoBind f = ctxSubst s ctx2 f + helper s ctx2 (Bind x tp ctx3) f = + helper s (InvBind ctx2 x (CtxEither $ Right tp)) ctx3 f + +instance MonadTerm m => CtxLiftSubst CtxTerm m where + ctxLift ctx1 ctx2 (CtxTerm t) = + CtxTerm <$> liftTerm (invBindingsLength ctx1) (bindingsLength ctx2) t + ctxSubst subst ctx (CtxTerm t) = + -- NOTE: our term lists put the least recently-bound variable first, so we + -- have to reverse here to call substTerm, which wants the term for the most + -- recently-bound variable first + CtxTerm <$> + substTerm (invBindingsLength ctx) (reverse (ctxTermsCtxToListUnsafe subst)) t + +instance MonadTerm m => CtxLiftSubst CtxTerms m where + ctxLift _ _ CtxTermsNil = return CtxTermsNil + ctxLift ctx1 ctx2 (CtxTermsCons t ts) = + CtxTermsCons <$> ctxLift ctx1 ctx2 t <*> ctxLift ctx1 ctx2 ts + ctxSubst _ _ CtxTermsNil = return CtxTermsNil + ctxSubst subst ctx (CtxTermsCons t ts) = + CtxTermsCons <$> ctxSubst subst ctx t <*> + ctxSubst subst ctx ts + +instance MonadTerm m => CtxLiftSubst CtxTermsCtx m where + ctxLift _ _ CtxTermsCtxNil = return CtxTermsCtxNil + ctxLift ctx1 ctx2 (CtxTermsCtxCons ts t) = + CtxTermsCtxCons <$> ctxLift ctx1 ctx2 ts <*> ctxLift ctx1 ctx2 t + ctxSubst _ _ CtxTermsCtxNil = return CtxTermsCtxNil + ctxSubst subst ctx (CtxTermsCtxCons ts t) = + CtxTermsCtxCons <$> ctxSubst subst ctx ts <*> + ctxSubst subst ctx t + +instance CtxLiftSubst tp m => CtxLiftSubst (Bindings tp) m where + ctxLift _ _ NoBind = return NoBind + ctxLift ctx1 ctx2 (Bind x x_tp bs) = + Bind x <$> ctxLift ctx1 ctx2 x_tp <*> + ctxLift (InvBind ctx1 x (error "Unused")) ctx2 bs + ctxSubst _ _ NoBind = return NoBind + ctxSubst subst ctx (Bind x x_tp bs) = + Bind x <$> ctxSubst subst ctx x_tp <*> + ctxSubst subst (InvBind ctx x (error "Unused")) bs + +instance MonadTerm m => CtxLiftSubst (CtorArg d ixs) m where + ctxLift ctx1 ctx2 (ConstArg tp) = ConstArg <$> ctxLift ctx1 ctx2 tp + ctxLift ctx1 ctx2 (RecursiveArg zs ixs) = + RecursiveArg <$> ctxLift ctx1 ctx2 zs <*> + ctxLiftInBindings ctx1 zs ctx2 ixs + ctxSubst subst ctx (ConstArg tp) = ConstArg <$> ctxSubst subst ctx tp + ctxSubst subst ctx (RecursiveArg zs ixs) = + RecursiveArg <$> ctxSubst subst ctx zs <*> + ctxSubstInBindings subst ctx zs ixs + +-- | Make a closed term and then lift it into a context +mkLiftedClosedTerm :: MonadTerm m => Bindings tp EmptyCtx as -> Term -> + m (CtxTerm (CtxInv as) a) +mkLiftedClosedTerm inners t = ctxLift InvNoBind inners $ mkClosedTerm t + + +-- +-- * Constructor Argument Types +-- + +-- | A specification of the type of an argument for a constructor of datatype +-- @d@, that has a specified list @ixs@ of indices, inside a context @ctx@ of +-- parameters and earlier arguments +data CtorArg d ixs ctx a where + -- | A fixed, constant type + ConstArg :: CtxTerm ctx (Typ a) -> CtorArg d ixs ctx (Typ a) + -- | The construct @'RecursiveArg [(z1,tp1),..,(zn,tpn)] [e1,..,ek]'@ + -- specifies a recursive argument type of the form + -- + -- > (z1::tp1) -> .. -> (zn::tpn) -> d p1 .. pm e1 .. ek + -- + -- where @d@ is the datatype, the @zi::tpi@ are the elements of the Pi + -- context (the first argument to 'RecursiveArgType'), the @pi@ are the + -- parameters of @d@ (not given here), and the @ei@ are the type indices of + -- @d@. + RecursiveArg :: + Bindings CtxTerm ctx zs -> CtxTerms (CtxInvApp ctx zs) ixs -> + CtorArg d ixs ctx (Typ (Arrows zs d)) + +-- | A structure that defines the parameters, arguments, and return type indices +-- of a constructor, using 'CtxTerm' and friends to get the bindings right +data CtorArgStruct d params ixs = + forall args. + CtorArgStruct + { + ctorParams :: Bindings CtxTerm EmptyCtx params, + ctorArgs :: Bindings (CtorArg d ixs) (CtxInv params) args, + ctorIndices :: CtxTerms (CtxInvApp (CtxInv params) args) ixs, + dataTypeIndices :: Bindings CtxTerm (CtxInv params) ixs + } + +-- | Convert a 'CtorArg' into the type that it represents, given a context of +-- the parameters and of the previous arguments +ctxCtorArgType :: MonadTerm m => DataIdent d -> + InvBindings CtxTerm EmptyCtx params -> + InvBindings CtxTerm params prevs -> + CtorArg d ixs (params <+> prevs) a -> + m (CtxTerm (params <+> prevs) a) +ctxCtorArgType _ _ _ (ConstArg tp) = return tp +ctxCtorArgType d params prevs (RecursiveArg zs_ctx ixs) = + ctxPi zs_ctx $ \_ -> + ctxDataTypeM d ((fst <$> ctxVars2 params prevs) >>= ctxLift InvNoBind zs_ctx) + (return $ invertCtxTerms ixs) + +-- | Convert a bindings list of 'CtorArg's to a binding list of types +ctxCtorArgBindings :: MonadTerm m => DataIdent d -> + InvBindings CtxTerm EmptyCtx params -> + InvBindings CtxTerm params prevs -> + Bindings (CtorArg d ixs) (params <+> prevs) args -> + m (Bindings CtxTerm (params <+> prevs) args) +ctxCtorArgBindings _ _ _ NoBind = return NoBind +ctxCtorArgBindings d params prevs (Bind x arg args) = + do tp <- ctxCtorArgType d params prevs arg + rest <- ctxCtorArgBindings d params (InvBind prevs x tp) args + return (Bind x tp rest) + +-- | Compute the type of a constructor from the name of its datatype and its +-- 'CtorArgStruct' +ctxCtorType :: MonadTerm m => Ident -> CtorArgStruct d params ixs -> m Term +ctxCtorType d (CtorArgStruct{..}) = + elimClosedTerm <$> + (ctxPi ctorParams $ \params -> + do bs <- + ctxCtorArgBindings (DataIdent d) (invertBindings ctorParams) + InvNoBind ctorArgs + ctxPi bs $ \_ -> + ctxDataTypeM (DataIdent d) + (ctxLift InvNoBind bs $ invertCtxTerms params) + (return $ invertCtxTerms ctorIndices)) + + +-- +-- * Computing with Eliminators +-- + +-- | Build the type of the @p_ret@ function, also known as the "motive" +-- function, of a recursor on datatype @d@. This type has the form +-- +-- > (i1::ix1) -> .. -> (im::ixm) -> d p1 .. pn i1 .. im -> s +-- +-- where the @pi@ are free variables for the parameters of @d@, the @ixj@ +-- are the indices of @d@, and @s@ is any sort supplied as an argument. +ctxPRetTp :: MonadTerm m => Proxy (Typ a) -> DataIdent d -> + InvBindings CtxTerm EmptyCtx ps -> + Bindings CtxTerm ps ixs -> Sort -> + m (CtxTerm ps (Typ (Arrows ixs (d -> Typ a)))) +ctxPRetTp (_ :: Proxy (Typ a)) (d :: DataIdent d) params ixs s = + ctxPiProxy (Proxy :: Proxy (Typ (d -> Typ a))) ixs $ \ix_vars -> + do param_vars <- ctxVars params + dt <- ctxDataTypeM d (ctxLift InvNoBind ixs param_vars) + (return $ invertCtxTerms ix_vars) + ctxPi1 "_" dt $ \_ -> ctxSort s + +-- | Like 'ctxPRetTp', but also take in a list of parameters and substitute them +-- for the parameter variables returned by that function +mkPRetTp :: + MonadTerm m => Ident -> [(LocalName, Term)] -> [(LocalName, Term)] -> + [Term] -> Sort -> m Term +mkPRetTp d untyped_p_ctx untyped_ix_ctx untyped_params s = + case ctxBindingsOfTerms untyped_p_ctx of + ExistsTp p_ctx -> + case (ctxBindingsOfTerms untyped_ix_ctx, + ctxTermsForBindings p_ctx untyped_params) of + (ExistsTp ix_ctx, Just params) -> + do p_ret <- (ctxPRetTp Proxy (DataIdent d) + (invertBindings p_ctx) ix_ctx s) + elimClosedTerm <$> + ctxSubst (invertCtxTerms params) InvNoBind + (castPRet (invertBindings p_ctx) p_ret) + (_, Nothing) -> + error "mkPRetTp: incorrect number of parameters" + where + castPRet :: InvBindings tp ctx1 ctx -> CtxTerm ctx a -> + CtxTerm (EmptyCtx <+> ctx) a + castPRet ctx = + case ctxAppNilEq ctx of + Refl -> id + + +-- | Compute the type of an eliminator function for a constructor from the name +-- of its datatype, its name, and its 'CtorArgStruct'. This type has, as free +-- variables, both the parameters of the datatype and a "motive" function from +-- indices of the datatype to a return type. It is of the form +-- +-- > (x1::arg1) -> maybe (rec1::rec_tp1) -> .. -> +-- > (xn::argn) -> maybe (recn::rec_tpn) -> +-- > p_ret ix_1 .. ix_k (ctor params x1 .. xn) +-- +-- where the ixs are the type indices of the return type for the constructor, +-- the (xi::argi) are the arguments of the constructor, and the @maybe@s +-- indicate additional arguments that are present only for arguments of +-- recursive type, that is, where @argi@ has the form +-- +-- > (z1::Z1) -> .. -> (zm::Zm) -> d params t1 .. tk +-- +-- In this case, @rec_tpi@ has the form +-- +-- > (z1::Z1) -> .. -> (zm::Zm) -> p_ret t1 .. tk (f z1 .. zm) +-- +-- Note that the output type cannot be expressed in the type of this function, +-- since it depends on fields of the 'CtorArgStruct', so, instead, the result is +-- just casted to whatever type the caller specifies. +ctxCtorElimType :: MonadTerm m => + Proxy (Typ ret) -> Proxy (Typ a) -> DataIdent d -> Ident -> + CtorArgStruct d params ixs -> + m (CtxTerm (CtxInv params ::> + (Arrows ixs (d -> Typ a))) (Typ ret)) +ctxCtorElimType ret (a_top :: Proxy (Typ a)) (d_top :: DataIdent d) c + (CtorArgStruct{..}) = + (do let params = invertBindings ctorParams + -- NOTE: we use propSort for the type of p_ret just as arbitrary sort, but + -- it doesn't matter because p_ret_tp is only actually used to form + -- contexts, and is never actually used directly in the output + p_ret_tp <- ctxPRetTp a_top d_top params dataTypeIndices propSort + + -- Lift the argument and return indices into the context of p_ret + args <- ctxLift InvNoBind (Bind "_" p_ret_tp NoBind) ctorArgs + ixs <- + ctxLiftInBindings InvNoBind ctorArgs (Bind "_" p_ret_tp NoBind) + ctorIndices + -- Form the context (params ::> p_ret) + let params_pret = InvBind params "_" (ctxLiftNil params p_ret_tp) + -- Call the helper and cast the result to (Typ ret) + castCtxTerm Proxy ret <$> + helper a_top d_top params_pret InvNoBind args ixs + ) where + + -- Iterate through the argument types of the constructor, building up a + -- function from those arguments to the result type of the p_ret function. + -- Note that, technically, this function also takes in recursive calls, so has + -- a slightly richer type, but we are not going to try to compute this richer + -- type in Haskell land. + helper :: MonadTerm m => Proxy (Typ a) -> DataIdent d -> + InvBindings CtxTerm EmptyCtx (ps ::> Arrows ixs (d -> Typ a)) -> + InvBindings CtxTerm (ps ::> Arrows ixs (d -> Typ a)) prevs -> + Bindings (CtorArg d ixs) ((ps ::> + Arrows ixs (d -> Typ a)) <+> prevs) args -> + CtxTerms (CtxInvApp ((ps ::> Arrows ixs (d -> Typ a)) <+> + prevs) args) ixs -> + m (CtxTerm ((ps ::> Arrows ixs (d -> Typ a)) <+> prevs) + (Typ (Arrows args a))) + helper _a d params_pret prevs NoBind ret_ixs = + -- If we are finished with our arguments, construct the final result type + -- (p_ret ret_ixs (c params prevs)) + do (vars, prev_vars) <- ctxVars2 params_pret prevs + let (param_terms, p_ret) = ctxTermsCtxHeadTail vars + ctxApply (ctxApplyMulti (return p_ret) (return ret_ixs)) $ + ctxCtorAppM d c (return param_terms) (return prev_vars) + helper a d params_pret prevs (Bind str (ConstArg tp) args) ixs = + -- For a constant argument type, just abstract it and continue + (ctxPi (Bind str tp NoBind) $ \_ -> + helper a d params_pret (InvBind prevs str tp) args ixs) + helper (a :: Proxy (Typ a)) (d::DataIdent d) params_pret + prevs (Bind str (RecursiveArg zs ts) args) ixs = + -- For a recursive argument type of the form + -- + -- (z1::Z1) -> .. -> (zm::Zm) -> d params t1 .. tk + -- + -- form the type abstraction + -- + -- (arg:: (z1::Z1) -> .. -> (zm::Zm) -> d params t1 .. tk) -> + -- (ih :: (z1::Z1) -> .. -> (zm::Zm) -> p_ret t1 .. tk (arg z1 .. zm)) -> + -- rest + -- + -- where rest is the result of a recursive call + do + -- Build terms for the params and p_ret variables + (param_vars, p_ret) <- + ctxTermsCtxHeadTail <$> fst <$> ctxVars2 params_pret prevs + -- Build the type of the argument arg + arg_tp <- ctxPi zs (\_ -> ctxDataTypeM d + (ctxLift InvNoBind zs param_vars) + (return $ invertCtxTerms ts)) + -- Lift zs and ts into the context of arg + let arg_ctx = Bind "_" arg_tp NoBind + zs' <- ctxLift InvNoBind arg_ctx zs + ts' <- ctxLiftInBindings InvNoBind zs arg_ctx ts + -- Build the pi-abstraction for arg + ctxPi1 str arg_tp $ \arg -> + do rest <- + helper a d params_pret (InvBind prevs str arg_tp) args ixs + -- Build the type of ih, in the context of arg + ih_tp <- ctxPi zs' $ \z_vars -> + ctxApplyProxy (Proxy :: Proxy d) (Proxy :: Proxy (Typ a)) + (ctxApplyMulti + (ctxLift InvNoBind (Bind "_" arg_tp zs') p_ret) (return ts')) + (ctxApplyMulti (ctxLift InvNoBind zs' arg) (return z_vars)) + -- Finally, build the pi-abstraction for ih around the rest + -- + -- NOTE: we cast away the IH argument, because that is a type that is + -- computed from the argument structure, and we cannot (well, we + -- could, but it would be much more work to) express that computation + -- in the Haskell type system + castCtxTerm Proxy Proxy <$> + (ctxPi1 "_" ih_tp $ \_ -> + ctxLift InvNoBind (Bind "_" ih_tp NoBind) rest) + +-- | Build a function that substitutes parameters and a @p_ret@ return type +-- function into the type of an eliminator, as returned by 'ctxCtorElimType', +-- for the given constructor. We return the substitution function in the monad +-- so that we only call 'ctxCtorElimType' once but can call the function many +-- times, in order to amortize the overhead of 'ctxCtorElimType'. +-- +-- NOTE: Because this function is defined *before* the @SharedTerm@ module, it +-- cannot call the normalization function @scWHNF@ defined in that module, and +-- so the terms return by the function it generates are not normalized. +mkCtorElimTypeFun :: MonadTerm m => Ident -> Ident -> + CtorArgStruct d params ixs -> m ([Term] -> Term -> m Term) +mkCtorElimTypeFun d c argStruct@(CtorArgStruct {..}) = + do ctxElimType <- ctxCtorElimType Proxy Proxy (DataIdent d) c argStruct + case ctxAppNilEq (invertBindings ctorParams) of + Refl -> + return $ \params p_ret -> + case ctxTermsForBindings ctorParams params of + Nothing -> error "ctorElimTypeFun: wrong number of parameters!" + Just paramsCtx -> + elimClosedTerm <$> + ctxSubstInBindings + (CtxTermsCtxCons (invertCtxTerms paramsCtx) (mkClosedTerm p_ret)) + InvNoBind NoBind ctxElimType + + +-- | Reduce an application of a recursor. This is known in the Coq literature as +-- an iota reduction. More specifically, the call +-- +-- > ctxReduceRecursor d [p1, .., pn] P [(c1,f1), .., (cm,fm)] ci [x1, .., xk] +-- +-- reduces the term @(RecursorApp d ps P cs_fs ixs (CtorApp ci ps xs))@ to +-- +-- > fi x1 (maybe rec_tm_1) .. xk (maybe rec_tm_k) +-- +-- where @maybe rec_tm_i@ indicates an optional recursive call of the recursor +-- on one of the @xi@. These recursive calls only exist for those arguments @xi@ +-- that are recursive arguments, i.e., that are specified with 'RecursiveArg', +-- and are omitted for non-recursive arguments specified by 'ConstArg'. +-- +-- Specifically, for a @'RecursiveArg' zs ixs@ argument @xi@, which has type +-- @\(z1::Z1) -> .. -> d p1 .. pn ix1 .. ixp@, we build the recursive call +-- +-- > \(z1::[ps/params,xs/args]Z1) -> .. -> +-- > RecursorApp d ps P cs_fs [ps/params,xs/args]ixs (xi z1 ... zn) +-- +-- where @[ps/params,xs/args]@ substitutes the concrete parameters @pi@ for the +-- parameter variables of the inductive type and the earlier constructor +-- arguments @xs@ for the remaining free variables. +ctxReduceRecursor :: MonadTerm m => Ident -> [Term] -> Term -> + [(Ident,Term)] -> Ident -> [Term] -> + CtorArgStruct d params ixs -> m Term +ctxReduceRecursor d params p_ret cs_fs c c_args (CtorArgStruct{..}) = + (case (invertCtxTerms <$> ctxTermsForBindings ctorParams params, + ctxTermsForBindings ctorArgs c_args, + ctxAppNilEq (invertBindings ctorParams)) of + (Just paramsCtx, Just argsCtx, Refl) -> + do let fi = + case lookup c cs_fs of + Just f -> f + Nothing -> + error ("ctxReduceRecursor: eliminator missing for constructor " + ++ show c) + args <- mk_args paramsCtx paramsCtx argsCtx ctorArgs + foldM (\f arg -> mkTermF $ App f arg) fi args + (Nothing, _, _) -> + error "ctxReduceRecursor: wrong number of parameters!" + (_, Nothing, _) -> + error "ctxReduceRecursor: wrong number of constructor arguments!" + ) + where + mk_args :: (MonadTerm m, EmptyCtx <+> ctx ~ ctx) => + CtxTermsCtx EmptyCtx params -> CtxTermsCtx EmptyCtx ctx -> + CtxTerms EmptyCtx args -> Bindings (CtorArg d ixs) ctx args -> + m [Term] + mk_args _ _ _ NoBind = return [] + mk_args ps pre_xs (CtxTermsCons x xs) (Bind _ (ConstArg _) args) = + (elimClosedTerm x :) <$> + mk_args ps (CtxTermsCtxCons pre_xs x) xs args + mk_args ps pre_xs (CtxTermsCons x xs) (Bind _ (RecursiveArg zs ixs) args) = + do zs' <- ctxSubstInBindings pre_xs InvNoBind NoBind zs + ixs' <- ctxSubstInBindings pre_xs InvNoBind zs ixs + (elimClosedTerm x :) <$> + ((:) <$> mk_rec_arg ps zs' ixs' x <*> + mk_args ps (CtxTermsCtxCons pre_xs x) xs args) + + -- Build an individual recursive call, given the parameters, the bindings + -- for the RecursiveArg, and the argument we are going to recurse on + mk_rec_arg :: MonadTerm m => CtxTermsCtx EmptyCtx params -> + Bindings CtxTerm EmptyCtx zs -> CtxTerms (CtxInv zs) ixs -> + CtxTerm EmptyCtx a -> m Term + mk_rec_arg ps zs_ctx ixs x = + elimClosedTerm <$> ctxLambda zs_ctx + (\zs -> + ctxRecursorAppM d (ctxLift InvNoBind zs_ctx ps) + (mkLiftedClosedTerm zs_ctx p_ret) + (forM cs_fs (\(c',f) -> (c',) <$> mkLiftedClosedTerm zs_ctx f)) + (return $ invertCtxTerms ixs) + (ctxApplyMulti + -- FIXME: can we do this without a cast? mk_rec_arg should specify that + -- the input type for x is (Arrows zs a)... + (fmap (castCtxTerm Proxy Proxy) (ctxLift InvNoBind zs_ctx x)) + (return zs))) + + +-- +-- * Parsing and Building Constructor Types +-- + +-- | Generic method for testing whether a datatype occurs in an object +class UsesDataType a where + usesDataType :: DataIdent d -> a -> Bool + +instance UsesDataType (TermF Term) where + usesDataType (DataIdent d) (FTermF (DataTypeApp d' _ _)) | d' == d = True + usesDataType (DataIdent d) (FTermF (RecursorApp d' _ _ _ _ _)) | d' == d = True + usesDataType d tf = any (usesDataType d) tf + +instance UsesDataType Term where + usesDataType d = usesDataType d . unwrapTermF + +instance UsesDataType (CtxTerm ctx a) where + usesDataType d (CtxTerm t) = usesDataType d t + +instance UsesDataType (Bindings CtxTerm ctx as) where + usesDataType _ NoBind = False + usesDataType d (Bind _ tp tps) = usesDataType d tp || usesDataType d tps + + +-- | Check that a type is a valid application of datatype @d@ for use in +-- specific ways in the type of a constructor for @d@. This requires that this +-- application of @d@ be of the form +-- +-- > d p1 .. pn x1 .. xm +-- +-- where the @pi@ are the distinct bound variables bound in the @params@ +-- context, given as argument, and that the @xj@ have no occurrences of @d@. If +-- the given type is of this form, return the @xj@. +asCtorDTApp :: DataIdent d -> Bindings CtxTerm EmptyCtx params -> + Bindings CtxTerm (CtxInv params) ixs -> + InvBindings tp1 (CtxInv params) ctx1 -> + Bindings tp2 (CtxInv params <+> ctx1) ctx2 -> + CtxTerm (CtxInvApp (CtxInv params <+> ctx1) ctx2) (Typ a) -> + Maybe (CtxTerms (CtxInvApp (CtxInv params <+> ctx1) ctx2) ixs) +asCtorDTApp d params dt_ixs ctx1 ctx2 (ctxAsDataTypeApp d params dt_ixs -> + Just (param_vars, ixs)) + | isVarList Proxy params ctx1 ctx2 param_vars && + not (any (usesDataType d) $ ctxTermsToListUnsafe ixs) + = Just ixs + where + -- Check that the given list of terms is a list of bound variables, one for + -- each parameter, in the context extended by the given arguments + isVarList :: Proxy prev_params -> + Bindings tp1 prev_params params -> + InvBindings tp2 (CtxInvApp prev_params params) ctx1 -> + Bindings tp3 (CtxInvApp prev_params params <+> ctx1) ctx2 -> + CtxTerms (CtxInvApp + (CtxInvApp prev_params params <+> ctx1) ctx2) params -> + Bool + isVarList _ _ _ _ CtxTermsNil = True + isVarList _ (Bind _ _ ps) c1 c2 (CtxTermsCons + (CtxTerm (unwrapTermF -> LocalVar i)) ts) = + i == bindingsLength ps + invBindingsLength c1 + bindingsLength c2 && + isVarList Proxy ps c1 c2 ts + isVarList _ _ _ _ _ = False +asCtorDTApp _ _ _ _ _ _ = Nothing + + +-- | Existential return type for 'asCtorArg' +data ExCtorArg d ixs ctx = + forall a. ExCtorArg (CtorArg d ixs ctx (Typ a)) + +-- | Check that an argument for a constructor has one of the allowed forms +asCtorArg :: DataIdent d -> Bindings CtxTerm EmptyCtx params -> + Bindings CtxTerm (CtxInv params) ixs -> + InvBindings tp (CtxInv params) prevs -> + CtxTerm (CtxInv params <+> prevs) (Typ a) -> + Maybe (ExCtorArg d ixs (CtxInv params <+> prevs)) +asCtorArg d params dt_ixs prevs (ctxAsPiMulti -> + CtxMultiPi zs + (asCtorDTApp d params dt_ixs prevs zs -> + Just ixs)) + | not (usesDataType d zs) + = Just (ExCtorArg $ RecursiveArg zs ixs) +asCtorArg d _ _ _ tp + | not (usesDataType d tp) + = Just (ExCtorArg $ ConstArg tp) +asCtorArg _ _ _ _ _ = Nothing + +-- | Existential return type of 'asPiCtorArg' +data CtxPiCtorArg d ixs ctx = + forall a b . + CtxPiCtorArg LocalName (CtorArg d ixs ctx (Typ a)) + (CtxTerm (ctx ::> a) (Typ b)) + +-- | Check that a constructor type is a pi-abstraction that takes as input an +-- argument of one of the allowed forms described by 'CtorArg' +asPiCtorArg :: DataIdent d -> Bindings CtxTerm EmptyCtx params -> + Bindings CtxTerm (CtxInv params) ixs -> + InvBindings tp (CtxInv params) prevs -> + CtxTerm (CtxInv params <+> prevs) (Typ a) -> + Maybe (CtxPiCtorArg d ixs (CtxInv params <+> prevs)) +asPiCtorArg d params dt_ixs prevs (ctxAsPi -> + Just (CtxPi x + (asCtorArg d params dt_ixs prevs -> + Just (ExCtorArg arg)) rest)) = + Just $ CtxPiCtorArg x arg (castTopCtxElem rest) + where + castTopCtxElem :: CtxTerm (ctx ::> a1) b -> CtxTerm (ctx ::> a2) b + castTopCtxElem (CtxTerm t) = CtxTerm t +asPiCtorArg _ _ _ _ _ = Nothing + +-- | Existential return type of 'mkCtorArgsIxs' +data CtorArgsIxs d ixs prevs = + forall args. + CtorArgsIxs (Bindings (CtorArg d ixs) prevs args) + (CtxTerms (CtxInvApp prevs args) ixs) + +-- | Helper function for 'mkCtorArgStruct' +mkCtorArgsIxs :: DataIdent d -> Bindings CtxTerm EmptyCtx params -> + Bindings CtxTerm (CtxInv params) ixs -> + InvBindings (CtorArg d ixs) (CtxInv params) prevs -> + CtxTerm (CtxInv params <+> prevs) (Typ a) -> + Maybe (CtorArgsIxs d ixs (CtxInv params <+> prevs)) +mkCtorArgsIxs d params dt_ixs prevs (asPiCtorArg d params dt_ixs prevs -> + Just (CtxPiCtorArg x arg rest)) = + case mkCtorArgsIxs d params dt_ixs (InvBind prevs x arg) rest of + Just (CtorArgsIxs args ixs) -> Just (CtorArgsIxs (Bind x arg args) ixs) + Nothing -> Nothing +mkCtorArgsIxs d params dt_ixs prevs (asCtorDTApp d params dt_ixs prevs NoBind -> + Just ixs) = + Just (CtorArgsIxs NoBind ixs) +mkCtorArgsIxs _ _ _ _ _ = Nothing + + +-- | Take in a datatype and 'Bindings' lists for its parameters and indices, and +-- also a prospective type of a constructor for that datatype, where the +-- constructor type is allowed to have the parameters but not the indices free. +-- Test that the constructor type is an allowed type for a constructor of this +-- datatype, and, if so, build a 'CtorArgStruct' for it. +mkCtorArgStruct :: Ident -> Bindings CtxTerm EmptyCtx params -> + Bindings CtxTerm (CtxInv params) ixs -> Term -> + Maybe (CtorArgStruct d params ixs) +mkCtorArgStruct d params dt_ixs ctor_tp = + case mkCtorArgsIxs (DataIdent d) params dt_ixs InvNoBind (CtxTerm ctor_tp) of + Just (CtorArgsIxs args ctor_ixs) -> + Just (CtorArgStruct params args ctor_ixs dt_ixs) + Nothing -> Nothing diff --git a/saw-core/src/Verifier/SAW/Term/Functor.hs b/saw-core/src/Verifier/SAW/Term/Functor.hs new file mode 100644 index 0000000000..ec18bac5b2 --- /dev/null +++ b/saw-core/src/Verifier/SAW/Term/Functor.hs @@ -0,0 +1,429 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE BangPatterns #-} + +{- | +Module : Verifier.SAW.Term.Functor +Copyright : Galois, Inc. 2012-2015 +License : BSD3 +Maintainer : huffman@galois.com +Stability : experimental +Portability : non-portable (language extensions) +-} + +module Verifier.SAW.Term.Functor + ( -- * Module Names + ModuleName, mkModuleName + , preludeName + , moduleNameText + , moduleNamePieces + -- * Identifiers + , Ident(identModule, identBaseName), identName, mkIdent + , parseIdent + , isIdent + , identText + , identPieces + -- * Data types and definitions + , DeBruijnIndex + , FieldName + , LocalName + , ExtCns(..) + , VarIndex + , NameInfo(..) + , toShortName + , toAbsoluteName + -- * Terms and associated operations + , TermIndex + , Term(..) + , TermF(..) + , FlatTermF(..) + , zipWithFlatTermF + , freesTermF + , unwrapTermF + , termToPat + , alphaEquiv + , alistAllFields + -- * Sorts + , Sort, mkSort, propSort, sortOf, maxSort + -- * Sets of free variables + , BitSet, emptyBitSet, inBitSet, unionBitSets, intersectBitSets + , decrBitSet, completeBitSet, singletonBitSet + , looseVars, smallestFreeVar + ) where + +import Data.Bits +#if !MIN_VERSION_base(4,8,0) +import Data.Foldable (Foldable) +#endif +import qualified Data.Foldable as Foldable (and, foldl') +import Data.Hashable +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Typeable (Typeable) +import Data.Vector (Vector) +import qualified Data.Vector as V +import Data.Word +import GHC.Generics (Generic) +import Numeric.Natural + +import qualified Language.Haskell.TH.Syntax as TH +import Instances.TH.Lift () -- for instance TH.Lift Text + +import Verifier.SAW.Name +import qualified Verifier.SAW.TermNet as Net + +type DeBruijnIndex = Int +type FieldName = Text +type LocalName = Text + +instance (Hashable k, Hashable a) => Hashable (Map k a) where + hashWithSalt x m = hashWithSalt x (Map.assocs m) + +instance Hashable a => Hashable (Vector a) where + hashWithSalt x v = hashWithSalt x (V.toList v) + + +-- Sorts ----------------------------------------------------------------------- + +-- | The sorts, also known as universes, which can either be a predicative +-- universe with level i or the impredicative universe Prop. +data Sort + = TypeSort Natural + | PropSort + deriving (Eq, Generic, TH.Lift) + +-- Prop is the lowest sort +instance Ord Sort where + PropSort <= _ = True + (TypeSort _) <= PropSort = False + (TypeSort i) <= (TypeSort j) = i <= j + +instance Hashable Sort -- automatically derived + +instance Show Sort where + showsPrec p (TypeSort i) = showParen (p >= 10) (showString "sort " . shows i) + showsPrec _ PropSort = showString "Prop" + +-- | Create sort @Type i@ for the given natural number @i@. +mkSort :: Natural -> Sort +mkSort i = TypeSort i + +-- | Wrapper around 'PropSort', for export +propSort :: Sort +propSort = PropSort + +-- | Returns sort of the given sort. +sortOf :: Sort -> Sort +sortOf (TypeSort i) = TypeSort (i + 1) +sortOf PropSort = TypeSort 0 + +-- | Get the maximum sort in a list, returning Prop for the empty list +maxSort :: [Sort] -> Sort +maxSort [] = propSort +maxSort ss = maximum ss + + +-- Flat Terms ------------------------------------------------------------------ + +-- | The "flat terms", which are the built-in atomic constructs of SAW core. +-- +-- NB: If you add constructors to FlatTermF, make sure you update +-- zipWithFlatTermF! +data FlatTermF e + -- | A primitive or axiom without a definition. + = Primitive !(ExtCns e) + + -- Tuples are represented as nested pairs, grouped to the right, + -- terminated with unit at the end. + | UnitValue + | UnitType + | PairValue e e + | PairType e e + | PairLeft e + | PairRight e + + -- | An inductively-defined type, applied to parameters and type indices + | DataTypeApp !Ident ![e] ![e] + -- | An application of a constructor to its arguments, i.e., an element of + -- an inductively-defined type; the parameters (of the inductive type to + -- which this constructor belongs) and indices are kept separate + | CtorApp !Ident ![e] ![e] + -- | An eliminator / pattern-matching function for an inductively-defined + -- type, given by: + -- * The (identifier of the) inductive type it eliminates; + -- * The parameters of that inductive type; + -- * The return type, also called the "intent", given by a function from + -- type indices of the inductive type to a type; + -- * The elimination function for each constructor of that inductive type; + -- * The indices for that inductive type; AND + -- * The argument that is being eliminated / pattern-matched + | RecursorApp !Ident [e] e [(Ident,e)] [e] e + + -- | Non-dependent record types, i.e., N-ary tuple types with named + -- fields. These are considered equal up to reordering of fields. Actual + -- tuple types are represented with field names @"1"@, @"2"@, etc. + | RecordType ![(FieldName, e)] + -- | Non-dependent records, i.e., N-ary tuples with named fields. These are + -- considered equal up to reordering of fields. Actual tuples are + -- represented with field names @"1"@, @"2"@, etc. + | RecordValue ![(FieldName, e)] + -- | Non-dependent record projection + | RecordProj e !FieldName + + -- | Sorts, aka universes, are the types of types; i.e., an object is a + -- "type" iff it has type @Sort s@ for some s + | Sort !Sort + + -- Primitive builtin values + -- | Natural number with given value. + | NatLit !Natural + -- | Array value includes type of elements followed by elements. + | ArrayValue e (Vector e) + -- | String literal + | StringLit !Text + + -- | An external constant with a name. + | ExtCns !(ExtCns e) + deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Generic) + +instance Hashable e => Hashable (FlatTermF e) -- automatically derived + +-- | Test if the association list used in a 'RecordType' or 'RecordValue' uses +-- precisely the given field names and no more. If so, return the values +-- associated with those field names, in the order given in the input, and +-- otherwise return 'Nothing' +alistAllFields :: Eq k => [k] -> [(k, a)] -> Maybe [a] +alistAllFields [] [] = Just [] +alistAllFields (fld:flds) alist + | Just val <- lookup fld alist = + (val :) <$> alistAllFields flds (deleteField fld alist) + where + deleteField _ [] = error "deleteField" + deleteField f ((f',_):rest) | f == f' = rest + deleteField f (x:rest) = x : deleteField f rest +alistAllFields _ _ = Nothing + +-- | Zip a binary function @f@ over a pair of 'FlatTermF's by applying @f@ +-- pointwise to immediate subterms, if the two 'FlatTermF's are the same +-- constructor; otherwise, return 'Nothing' if they use different constructors +zipWithFlatTermF :: (x -> y -> z) -> FlatTermF x -> FlatTermF y -> + Maybe (FlatTermF z) +zipWithFlatTermF f = go + where + go (Primitive (EC xi xn xt)) (Primitive (EC yi _ yt)) + | xi == yi = Just (Primitive (EC xi xn (f xt yt))) + + go UnitValue UnitValue = Just UnitValue + go UnitType UnitType = Just UnitType + go (PairValue x1 x2) (PairValue y1 y2) = Just (PairValue (f x1 y1) (f x2 y2)) + go (PairType x1 x2) (PairType y1 y2) = Just (PairType (f x1 y1) (f x2 y2)) + go (PairLeft x) (PairLeft y) = Just (PairLeft (f x y)) + go (PairRight x) (PairRight y) = Just (PairLeft (f x y)) + + go (CtorApp cx psx lx) (CtorApp cy psy ly) + | cx == cy = Just $ CtorApp cx (zipWith f psx psy) (zipWith f lx ly) + go (DataTypeApp dx psx lx) (DataTypeApp dy psy ly) + | dx == dy = Just $ DataTypeApp dx (zipWith f psx psy) (zipWith f lx ly) + go (RecursorApp d1 ps1 p1 cs_fs1 ixs1 x1) (RecursorApp d2 ps2 p2 cs_fs2 ixs2 x2) + | d1 == d2 + , Just fs2 <- alistAllFields (map fst cs_fs1) cs_fs2 + = Just $ + RecursorApp d1 (zipWith f ps1 ps2) (f p1 p2) + (zipWith (\(c,f1) f2 -> (c, f f1 f2)) cs_fs1 fs2) + (zipWith f ixs1 ixs2) (f x1 x2) + + go (RecordType elems1) (RecordType elems2) + | Just vals2 <- alistAllFields (map fst elems1) elems2 = + Just $ RecordType $ zipWith (\(fld,x) y -> (fld, f x y)) elems1 vals2 + go (RecordValue elems1) (RecordValue elems2) + | Just vals2 <- alistAllFields (map fst elems1) elems2 = + Just $ RecordValue $ zipWith (\(fld,x) y -> (fld, f x y)) elems1 vals2 + go (RecordProj e1 fld1) (RecordProj e2 fld2) + | fld1 == fld2 = Just $ RecordProj (f e1 e2) fld1 + + go (Sort sx) (Sort sy) | sx == sy = Just (Sort sx) + go (NatLit i) (NatLit j) | i == j = Just (NatLit i) + go (StringLit s) (StringLit t) | s == t = Just (StringLit s) + go (ArrayValue tx vx) (ArrayValue ty vy) + | V.length vx == V.length vy + = Just $ ArrayValue (f tx ty) (V.zipWith f vx vy) + go (ExtCns (EC xi xn xt)) (ExtCns (EC yi _ yt)) + | xi == yi = Just (ExtCns (EC xi xn (f xt yt))) + + go _ _ = Nothing + + +-- Term Functor ---------------------------------------------------------------- + +data TermF e + = FTermF !(FlatTermF e) + -- ^ The atomic, or builtin, term constructs + | App !e !e + -- ^ Applications of functions + | Lambda !LocalName !e !e + -- ^ Function abstractions + | Pi !LocalName !e !e + -- ^ The type of a (possibly) dependent function + | LocalVar !DeBruijnIndex + -- ^ Local variables are referenced by deBruijn index. + | Constant !(ExtCns e) !e + -- ^ An abstract constant packaged with its type and definition. + -- The body and type should be closed terms. + deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Generic) + +instance Hashable e => Hashable (TermF e) -- automatically derived. + + +-- Term Datatype --------------------------------------------------------------- + +type TermIndex = Int -- Word64 + +data Term + = STApp + { stAppIndex :: {-# UNPACK #-} !TermIndex + , stAppFreeVars :: !BitSet -- Free variables + , stAppTermF :: !(TermF Term) + } + | Unshared !(TermF Term) + deriving (Show, Typeable) + +instance Hashable Term where + hashWithSalt salt STApp{ stAppIndex = i } = salt `combine` 0x00000000 `hashWithSalt` hash i + hashWithSalt salt (Unshared t) = salt `combine` 0x55555555 `hashWithSalt` hash t + + +-- | Combine two given hash values. 'combine' has zero as a left +-- identity. (FNV hash, copied from Data.Hashable 1.2.1.0.) +combine :: Int -> Int -> Int +combine h1 h2 = (h1 * 0x01000193) `xor` h2 + +instance Eq Term where + (==) = alphaEquiv + +alphaEquiv :: Term -> Term -> Bool +alphaEquiv = term + where + term :: Term -> Term -> Bool + term (Unshared tf1) (Unshared tf2) = termf tf1 tf2 + term (Unshared tf1) (STApp{stAppTermF = tf2}) = termf tf1 tf2 + term (STApp{stAppTermF = tf1}) (Unshared tf2) = termf tf1 tf2 + term (STApp{stAppIndex = i1, stAppTermF = tf1}) + (STApp{stAppIndex = i2, stAppTermF = tf2}) = i1 == i2 || termf tf1 tf2 + + termf :: TermF Term -> TermF Term -> Bool + termf (FTermF ftf1) (FTermF ftf2) = ftermf ftf1 ftf2 + termf (App t1 u1) (App t2 u2) = term t1 t2 && term u1 u2 + termf (Lambda _ t1 u1) (Lambda _ t2 u2) = term t1 t2 && term u1 u2 + termf (Pi _ t1 u1) (Pi _ t2 u2) = term t1 t2 && term u1 u2 + termf (LocalVar i1) (LocalVar i2) = i1 == i2 + termf (Constant x1 _) (Constant x2 _) = ecVarIndex x1 == ecVarIndex x2 + termf _ _ = False + + ftermf :: FlatTermF Term -> FlatTermF Term -> Bool + ftermf ftf1 ftf2 = case zipWithFlatTermF term ftf1 ftf2 of + Nothing -> False + Just ftf3 -> Foldable.and ftf3 + +instance Ord Term where + compare (STApp{stAppIndex = i}) (STApp{stAppIndex = j}) | i == j = EQ + compare x y = compare (unwrapTermF x) (unwrapTermF y) + +instance Net.Pattern Term where + toPat = termToPat + +termToPat :: Term -> Net.Pat +termToPat t = + case unwrapTermF t of + Constant ec _ -> Net.Atom (toAbsoluteName (ecName ec)) + App t1 t2 -> Net.App (termToPat t1) (termToPat t2) + FTermF (Primitive ec) -> Net.Atom (toAbsoluteName (ecName ec)) + FTermF (Sort s) -> Net.Atom (Text.pack ('*' : show s)) + FTermF (NatLit _) -> Net.Var + FTermF (DataTypeApp c ps ts) -> + foldl Net.App (Net.Atom (identText c)) (map termToPat (ps ++ ts)) + FTermF (CtorApp c ps ts) -> + foldl Net.App (Net.Atom (identText c)) (map termToPat (ps ++ ts)) + _ -> Net.Var + +unwrapTermF :: Term -> TermF Term +unwrapTermF STApp{stAppTermF = tf} = tf +unwrapTermF (Unshared tf) = tf + + +-- Free de Bruijn Variables ---------------------------------------------------- + +-- | A @BitSet@ represents a set of natural numbers. +-- Bit n is a 1 iff n is in the set. +newtype BitSet = BitSet Integer deriving (Eq, Ord, Show) + +-- | The empty 'BitSet' +emptyBitSet :: BitSet +emptyBitSet = BitSet 0 + +-- | The singleton 'BitSet' +singletonBitSet :: Int -> BitSet +singletonBitSet = BitSet . bit + +-- | Test if a number is in a 'BitSet' +inBitSet :: Int -> BitSet -> Bool +inBitSet i (BitSet j) = testBit j i + +-- | Union two 'BitSet's +unionBitSets :: BitSet -> BitSet -> BitSet +unionBitSets (BitSet i1) (BitSet i2) = BitSet (i1 .|. i2) + +-- | Intersect two 'BitSet's +intersectBitSets :: BitSet -> BitSet -> BitSet +intersectBitSets (BitSet i1) (BitSet i2) = BitSet (i1 .&. i2) + +-- | Decrement all elements of a 'BitSet' by 1, removing 0 if it is in the +-- set. This is useful for moving a 'BitSet' out of the scope of a variable. +decrBitSet :: BitSet -> BitSet +decrBitSet (BitSet i) = BitSet (shiftR i 1) + +-- | The 'BitSet' containing all elements less than a given index @i@ +completeBitSet :: Int -> BitSet +completeBitSet i = BitSet (bit i - 1) + +-- | Compute the smallest element of a 'BitSet', if any +smallestBitSetElem :: BitSet -> Maybe Int +smallestBitSetElem (BitSet 0) = Nothing +smallestBitSetElem (BitSet i) | i < 0 = error "smallestBitSetElem" +smallestBitSetElem (BitSet i) = Just $ go 0 i where + go :: Int -> Integer -> Int + go !shft !x + | xw == 0 = go (shft+64) (shiftR x 64) + | otherwise = shft + countTrailingZeros xw + where xw :: Word64 + xw = fromInteger x + +-- | Compute the free variables of a term given free variables for its immediate +-- subterms +freesTermF :: TermF BitSet -> BitSet +freesTermF tf = + case tf of + FTermF ftf -> Foldable.foldl' unionBitSets emptyBitSet ftf + App l r -> unionBitSets l r + Lambda _name tp rhs -> unionBitSets tp (decrBitSet rhs) + Pi _name lhs rhs -> unionBitSets lhs (decrBitSet rhs) + LocalVar i -> singletonBitSet i + Constant {} -> emptyBitSet -- assume rhs is a closed term + +-- | Return a bitset containing indices of all free local variables +looseVars :: Term -> BitSet +looseVars STApp{ stAppFreeVars = x } = x +looseVars (Unshared f) = freesTermF (fmap looseVars f) + +-- | Compute the value of the smallest variable in the term, if any. +smallestFreeVar :: Term -> Maybe Int +smallestFreeVar = smallestBitSetElem . looseVars diff --git a/saw-core/src/Verifier/SAW/Term/Pretty.hs b/saw-core/src/Verifier/SAW/Term/Pretty.hs new file mode 100644 index 0000000000..77b6416ae4 --- /dev/null +++ b/saw-core/src/Verifier/SAW/Term/Pretty.hs @@ -0,0 +1,715 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecordWildCards #-} + +{- | +Module : Verifier.SAW.Term.Pretty +Copyright : Galois, Inc. 2012-2015 +License : BSD3 +Maintainer : huffman@galois.com +Stability : experimental +Portability : non-portable (language extensions) +-} + +module Verifier.SAW.Term.Pretty + ( SawDoc + , SawStyle(..) + , PPOpts(..) + , defaultPPOpts + , depthPPOpts + , ppNat + , ppTerm + , ppTermInCtx + , showTerm + , scPrettyTerm + , scPrettyTermInCtx + , ppTermDepth + , ppTermWithNames + , showTermWithNames + , PPModule(..), PPDecl(..) + , ppPPModule + , scTermCount + , OccurrenceMap + , shouldMemoizeTerm + , ppName + ) where + +import Data.Maybe (isJust) +import Control.Monad.Reader +import Control.Monad.State.Strict as State +#if !MIN_VERSION_base(4,8,0) +import Data.Foldable (Foldable) +#endif +import qualified Data.Foldable as Fold +import qualified Data.Text as Text +import qualified Data.Text.Lazy as Text.Lazy +import qualified Data.Vector as V +import Numeric (showIntAtBase) +import Prettyprinter +import Prettyprinter.Render.Terminal +import Text.URI + +import Data.IntMap.Strict (IntMap) +import qualified Data.IntMap.Strict as IntMap + +import Verifier.SAW.Name +import Verifier.SAW.Term.Functor + +-------------------------------------------------------------------------------- +-- * Doc annotations + +data SawStyle + = PrimitiveStyle + | ConstantStyle + | ExtCnsStyle + | LocalVarStyle + | DataTypeStyle + | CtorAppStyle + | RecursorStyle + | FieldNameStyle + +-- TODO: assign colors for more styles +colorStyle :: SawStyle -> AnsiStyle +colorStyle = + \case + PrimitiveStyle -> mempty + ConstantStyle -> colorDull Blue + ExtCnsStyle -> colorDull Red + LocalVarStyle -> colorDull Green + DataTypeStyle -> mempty + CtorAppStyle -> mempty + RecursorStyle -> mempty + FieldNameStyle -> mempty + +type SawDoc = Doc SawStyle + +-------------------------------------------------------------------------------- +-- * Pretty-Printing Options and Precedences +-------------------------------------------------------------------------------- + +-- | Global options for pretty-printing +data PPOpts = PPOpts { ppBase :: Int + , ppColor :: Bool + , ppShowLocalNames :: Bool + , ppMaxDepth :: Maybe Int } + +-- | Default options for pretty-printing +defaultPPOpts :: PPOpts +defaultPPOpts = PPOpts { ppBase = 10, ppColor = False, + ppShowLocalNames = True, ppMaxDepth = Nothing } + +-- | Options for printing with a maximum depth +depthPPOpts :: Int -> PPOpts +depthPPOpts max_d = defaultPPOpts { ppMaxDepth = Just max_d } + +-- | Test if a depth is "allowed", meaning not greater than the max depth +depthAllowed :: PPOpts -> Int -> Bool +depthAllowed (PPOpts { ppMaxDepth = Just max_d }) d = d < max_d +depthAllowed _ _ = True + +-- | Precedence levels, each of which corresponds to a parsing nonterminal +data Prec + = PrecNone -- ^ Nonterminal 'Term' + | PrecLambda -- ^ Nonterminal 'LTerm' + | PrecProd -- ^ Nonterminal 'ProductTerm' + | PrecApp -- ^ Nonterminal 'AppTerm' + | PrecArg -- ^ Nonterminal 'AtomTerm' + +-- | Test if the first precedence "contains" the second, meaning that terms at +-- the latter precedence level can be printed in the context of the former +-- without parentheses. +-- +-- NOTE: we write this explicitly here, instead of generating it from an 'Ord' +-- instance, so that readers of this code understand it and know what it is. +precContains :: Prec -> Prec -> Bool +precContains _ PrecArg = True +precContains PrecArg _ = False +precContains _ PrecApp = True +precContains PrecApp _ = False +precContains _ PrecProd = True +precContains PrecProd _ = False +precContains _ PrecLambda = True +precContains PrecLambda _ = False +precContains PrecNone PrecNone = True + +-- | Optionally print parentheses around a document, iff the incoming, outer +-- precedence (listed first) contains (as in 'precContains') the required +-- precedence (listed second) for printing the given document. +-- +-- Stated differently: @ppParensPrec p1 p2 d@ means we are pretty-printing in a +-- term context that requires precedence @p1@, but @d@ was pretty-printed at +-- precedence level @p2@. If @p1@ does not contain @p2@ (e.g., if @p1@ is +-- 'PrecArg', meaning we are pretty-printing the argument of an application, and +-- @p2@ is 'PrecLambda', meaning the construct we are pretty-printing is a +-- lambda or pi abstraction) then add parentheses. +ppParensPrec :: Prec -> Prec -> SawDoc -> SawDoc +ppParensPrec p1 p2 d + | precContains p1 p2 = d + | otherwise = parens $ align d + + +---------------------------------------------------------------------- +-- * Local Variable Namings +---------------------------------------------------------------------- + +-- | Local variable namings, which map each deBruijn index in scope to a unique +-- string to be used to print it. This mapping is given by position in a list. +newtype VarNaming = VarNaming [LocalName] + +-- | The empty local variable context +emptyVarNaming :: VarNaming +emptyVarNaming = VarNaming [] + +-- | Look up a string to use for a variable, if the first argument is 'True', or +-- just print the variable number if the first argument is 'False' +lookupVarName :: Bool -> VarNaming -> DeBruijnIndex -> LocalName +lookupVarName True (VarNaming names) i + | i >= length names = Text.pack ('!' : show (i - length names)) +lookupVarName True (VarNaming names) i = names!!i +lookupVarName False _ i = Text.pack ('!' : show i) + +-- | Generate a fresh name from a base name that does not clash with any names +-- already in a given list, unless it is "_", in which case return it as is +freshName :: [LocalName] -> LocalName -> LocalName +freshName used name + | name == "_" = name + | elem name used = freshName used (name <> "'") + | otherwise = name + +-- | Add a new variable with the given base name to the local variable list, +-- returning both the fresh name actually used and the new variable list. As a +-- special case, if the base name is "_", it is not modified. +consVarNaming :: VarNaming -> LocalName -> (LocalName, VarNaming) +consVarNaming (VarNaming names) name = + let nm = freshName names name in (nm, VarNaming (nm : names)) + + +-------------------------------------------------------------------------------- +-- * Pretty-printing monad +-------------------------------------------------------------------------------- + +-- | Memoization variables, which are like deBruijn index variables but for +-- terms that we are memoizing during printing +type MemoVar = Int + +-- | The local state used by pretty-printing computations +data PPState = + PPState + { + -- | The global pretty-printing options + ppOpts :: PPOpts, + -- | The current depth of printing + ppDepth :: Int, + -- | The current naming for the local variables + ppNaming :: VarNaming, + -- | The top-level naming environment + ppNamingEnv :: SAWNamingEnv, + -- | The next "memoization variable" to generate + ppNextMemoVar :: MemoVar, + -- | Memoization table for the global, closed terms, mapping term indices to + -- "memoization variables" that are in scope + ppGlobalMemoTable :: IntMap MemoVar, + -- | Memoization table for terms at the current binding level, mapping term + -- indices to "memoization variables" that are in scope + ppLocalMemoTable :: IntMap MemoVar + } + +emptyPPState :: PPOpts -> SAWNamingEnv -> PPState +emptyPPState opts ne = + PPState { ppOpts = opts, ppDepth = 0, ppNaming = emptyVarNaming, + ppNamingEnv = ne, + ppNextMemoVar = 1, ppGlobalMemoTable = IntMap.empty, + ppLocalMemoTable = IntMap.empty } + +-- | The pretty-printing monad +newtype PPM a = PPM (Reader PPState a) + deriving (Functor, Applicative, Monad) + +-- | Run a pretty-printing computation in a top-level, empty context +runPPM :: PPOpts -> SAWNamingEnv -> PPM a -> a +runPPM opts ne (PPM m) = runReader m $ emptyPPState opts ne + +instance MonadReader PPState PPM where + ask = PPM ask + local f (PPM m) = PPM $ local f m + +-- | Look up the given local variable by deBruijn index to get its name +varLookupM :: DeBruijnIndex -> PPM LocalName +varLookupM idx = + lookupVarName <$> (ppShowLocalNames <$> ppOpts <$> ask) + <*> (ppNaming <$> ask) <*> return idx + +-- | Test if a given term index is memoized, returning its memoization variable +-- if so and otherwise returning 'Nothing' +memoLookupM :: TermIndex -> PPM (Maybe MemoVar) +memoLookupM idx = + do s <- ask + return $ case (IntMap.lookup idx (ppGlobalMemoTable s), + IntMap.lookup idx (ppLocalMemoTable s)) of + (res@(Just _), _) -> res + (_, res@(Just _)) -> res + _ -> Nothing + +-- | Run a pretty-printing computation at the next greater depth, returning the +-- default value if the max depth has been exceeded +atNextDepthM :: a -> PPM a -> PPM a +atNextDepthM dflt m = + do s <- ask + let new_depth = ppDepth s + 1 + if depthAllowed (ppOpts s) new_depth + then local (\_ -> s { ppDepth = new_depth }) m + else return dflt + +-- | Run a pretty-printing computation in the context of a new bound variable, +-- also erasing the local memoization table (which is no longer valid in an +-- extended variable context) during that computation. Return the result of the +-- computation and also the name that was actually used for the bound variable. +withBoundVarM :: LocalName -> PPM a -> PPM (LocalName, a) +withBoundVarM basename m = + do st <- ask + let (var, naming) = consVarNaming (ppNaming st) basename + ret <- local (\_ -> st { ppNaming = naming, + ppLocalMemoTable = IntMap.empty }) m + return (var, ret) + +-- | Run a computation in the context of a fresh "memoization variable" that is +-- bound to the given term index, passing the new memoization variable to the +-- computation. If the flag is true, use the global table, otherwise use the +-- local table. +withMemoVar :: Bool -> TermIndex -> (MemoVar -> PPM a) -> PPM a +withMemoVar global_p idx f = + do memo_var <- ppNextMemoVar <$> ask + local (\s -> add_to_table global_p memo_var s) (f memo_var) + where + add_to_table True v st = + st { ppNextMemoVar = v + 1, + ppGlobalMemoTable = IntMap.insert idx v (ppGlobalMemoTable st) } + add_to_table False v st = + st { ppNextMemoVar = v + 1, + ppLocalMemoTable = IntMap.insert idx v (ppLocalMemoTable st) } + + +-------------------------------------------------------------------------------- +-- * The Pretty-Printing of Specific Constructs +-------------------------------------------------------------------------------- + +-- | Pretty-print an identifier +ppIdent :: Ident -> SawDoc +ppIdent = viaShow + +-- | Pretty-print an integer in the correct base +ppNat :: PPOpts -> Integer -> SawDoc +ppNat (PPOpts{..}) i + | ppBase > 36 = pretty i + | otherwise = prefix <> pretty value + where + prefix = case ppBase of + 2 -> "0b" + 8 -> "0o" + 10 -> mempty + 16 -> "0x" + _ -> "0" <> pretty '<' <> pretty ppBase <> pretty '>' + + value = showIntAtBase (toInteger ppBase) (digits !!) i "" + digits = "0123456789abcdefghijklmnopqrstuvwxyz" + +-- | Pretty-print a memoization variable +ppMemoVar :: MemoVar -> SawDoc +ppMemoVar mv = "x@" <> pretty mv + +-- | Pretty-print a type constraint (also known as an ascription) @x : tp@ +ppTypeConstraint :: SawDoc -> SawDoc -> SawDoc +ppTypeConstraint x tp = + hang 2 $ group $ vsep [annotate LocalVarStyle x, ":" <+> tp] + +-- | Pretty-print an application to 0 or more arguments at the given precedence +ppAppList :: Prec -> SawDoc -> [SawDoc] -> SawDoc +ppAppList _ f [] = f +ppAppList p f args = ppParensPrec p PrecApp $ group $ hang 2 $ vsep (f : args) + +-- | Pretty-print "let x1 = t1 ... xn = tn in body" +ppLetBlock :: [(MemoVar, SawDoc)] -> SawDoc -> SawDoc +ppLetBlock defs body = + vcat + [ "let" <+> lbrace <+> align (vcat (map ppEqn defs)) + , indent 4 rbrace + , " in" <+> body + ] + where + ppEqn (var,d) = ppMemoVar var <+> pretty '=' <+> d + + +-- | Pretty-print pairs as "(x, y)" +ppPair :: Prec -> SawDoc -> SawDoc -> SawDoc +ppPair prec x y = ppParensPrec prec PrecNone (group (vcat [x <> pretty ',', y])) + +-- | Pretty-print pair types as "x * y" +ppPairType :: Prec -> SawDoc -> SawDoc -> SawDoc +ppPairType prec x y = ppParensPrec prec PrecProd (x <+> pretty '*' <+> y) + +-- | Pretty-print records (if the flag is 'False') or record types (if the flag +-- is 'True'), where the latter are preceded by the string @#@, either as: +-- +-- * @(val1, val2, .., valn)@, if the record represents a tuple; OR +-- +-- * @{ fld1 op val1, ..., fldn op valn }@ otherwise, where @op@ is @::@ for +-- types and @=@ for values. +ppRecord :: Bool -> [(FieldName, SawDoc)] -> SawDoc +ppRecord type_p alist = + (if type_p then (pretty '#' <>) else id) $ + encloseSep lbrace rbrace comma $ map ppField alist + where + ppField (fld, rhs) = group (nest 2 (vsep [pretty fld <+> op_str, rhs])) + op_str = if type_p then ":" else "=" + +-- | Pretty-print a projection / selector "x.f" +ppProj :: FieldName -> SawDoc -> SawDoc +ppProj sel doc = doc <> pretty '.' <> pretty sel + +-- | Pretty-print an array value @[v1, ..., vn]@ +ppArrayValue :: [SawDoc] -> SawDoc +ppArrayValue = list + +-- | Pretty-print a lambda abstraction as @\(x :: tp) -> body@, where the +-- variable name to use for @x@ is bundled with @body@ +ppLambda :: SawDoc -> (LocalName, SawDoc) -> SawDoc +ppLambda tp (name, body) = + group $ hang 2 $ + vsep ["\\" <> parens (ppTypeConstraint (pretty name) tp) <+> "->", body] + +-- | Pretty-print a pi abstraction as @(x :: tp) -> body@, or as @tp -> body@ if +-- @x == "_"@ +ppPi :: SawDoc -> (LocalName, SawDoc) -> SawDoc +ppPi tp (name, body) = vsep [lhs, "->" <+> body] + where + lhs = if name == "_" then tp else parens (ppTypeConstraint (pretty name) tp) + +-- | Pretty-print a definition @d :: tp = body@ +ppDef :: SawDoc -> SawDoc -> Maybe SawDoc -> SawDoc +ppDef d tp Nothing = ppTypeConstraint d tp +ppDef d tp (Just body) = ppTypeConstraint d tp <+> equals <+> body + +-- | Pretty-print a datatype declaration of the form +-- > data d (p1:tp1) .. (pN:tpN) : tp where { +-- > c1 (x1_1:tp1_1) .. (x1_N:tp1_N) : tp1 +-- > ... +-- > } +ppDataType :: Ident -> (SawDoc, ((SawDoc, SawDoc), [SawDoc])) -> SawDoc +ppDataType d (params, ((d_ctx,d_tp), ctors)) = + group $ + vcat + [ vsep + [ (group . vsep) + [ "data" <+> ppIdent d <+> params <+> ":" <+> + (d_ctx <+> "->" <+> d_tp) + , "where" <+> lbrace + ] + , vcat (map (<> semi) ctors) + ] + , rbrace + ] + + +-------------------------------------------------------------------------------- +-- * Pretty-Printing Terms +-------------------------------------------------------------------------------- + +-- | Pretty-print a built-in atomic construct +ppFlatTermF :: Prec -> FlatTermF Term -> PPM SawDoc +ppFlatTermF prec tf = + case tf of + Primitive ec -> annotate PrimitiveStyle <$> ppBestName (ecName ec) + UnitValue -> return "(-empty-)" + UnitType -> return "#(-empty-)" + PairValue x y -> ppPair prec <$> ppTerm' PrecLambda x <*> ppTerm' PrecNone y + PairType x y -> ppPairType prec <$> ppTerm' PrecApp x <*> ppTerm' PrecProd y + PairLeft t -> ppProj "1" <$> ppTerm' PrecArg t + PairRight t -> ppProj "2" <$> ppTerm' PrecArg t + + CtorApp c params args -> + ppAppList prec (annotate CtorAppStyle (ppIdent c)) <$> mapM (ppTerm' PrecArg) (params ++ args) + DataTypeApp dt params args -> + ppAppList prec (annotate DataTypeStyle (ppIdent dt)) <$> mapM (ppTerm' PrecArg) (params ++ args) + RecursorApp d params p_ret cs_fs ixs arg -> + do params_pp <- mapM (ppTerm' PrecArg) params + p_ret_pp <- ppTerm' PrecArg p_ret + fs_pp <- mapM (ppTerm' PrecNone . snd) cs_fs + ixs_pp <- mapM (ppTerm' PrecArg) ixs + arg_pp <- ppTerm' PrecArg arg + return $ + ppAppList prec (annotate RecursorStyle (ppIdent d <> "#rec")) + (params_pp ++ [p_ret_pp] ++ + [tupled $ + zipWith (\(c,_) f_pp -> vsep [ppIdent c, "=>", f_pp]) + cs_fs fs_pp] + ++ ixs_pp ++ [arg_pp]) + RecordType alist -> + ppRecord True <$> mapM (\(fld,t) -> (fld,) <$> ppTerm' PrecNone t) alist + RecordValue alist -> + ppRecord False <$> mapM (\(fld,t) -> (fld,) <$> ppTerm' PrecNone t) alist + RecordProj e fld -> ppProj fld <$> ppTerm' PrecArg e + Sort s -> return $ viaShow s + NatLit i -> ppNat <$> (ppOpts <$> ask) <*> return (toInteger i) + ArrayValue _ args -> + ppArrayValue <$> mapM (ppTerm' PrecNone) (V.toList args) + StringLit s -> return $ viaShow s + ExtCns cns -> annotate ExtCnsStyle <$> ppBestName (ecName cns) + +-- | Pretty-print a name, using the best unambiguous alias from the +-- naming environment. +ppBestName :: NameInfo -> PPM SawDoc +ppBestName ni = + do ne <- asks ppNamingEnv + case bestAlias ne ni of + Left _ -> pure $ ppName ni + Right alias -> pure $ pretty alias + +ppName :: NameInfo -> SawDoc +ppName (ModuleIdentifier i) = ppIdent i +ppName (ImportedName absName _) = pretty (render absName) + +-- | Pretty-print a non-shared term +ppTermF :: Prec -> TermF Term -> PPM SawDoc +ppTermF prec (FTermF ftf) = ppFlatTermF prec ftf +ppTermF prec (App e1 e2) = + ppAppList prec <$> ppTerm' PrecApp e1 <*> mapM (ppTerm' PrecArg) [e2] +ppTermF prec (Lambda x tp body) = + ppParensPrec prec PrecLambda <$> + (ppLambda <$> ppTerm' PrecApp tp <*> ppTermInBinder PrecLambda x body) +ppTermF prec (Pi x tp body) = + ppParensPrec prec PrecLambda <$> + (ppPi <$> ppTerm' PrecApp tp <*> + ppTermInBinder PrecLambda x body) +ppTermF _ (LocalVar x) = annotate LocalVarStyle <$> pretty <$> varLookupM x +ppTermF _ (Constant ec _) = annotate ConstantStyle <$> ppBestName (ecName ec) + + +-- | Internal function to recursively pretty-print a term +ppTerm' :: Prec -> Term -> PPM SawDoc +ppTerm' prec = atNextDepthM "..." . ppTerm'' where + ppTerm'' (Unshared tf) = ppTermF prec tf + ppTerm'' (STApp {stAppIndex = idx, stAppTermF = tf}) = + do maybe_memo_var <- memoLookupM idx + case maybe_memo_var of + Just memo_var -> return $ ppMemoVar memo_var + Nothing -> ppTermF prec tf + + +-------------------------------------------------------------------------------- +-- * Memoization Tables and Dealing with Binders in Terms +-------------------------------------------------------------------------------- + +-- | An occurrence map maps each shared term index to its term and how many +-- times that term occurred +type OccurrenceMap = IntMap (Term, Int) + +-- | Returns map that associates each term index appearing in the term to the +-- number of occurrences in the shared term. Subterms that are on the left-hand +-- side of an application are excluded. (FIXME: why?) The boolean flag indicates +-- whether to descend under lambdas and other binders. +scTermCount :: Bool -> Term -> OccurrenceMap +scTermCount doBinders t0 = execState (go [t0]) IntMap.empty + where go :: [Term] -> State OccurrenceMap () + go [] = return () + go (t:r) = + case t of + Unshared _ -> recurse + STApp{ stAppIndex = i } -> do + m <- get + case IntMap.lookup i m of + Just (_, n) -> do + put $ n `seq` IntMap.insert i (t, n+1) m + go r + Nothing -> do + put (IntMap.insert i (t, 1) m) + recurse + where + recurse = go (r ++ argsAndSubterms t) + argsAndSubterms (unwrapTermF -> App f arg) = arg : argsAndSubterms f + argsAndSubterms h = + case unwrapTermF h of + Lambda _ t1 _ | not doBinders -> [t1] + Pi _ t1 _ | not doBinders -> [t1] + Constant{} -> [] + tf -> Fold.toList tf + +-- | Return true if the printing of the given term should be memoized; we do not +-- want to memoize the printing of terms that are "too small" +shouldMemoizeTerm :: Term -> Bool +shouldMemoizeTerm t = + case unwrapTermF t of + FTermF Primitive{} -> False + FTermF UnitValue -> False + FTermF UnitType -> False + FTermF (CtorApp _ [] []) -> False + FTermF (DataTypeApp _ [] []) -> False + FTermF Sort{} -> False + FTermF NatLit{} -> False + FTermF (ArrayValue _ v) | V.length v == 0 -> False + FTermF StringLit{} -> False + FTermF ExtCns{} -> False + LocalVar{} -> False + _ -> True + +-- | Compute a memoization table for a term, and pretty-print the term using the +-- table to memoize the printing. Also print the table itself as a sequence of +-- let-bindings for the entries in the memoization table. If the flag is true, +-- compute a global table, otherwise compute a local table. +ppTermWithMemoTable :: Prec -> Bool -> Term -> PPM SawDoc +ppTermWithMemoTable prec global_p trm = ppLets occ_map_elems [] where + + -- Generate an occurrence map for trm, filtering out terms that only occur + -- once, that are "too small" to memoize, and, for the global table, terms + -- that are not closed + occ_map_elems = + IntMap.assocs $ + IntMap.filter + (\(t,cnt) -> + cnt > 1 && shouldMemoizeTerm t && + (if global_p then looseVars t == emptyBitSet else True)) $ + scTermCount global_p trm + + -- For each (TermIndex, Term) pair in the occurrence map, pretty-print the + -- Term and then add it to the memoization table of subsequent printing. The + -- pretty-printing of these terms is reverse-accumulated in the second + -- list. Finally, print trm with a let-binding for the bound terms. + ppLets :: [(TermIndex, (Term, Int))] -> [(MemoVar, SawDoc)] -> PPM SawDoc + + -- Special case: don't print let-binding if there are no bound vars + ppLets [] [] = ppTerm' prec trm + -- When we have run out of (idx,term) pairs, pretty-print a let binding for + -- all the accumulated bindings around the term + ppLets [] bindings = ppLetBlock (reverse bindings) <$> ppTerm' prec trm + -- To add an (idx,term) pair, first check if idx is already bound, and, if + -- not, add a new MemoVar bind it to idx + ppLets ((idx, (t_rhs,_)):idxs) bindings = + do isBound <- isJust <$> memoLookupM idx + if isBound then ppLets idxs bindings else + do doc_rhs <- ppTerm' prec t_rhs + withMemoVar global_p idx $ \memo_var -> + ppLets idxs ((memo_var, doc_rhs):bindings) + + +-- | Pretty-print a term inside a binder for a variable of the given name, +-- returning both the result of pretty-printing and the fresh name actually used +-- for the newly bound variable. If the variable occurs in the term, then do not +-- use an underscore for it, and use "_x" instead. +-- +-- Also, pretty-print let-bindings around the term for all subterms that occur +-- more than once at the same binding level. +ppTermInBinder :: Prec -> LocalName -> Term -> PPM (LocalName, SawDoc) +ppTermInBinder prec basename trm = + let nm = if basename == "_" && inBitSet 0 (looseVars trm) then "_x" + else basename in + withBoundVarM nm $ ppTermWithMemoTable prec False trm + +-- | Run a pretty-printing computation inside a context that binds zero or more +-- variables, returning the result of the computation and also the +-- pretty-printing of the context. Note: we do not use any local memoization +-- tables for the inner computation; the justification is that this function is +-- only used for printing datatypes, which we assume are not very big. +ppWithBoundCtx :: [(LocalName, Term)] -> PPM a -> PPM (SawDoc, a) +ppWithBoundCtx [] m = (mempty ,) <$> m +ppWithBoundCtx ((x,tp):ctx) m = + (\tp_d (x', (ctx_d, ret)) -> + (parens (ppTypeConstraint (pretty x') tp_d) <+> ctx_d, ret)) + <$> ppTerm' PrecNone tp <*> withBoundVarM x (ppWithBoundCtx ctx m) + +-- | Pretty-print a term, also adding let-bindings for all subterms that occur +-- more than once at the same binding level +ppTerm :: PPOpts -> Term -> SawDoc +ppTerm opts = ppTermWithNames opts emptySAWNamingEnv + +-- | Pretty-print a term, but only to a maximum depth +ppTermDepth :: Int -> Term -> SawDoc +ppTermDepth depth t = ppTerm (depthPPOpts depth) t + +-- | Like 'ppTerm', but also supply a context of bound names, where the most +-- recently-bound variable is listed first in the context +ppTermInCtx :: PPOpts -> [LocalName] -> Term -> SawDoc +ppTermInCtx opts ctx trm = + runPPM opts emptySAWNamingEnv $ + flip (Fold.foldl' (\m x -> snd <$> withBoundVarM x m)) ctx $ + ppTermWithMemoTable PrecNone True trm + +renderSawDoc :: PPOpts -> SawDoc -> String +renderSawDoc ppOpts doc = + Text.Lazy.unpack (renderLazy (style (layoutPretty layoutOpts doc))) + where + layoutOpts = LayoutOptions (AvailablePerLine 80 0.8) + style = if ppColor ppOpts then reAnnotateS colorStyle else unAnnotateS + +-- | Pretty-print a term and render it to a string, using the given options +scPrettyTerm :: PPOpts -> Term -> String +scPrettyTerm opts t = + renderSawDoc opts $ ppTerm opts t + +-- | Like 'scPrettyTerm', but also supply a context of bound names, where the +-- most recently-bound variable is listed first in the context +scPrettyTermInCtx :: PPOpts -> [LocalName] -> Term -> String +scPrettyTermInCtx opts ctx trm = + renderSawDoc opts $ + runPPM opts emptySAWNamingEnv $ + flip (Fold.foldl' (\m x -> snd <$> withBoundVarM x m)) ctx $ + ppTermWithMemoTable PrecNone False trm + + +-- | Pretty-print a term and render it to a string +showTerm :: Term -> String +showTerm t = scPrettyTerm defaultPPOpts t + + +-------------------------------------------------------------------------------- +-- * Pretty-printers with naming environments +-------------------------------------------------------------------------------- + +-- | Pretty-print a term, also adding let-bindings for all subterms that occur +-- more than once at the same binding level +ppTermWithNames :: PPOpts -> SAWNamingEnv -> Term -> SawDoc +ppTermWithNames opts ne trm = + runPPM opts ne $ ppTermWithMemoTable PrecNone True trm + +showTermWithNames :: PPOpts -> SAWNamingEnv -> Term -> String +showTermWithNames opts ne trm = + renderSawDoc opts $ ppTermWithNames opts ne trm + +-------------------------------------------------------------------------------- +-- * Pretty-printers for Modules and Top-level Constructs +-------------------------------------------------------------------------------- + +-- | Datatype for representing modules in pretty-printer land. We do not want to +-- make the pretty-printer dependent on @Verifier.SAW.Module@, so we instead +-- have that module translate to this representation. +data PPModule = PPModule [ModuleName] [PPDecl] + +data PPDecl + = PPTypeDecl Ident [(LocalName, Term)] [(LocalName, Term)] Sort [(Ident, Term)] + | PPDefDecl Ident Term (Maybe Term) + +-- | Pretty-print a 'PPModule' +ppPPModule :: PPOpts -> PPModule -> SawDoc +ppPPModule opts (PPModule importNames decls) = + vcat $ concat $ fmap (map (<> line)) $ + [ map ppImport importNames + , map (runPPM opts emptySAWNamingEnv . ppDecl) decls + ] + where + ppImport nm = pretty $ "import " ++ show nm + ppDecl (PPTypeDecl dtName dtParams dtIndices dtSort dtCtors) = + ppDataType dtName <$> ppWithBoundCtx dtParams + ((,) <$> + ppWithBoundCtx dtIndices (return $ viaShow dtSort) <*> + mapM (\(ctorName,ctorType) -> + ppTypeConstraint (ppIdent ctorName) <$> + ppTerm' PrecNone ctorType) + dtCtors) + ppDecl (PPDefDecl defIdent defType defBody) = + ppDef (ppIdent defIdent) <$> ppTerm' PrecNone defType <*> + case defBody of + Just body -> Just <$> ppTerm' PrecNone body + Nothing -> return Nothing diff --git a/saw-core/src/Verifier/SAW/TermNet.hs b/saw-core/src/Verifier/SAW/TermNet.hs new file mode 100644 index 0000000000..3c7a6dd101 --- /dev/null +++ b/saw-core/src/Verifier/SAW/TermNet.hs @@ -0,0 +1,307 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RecordWildCards #-} + +{- | +Module : Verifier.SAW.TermNet +Copyright : Galois, Inc. 2012-2015 +License : BSD3 +Maintainer : jhendrix@galois.com +Stability : experimental +Portability : non-portable (language extensions) +-} + +module Verifier.SAW.TermNet + ( Pat(..) + , Pattern(..) + , Key + , key_of_term -- :: Pat -> [Key] + , Net -- :: * -> * + , empty -- :: Net a + , insert -- :: Eq a => ([Key], a) -> Net a -> Net a + , insert_term -- :: (Pattern t, Eq a) => (t, a) -> Net a -> Net a + , delete -- :: Eq a => ([Key], a) -> Net a -> Net a + , delete_term -- :: (Pattern t, Eq a) => (t, a) -> Net a -> Net a + , lookup -- :: Net a -> [Key] -> [a] + , match_term -- :: Pattern t => Net a -> t -> [a] + , unify_term -- :: Pattern t => Net a -> t -> [a] + , merge -- :: Eq a => Net a -> Net a -> Net a + , content -- :: Net a -> [a] + ) where + +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (fromMaybe) +import qualified Data.List as List +import Data.Text (Text) +import Prelude hiding (lookup) + +{- +Based on Pure/net.ML from Isabelle 2012. +Ported from Standard ML to Haskell by Brian Huffman. + + Title: Pure/net.ML + Author: Lawrence C Paulson, Cambridge University Computer Laboratory + +Discrimination nets: a data structure for indexing items + +From the book + E. Charniak, C. K. Riesbeck, D. V. McDermott. + Artificial Intelligence Programming. + (Lawrence Erlbaum Associates, 1980). [Chapter 14] + +match_term no longer treats abstractions as wildcards; instead they match +only wildcards in patterns. Requires operands to be beta-eta-normal. +-} + +-- Laziness is important here, as we will often create and partially +-- traverse patterns for very large terms. +data Pat = Atom Text | Var | App Pat Pat + deriving Eq + +class Pattern t where + toPat :: t -> Pat + +instance Show Pat where + showsPrec _ (Atom s) = shows s + showsPrec _ Var = showString "_" + showsPrec p (App x y) = + showParen (p > 5) (showsPrec 5 x . showString " " . showsPrec 6 y) + +isVarApp :: Pat -> Bool +isVarApp t = case t of + Atom _ -> False + Var -> True + App t' _ -> isVarApp t' + +-- Start + +data Key = CombK | VarK | AtomK Text + +{-Keys are preorder lists of symbols -- Combinations, Vars, Atoms. + Any term whose head is a Var is regarded entirely as a Var. + Abstractions are also regarded as Vars; this covers eta-conversion + and "near" eta-conversions such as %x.?P(?f(x)). +-} + +add_key_of_terms :: Pat -> [Key] -> [Key] +add_key_of_terms t cs + | isVarApp t = VarK : cs + | otherwise = add_key_of_terms' t cs + +-- | Precondition: not (isVarApp t). +add_key_of_terms' :: Pat -> [Key] -> [Key] +add_key_of_terms' (App f t) cs = CombK : add_key_of_terms' f (add_key_of_terms t cs) +add_key_of_terms' (Atom c) cs = AtomK c : cs +add_key_of_terms' Var _ = error "impossible" + +{-convert a term to a list of keys-} +key_of_term :: Pat -> [Key] +key_of_term t = add_key_of_terms t [] +{- ^ Required property: @depth (key_of_term t) = 1@ +depth :: [Key] -> Int +depth [] = 0 +depth (CombK : keys) = depth keys - 1 +depth (VarK : keys) = depth keys + 1 +depth (AtomK _ : keys) = depth keys + 1 +-} + +{-Trees indexed by key lists: each arc is labelled by a key. + Each node contains a list of items, and arcs to children. + The empty key addresses the entire net. + Lookup functions preserve order in items stored at same level. +-} + +data Net a + = Leaf [a] + | Net { comb :: Net a, var :: Net a, atoms :: Map Text (Net a) } + deriving Show + +{- +Invariant: A well-formed term net should satisfy @valid 1@. +Every sub-net should satisfy @valid n@ for some non-negative @n@. + +valid :: Int -> Net a -> Bool +valid n (Leaf xs) = null xs || n == 0 +valid n (Net {comb, var, atoms}) = + n > 0 && valid (n+1) comb && valid (n-1) var && all (valid (n-1)) (elems atoms) +-} + +empty :: Net a +empty = Leaf [] + +is_empty :: Net a -> Bool +is_empty (Leaf []) = True +is_empty _ = False + +emptynet :: Net a +emptynet = Net { comb = empty, var = empty, atoms = Map.empty } + +{-** Insertion into a discrimination net **-} + +{-Adds item x to the list at the node addressed by the keys. + Creates node if not already present. + The empty list of keys generates a Leaf node, others a Net node. +-} +insert :: forall a. (Eq a) => ([Key], a) -> Net a -> Net a +insert (keys0, x) net = ins1 keys0 net + where + ins1 :: [Key] -> Net a -> Net a + ins1 [] (Leaf xs) + | x `elem` xs = Leaf xs + | otherwise = Leaf (x : xs) + ins1 keys (Leaf []) = ins1 keys emptynet + ins1 (CombK : keys) (Net {comb, var, atoms}) = + Net {comb = ins1 keys comb, var = var, atoms = atoms} + ins1 (VarK : keys) (Net {comb, var, atoms}) = + Net {comb = comb, var = ins1 keys var, atoms = atoms} + ins1 (AtomK a : keys) (Net {comb, var, atoms}) = + let atoms' = Map.alter (Just . ins1 keys . fromMaybe empty) a atoms + in Net {comb = comb, var = var, atoms = atoms'} + ins1 [] (Net {}) = error "impossible" + ins1 (_ : _) (Leaf (_ : _)) = error "impossible" + +insert_term :: (Pattern t, Eq a) => (t, a) -> Net a -> Net a +insert_term (t, x) = insert (key_of_term (toPat t), x) + +{-** Deletion from a discrimination net **-} + +{-Create a new Net node if it would be nonempty-} +newnet :: Net a -> Net a -> Map Text (Net a) -> Net a +newnet comb var atoms = + if is_empty comb && is_empty var && Map.null atoms + then empty else Net { comb = comb, var = var, atoms = atoms } + +{-Deletes item x from the list at the node addressed by the keys. + Returns Nothing if absent. Collapses the net if possible. -} +delete :: (Eq a) => ([Key], a) -> Net a -> Net a +delete (keys0, x) net0 = del1 keys0 net0 + where + -- | Invariant: @del1 keys net@ requires @valid (depth keys) net@. + del1 [] (Leaf xs) = Leaf (List.delete x xs) + del1 _ (Leaf []) = Leaf [] + del1 (CombK : keys) (Net {comb, var, atoms}) = + newnet (del1 keys comb) var atoms + del1 (VarK : keys) (Net {comb, var, atoms}) = + newnet comb (del1 keys var) atoms + del1 (AtomK a : keys) (Net {comb, var, atoms}) = + let nonempty (Leaf []) = Nothing + nonempty net = Just net + atoms' = Map.update (nonempty . del1 keys) a atoms + in newnet comb var atoms' + del1 [] (Net {}) = error "impossible" + del1 (_ : _) (Leaf (_ : _)) = error "impossible" + +delete_term :: (Pattern t, Eq a) => (t, a) -> Net a -> Net a +delete_term (t, x) = delete (key_of_term (toPat t), x) + +{-** Retrieval functions for discrimination nets **-} + +{-Return the list of items at the given node, [] if no such node-} +-- | Invariant: @lookup net keys@ requires @valid (depth keys) net@. +lookup :: Net a -> [Key] -> [a] +lookup (Leaf xs) [] = xs +lookup (Leaf _) (_ : _) = [] {-non-empty keys and empty net-} +lookup (Net {comb}) (CombK : keys) = lookup comb keys +lookup (Net {var}) (VarK : keys) = lookup var keys +lookup (Net {atoms}) (AtomK a : keys) = + case Map.lookup a atoms of + Just net -> lookup net keys + Nothing -> [] +lookup (Net {}) [] = error "impossible" + +{-Skipping a term in a net. Recursively skip 2 levels if a combination-} +net_skip :: Net a -> [Net a] -> [Net a] +net_skip (Leaf _) nets = nets +net_skip (Net {comb, var, atoms}) nets = + foldr net_skip (Map.foldr (:) (var : nets) atoms) (net_skip comb []) + +{-* Matching and Unification *-} + +{-conses the linked net, if present, to nets-} +look1 :: (Map Text (Net a), Text) -> [Net a] -> [Net a] +look1 (atoms, a) nets = + case Map.lookup a atoms of + Just net -> net : nets + Nothing -> nets + +{-Return the nodes accessible from the term (cons them before nets) + "unif" signifies retrieval for unification rather than matching. + Var in net matches any term. + Abs or Var in object: if "unif", regarded as wildcard, + else matches only a variable in net. +-} +matching :: Bool -> Pat -> Net a -> [Net a] -> [Net a] +matching unif = match + where + match :: Pat -> Net a -> [Net a] -> [Net a] + match t net nets = + case net of + Leaf _ -> nets + Net {var} -> + case t of + Var -> if unif then net_skip net nets else var : nets {-only matches Var in net-} + _ -> rands t net (var : nets) {-var could match also-} + rands :: Pat -> Net a -> [Net a] -> [Net a] + rands _ (Leaf _) nets = nets + rands t (Net {comb, atoms}) nets = + case t of + Atom c -> look1 (atoms, c) nets + Var -> nets + App t1 t2 -> foldr (match t2) nets (rands t1 comb []) + +extract_leaves :: [Net a] -> [a] +extract_leaves = concatMap (\(Leaf xs) -> xs) + +{-return items whose key could match t, WHICH MUST BE BETA-ETA NORMAL-} +match_term :: Pattern t => Net a -> t -> [a] +match_term net t = extract_leaves (matching False (toPat t) net []) + +{-return items whose key could unify with t-} +unify_term :: Pattern t => Net a -> t -> [a] +unify_term net t = extract_leaves (matching True (toPat t) net []) + +{-------------------------------------------------------------------- + +{-* operations on nets *-} + +{-subtraction: collect entries of second net that are NOT present in first net-} +fun subtract eq net1 net2 = + let + fun subtr (Net _) (Leaf ys) = append ys + | subtr (Leaf xs) (Leaf ys) = + fold_rev (fn y => if member eq xs y then I else cons y) ys + | subtr (Leaf _) (net as Net _) = subtr emptynet net + | subtr (Net {comb = comb1, var = var1, atoms = atoms1}) + (Net {comb = comb2, var = var2, atoms = atoms2}) = + subtr comb1 comb2 + #> subtr var1 var2 + #> Symtab.fold (fn (a, net) => + subtr (the_default emptynet (Symtab.lookup atoms1 a)) net) atoms2 + in subtr net1 net2 [] end; + +fun entries net = subtract (K false) empty net; + +--------------------------------------------------------------------------------} + +{- merge -} + +cons_fst :: a -> ([a], b) -> ([a], b) +cons_fst x (xs, y) = (x : xs, y) + +dest :: Net a -> [([Key], a)] +dest (Leaf xs) = map ((,) []) xs +dest (Net {comb, var, atoms}) = + map (cons_fst CombK) (dest comb) ++ + map (cons_fst VarK) (dest var) ++ + concatMap (\(a, net) -> map (cons_fst (AtomK a)) (dest net)) (Map.assocs atoms) + +merge :: Eq a => Net a -> Net a -> Net a +merge net1 net2 = foldl (flip insert) net1 (dest net2) + +content :: Net a -> [a] +content (Leaf xs) = xs +content (Net {comb, var, atoms}) = + content comb ++ + content var ++ + concatMap content (Map.elems atoms) diff --git a/saw-core/src/Verifier/SAW/Testing/Random.hs b/saw-core/src/Verifier/SAW/Testing/Random.hs new file mode 100644 index 0000000000..5f32ed8401 --- /dev/null +++ b/saw-core/src/Verifier/SAW/Testing/Random.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DoAndIfThenElse #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +-- | +-- Module : Verifier.SAW.Testing.Random +-- Copyright : (c) 2013-2015 Galois, Inc. +-- License : BSD3 +-- Maintainer : jhendrix@galois.com, conathan@galois.com +-- Stability : experimental +-- Portability : portable +-- +-- This module generates random values for 'FiniteValue.FiniteType' types. +-- +-- Based on 'Cryptol.Testing.Random'. + +module Verifier.SAW.Testing.Random where + +import Verifier.SAW.FiniteValue + ( FirstOrderType(..), FirstOrderValue(..), scFirstOrderValue ) + +import Verifier.SAW.Module (ModuleMap) +import Verifier.SAW.SATQuery +import Verifier.SAW.SharedTerm + ( scGetModuleMap, SharedContext, Term + , ExtCns(..), scInstantiateExt + ) +import Verifier.SAW.Simulator.Concrete (evalSharedTerm) -- , CValue) +import Verifier.SAW.Simulator.Value (Value(..)) -- , TValue(..)) + + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>), Applicative) +import Data.Traversable (traverse) +#endif +import qualified Control.Monad.Fail as F +import Control.Monad.Random +import Data.Functor.Compose (Compose(..)) +import qualified Data.Map as Map +import qualified Data.Set as Set +import System.Random.TF (newTFGen, TFGen) + + + +randomFirstOrderValue :: (Applicative m, Functor m, MonadRandom m) => + FirstOrderType -> Compose Maybe m FirstOrderValue +randomFirstOrderValue FOTBit = + Compose (Just (FOVBit <$> getRandom)) +randomFirstOrderValue FOTInt = + Compose (Just (FOVInt <$> randomInt)) +randomFirstOrderValue (FOTIntMod m) = + Compose (Just (FOVIntMod m <$> getRandomR (0, toInteger m - 1))) +randomFirstOrderValue (FOTVec n FOTBit) = + Compose (Just (FOVWord n <$> getRandomR (0, 2^n - 1))) +randomFirstOrderValue (FOTVec n t) = + FOVVec t <$> replicateM (fromIntegral n) (randomFirstOrderValue t) +randomFirstOrderValue (FOTTuple ts) = + FOVTuple <$> traverse randomFirstOrderValue ts +randomFirstOrderValue (FOTRec fs) = + FOVRec <$> traverse randomFirstOrderValue fs +randomFirstOrderValue (FOTArray _ _) = Compose Nothing + + +-- TODO this is really a hack +randomInt :: MonadRandom m => m Integer +randomInt = getRandomR (-10^(6::Int), 10^(6::Int)) + + + +execTest :: + (F.MonadFail m, MonadRandom m, MonadIO m) => + SharedContext -> + ModuleMap -> + Map.Map (ExtCns Term) (m FirstOrderValue) -> + Term -> + m (Maybe [(ExtCns Term, FirstOrderValue)]) +execTest sc mmap vars tm = + do testVec <- sequence vars + tm' <- liftIO $ + do argMap0 <- traverse (scFirstOrderValue sc) testVec + let argMap = Map.fromList [ (ecVarIndex ec, v) | (ec,v) <- Map.toList argMap0 ] + scInstantiateExt sc argMap tm + case evalSharedTerm mmap Map.empty Map.empty tm' of + -- satisfaible, return counterexample + VBool True -> return (Just (Map.toList testVec)) + -- not satisfied by this test vector + VBool False -> return Nothing + _ -> fail "execTest: expected boolean result from random testing" + +prepareSATQuery :: + (MonadRandom m, F.MonadFail m, MonadIO m) => + SharedContext -> + SATQuery -> + IO (m (Maybe [(ExtCns Term, FirstOrderValue)])) +prepareSATQuery sc satq + | Set.null (satUninterp satq) = + do varmap <- traverse prepareVar (satVariables satq) + t <- satQueryAsTerm sc satq + mmap <- scGetModuleMap sc + return (execTest sc mmap varmap t) + | otherwise = fail "Random testing cannot handle uninterpreted functions" + + where + prepareVar fot = + case randomFirstOrderValue fot of + Compose (Just v) -> pure v + _ -> fail ("Cannot randomly test argument of type: " ++ show fot) + +runManyTests :: + RandT TFGen IO (Maybe [(ExtCns Term, FirstOrderValue)]) -> + Integer -> + IO (Maybe [(ExtCns Term, FirstOrderValue)]) +runManyTests m numtests = evalRandT (loop numtests) =<< newTFGen + where + loop n + | n > 0 = + m >>= \case + Nothing -> loop (n-1) + Just cex -> return (Just cex) + + | otherwise = return Nothing diff --git a/saw-core/src/Verifier/SAW/Typechecker.hs b/saw-core/src/Verifier/SAW/Typechecker.hs new file mode 100644 index 0000000000..a7c241bf27 --- /dev/null +++ b/saw-core/src/Verifier/SAW/Typechecker.hs @@ -0,0 +1,477 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- The above is needed because we want our orphan TypeInfer instance below + +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DoAndIfThenElse #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE RecordWildCards #-} + +{- | +Module : Verifier.SAW.Typechecker +Copyright : Galois, Inc. 2012-2015 +License : BSD3 +Maintainer : jhendrix@galois.com +Stability : experimental +Portability : non-portable (language extensions) +-} + +module Verifier.SAW.Typechecker + ( inferCompleteTerm + , tcInsertModule + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif +import Control.Monad.State +import Data.List (findIndex) +import Data.Text (Text) +import qualified Data.Vector as V + +import Prettyprinter hiding (Doc) + +import Verifier.SAW.Utils (internalError) + +import Verifier.SAW.Module +import Verifier.SAW.Name (mkIdentText) +import Verifier.SAW.Position +import Verifier.SAW.Term.Functor +import Verifier.SAW.Term.CtxTerm +import Verifier.SAW.Term.Pretty (SawDoc) +import Verifier.SAW.SharedTerm +import Verifier.SAW.Recognizer +import Verifier.SAW.SCTypeCheck +import qualified Verifier.SAW.UntypedAST as Un + +import Debug.Trace + +-- | Infer the type of an untyped term and complete it to a 'Term', all in the +-- empty typing context +inferCompleteTerm :: SharedContext -> Maybe ModuleName -> Un.Term -> + IO (Either SawDoc Term) +inferCompleteTerm sc mnm t = inferCompleteTermCtx sc mnm [] t + +-- | Infer the type of an untyped term and complete it to a 'Term' in a given +-- typing context +inferCompleteTermCtx :: + SharedContext -> Maybe ModuleName -> [(LocalName, Term)] -> + Un.Term -> IO (Either SawDoc Term) +inferCompleteTermCtx sc mnm ctx t = + do res <- runTCM (typeInferComplete t) sc mnm ctx + case res of + -- TODO: avoid intermediate 'String's from 'prettyTCError' + Left err -> return $ Left $ vsep $ map pretty $ prettyTCError err + Right t' -> return $ Right $ typedVal t' + +-- | Look up the current module name, raising an error if it is not set +getModuleName :: TCM ModuleName +getModuleName = + do maybe_modname <- askModName + case maybe_modname of + Just mnm -> return mnm + Nothing -> + internalError "Current module name not set during typechecking" + +-- | Look up the current module +getModule :: TCM Module +getModule = getModuleName >>= liftTCM scFindModule + +-- | Build a multi-arity application of 'TypedTerm's +inferApplyAll :: TypedTerm -> [TypedTerm] -> TCM TypedTerm +inferApplyAll t [] = return t +inferApplyAll t (arg:args) = + do app1 <- typeInferComplete (App t arg) + inferApplyAll app1 args + +-- | Resolve a name in the current module and apply it to some arguments +inferResolveNameApp :: Text -> [TypedTerm] -> TCM TypedTerm +inferResolveNameApp n args = + do ctx <- askCtx + m <- getModule + case (findIndex ((== n) . fst) ctx, resolveName m n) of + (Just i, _) -> + do t <- typeInferComplete (LocalVar i :: TermF TypedTerm) + inferApplyAll t args + (_, Just (ResolvedCtor ctor)) -> + let (params, ctor_args) = splitAt (ctorNumParams ctor) args in + -- NOTE: typeInferComplete will check that we have the correct number + -- of arguments + typeInferComplete (CtorApp (ctorName ctor) params ctor_args) + (_, Just (ResolvedDataType dt)) -> + let (params, ixs) = splitAt (length $ dtParams dt) args in + -- NOTE: typeInferComplete will check that we have the correct number + -- of indices + typeInferComplete (DataTypeApp (dtName dt) params ixs) + (_, Just (ResolvedDef d)) -> + do t <- liftTCM scGlobalDef (defIdent d) + f <- TypedTerm t <$> liftTCM scTypeOf t + inferApplyAll f args + (Nothing, Nothing) -> + throwTCError $ UnboundName n + +-- | Match an untyped term as a name applied to 0 or more arguments +matchAppliedName :: Un.Term -> Maybe (Text, [Un.Term]) +matchAppliedName (Un.Name (PosPair _ n)) = Just (n, []) +matchAppliedName (Un.App f arg) = + do (n, args) <- matchAppliedName f + return (n, args++[arg]) +matchAppliedName _ = Nothing + +-- | Match an untyped term as a recursor applied to 0 or more arguments +matchAppliedRecursor :: Un.Term -> Maybe (Maybe ModuleName, Text, [Un.Term]) +matchAppliedRecursor (Un.Recursor mnm (PosPair _ n)) = Just (mnm, n, []) +matchAppliedRecursor (Un.App f arg) = + do (mnm, n, args) <- matchAppliedRecursor f + return (mnm, n, args++[arg]) +matchAppliedRecursor _ = Nothing + +-- | The debugging level +debugLevel :: Int +debugLevel = 0 + +-- | Print debugging output if 'debugLevel' is greater than 0 +typeInferDebug :: String -> TCM () +typeInferDebug str | debugLevel > 0 = liftIO $ traceIO str +typeInferDebug _ = return () + +-- The type inference engine for untyped terms, which mostly just dispatches to +-- the type inference engine for (FTermF TypedTerm) defined in SCTypeCheck.hs +instance TypeInfer Un.Term where + typeInfer t = typedVal <$> typeInferComplete t + + typeInferComplete t = + do typeInferDebug ("typechecking term: " ++ show t) + res <- atPos (pos t) $ typeInferCompleteTerm t + typeInferDebug ("completed typechecking term: " ++ show t ++ "\n" + ++ "type = " ++ show (typedType res)) + return res + +-- | Main workhorse function for type inference on untyped terms +typeInferCompleteTerm :: Un.Term -> TCM TypedTerm + +-- Names +typeInferCompleteTerm (matchAppliedName -> Just (n, args)) = + mapM typeInferComplete args >>= inferResolveNameApp n +typeInferCompleteTerm (Un.Name (PosPair _ n)) = + -- NOTE: this is actually covered by the previous case, but we put it here + -- so GHC doesn't complain about coverage + inferResolveNameApp n [] + +-- Sorts +typeInferCompleteTerm (Un.Sort _ srt) = + typeInferComplete (Sort srt :: FlatTermF TypedTerm) + +-- Recursors (must come before applications) +typeInferCompleteTerm (matchAppliedRecursor -> Just (maybe_mnm, str, args)) = + do mnm <- + case maybe_mnm of + Just mnm -> return mnm + Nothing -> getModuleName + m <- liftTCM scFindModule mnm + let dt_ident = mkIdentText mnm str + dt <- case findDataType m str of + Just d -> return d + Nothing -> throwTCError $ NoSuchDataType dt_ident + typed_args <- mapM typeInferComplete args + case typed_args of + (splitAt (length $ dtParams dt) -> + (params, + p_ret : + (splitAt (length $ dtCtors dt) -> + (elims, + (splitAt (length $ dtIndices dt) -> + (ixs, arg : rem_args)))))) -> + do let cs_fs = zip (map ctorName $ dtCtors dt) elims + typed_r <- typeInferComplete (RecursorApp dt_ident params + p_ret cs_fs ixs arg) + inferApplyAll typed_r rem_args + _ -> throwTCError $ NotFullyAppliedRec dt_ident +typeInferCompleteTerm (Un.Recursor _ _) = + error "typeInferComplete: found a bare Recursor, which should never happen!" + +-- Applications, lambdas, and pis +typeInferCompleteTerm (Un.App f arg) = + (App <$> typeInferComplete f <*> typeInferComplete arg) + >>= typeInferComplete +typeInferCompleteTerm (Un.Lambda _ [] t) = typeInferComplete t +typeInferCompleteTerm (Un.Lambda p ((Un.termVarLocalName -> x, tp) : ctx) t) = + do tp_trm <- typeInferCompleteWHNF tp + -- Normalize (the Term value of) tp before putting it into the context. See + -- the documentation for withVar. + body <- withVar x (typedVal tp_trm) $ + typeInferComplete $ Un.Lambda p ctx t + typeInferComplete (Lambda x tp_trm body) +typeInferCompleteTerm (Un.Pi _ [] t) = typeInferComplete t +typeInferCompleteTerm (Un.Pi p ((Un.termVarLocalName -> x, tp) : ctx) t) = + do tp_trm <- typeInferComplete tp + -- NOTE: we need the type of x to be normalized when we add it to the + -- context in withVar, but we do not want to normalize this type in the + -- output, as the contract for typeInferComplete only normalizes the type, + -- so we use the unnormalized tp_trm in the return + tp_whnf <- typeCheckWHNF $ typedVal tp_trm + body <- withVar x tp_whnf $ + typeInferComplete $ Un.Pi p ctx t + typeInferComplete (Pi x tp_trm body) + +-- Non-dependent records +typeInferCompleteTerm (Un.RecordValue _ elems) = + do typed_elems <- + mapM (\(PosPair _ fld, t) -> (fld,) <$> typeInferComplete t) elems + typeInferComplete (RecordValue typed_elems) +typeInferCompleteTerm (Un.RecordType _ elems) = + do typed_elems <- + mapM (\(PosPair _ fld, t) -> (fld,) <$> typeInferComplete t) elems + typeInferComplete (RecordType typed_elems) +typeInferCompleteTerm (Un.RecordProj t prj) = + (RecordProj <$> typeInferComplete t <*> return prj) >>= typeInferComplete + +-- Unit +typeInferCompleteTerm (Un.UnitValue _) = + typeInferComplete (UnitValue :: FlatTermF TypedTerm) +typeInferCompleteTerm (Un.UnitType _) = + typeInferComplete (UnitType :: FlatTermF TypedTerm) + +-- Simple pairs +typeInferCompleteTerm (Un.PairValue _ t1 t2) = + (PairValue <$> typeInferComplete t1 <*> typeInferComplete t2) + >>= typeInferComplete +typeInferCompleteTerm (Un.PairType _ t1 t2) = + (PairType <$> typeInferComplete t1 <*> typeInferComplete t2) + >>= typeInferComplete +typeInferCompleteTerm (Un.PairLeft t) = + (PairLeft <$> typeInferComplete t) >>= typeInferComplete +typeInferCompleteTerm (Un.PairRight t) = + (PairRight <$> typeInferComplete t) >>= typeInferComplete + +-- Type ascriptions +typeInferCompleteTerm (Un.TypeConstraint t _ tp) = + do typed_t <- typeInferComplete t + typed_tp <- typeInferComplete tp + _ <- ensureSort (typedType typed_tp) + checkSubtype typed_t (typedVal typed_tp) + return typed_t + +-- Literals +typeInferCompleteTerm (Un.NatLit _ i) = + typeInferComplete (NatLit i :: FlatTermF TypedTerm) +typeInferCompleteTerm (Un.StringLit _ str) = + typeInferComplete (StringLit str :: FlatTermF TypedTerm) +typeInferCompleteTerm (Un.VecLit _ []) = throwTCError EmptyVectorLit +typeInferCompleteTerm (Un.VecLit _ ts) = + do typed_ts <- mapM typeInferComplete ts + tp <- case typed_ts of + (t1:_) -> return $ typedType t1 + [] -> throwTCError $ EmptyVectorLit + type_of_tp <- typeInfer tp + typeInferComplete (ArrayValue (TypedTerm tp type_of_tp) $ + V.fromList typed_ts) + +typeInferCompleteTerm (Un.BadTerm _) = + -- Should be unreachable, since BadTerms represent parse errors, that should + -- already have been signaled before type inference + internalError "Type inference encountered a BadTerm" + + +instance TypeInferCtx Un.TermVar Un.Term where + typeInferCompleteCtx = + typeInferCompleteCtx . map (\(x,tp) -> (Un.termVarLocalName x, tp)) + + +-- +-- Type-checking modules +-- + +-- | Type-check a list of declarations and insert them into the current module +processDecls :: [Un.Decl] -> TCM () +processDecls [] = return () +processDecls (Un.TypedDef nm params rty body : rest) = + processDecls (Un.TypeDecl NoQualifier nm (Un.Pi (pos nm) params rty) : + Un.TermDef nm (map fst params) body : rest) +processDecls (Un.TypeDecl NoQualifier (PosPair p nm) tp : + Un.TermDef (PosPair _ ((== nm) -> True)) vars body : rest) = + -- Type-checking for definitions + (atPos p $ + do + -- Step 1: type-check the type annotation, and make sure it is a type + typed_tp <- typeInferComplete tp + void $ ensureSort $ typedType typed_tp + let def_tp = typedVal typed_tp + def_tp_whnf <- liftTCM scTypeCheckWHNF def_tp + + -- Step 2: assign types to the bound variables of the definition, by + -- peeling off the pi-abstraction variables in the type annotation. Any + -- remaining body of the pi-type is the required type for the def body. + (ctx, req_body_tp) <- + case matchPiWithNames (map Un.termVarLocalName vars) def_tp_whnf of + Just x -> return x + Nothing -> + throwTCError $ + DeclError nm ("More variables " ++ show vars ++ + " than length of function type:\n" ++ + showTerm (typedVal typed_tp)) + + -- Step 3: type-check the body of the definition in the context of its + -- variables, and build a function that takes in those variables + def_tm <- + withCtx ctx $ + do typed_body <- typeInferComplete body + checkSubtype typed_body req_body_tp + liftTCM scLambdaList ctx (typedVal typed_body) + + -- Step 4: add the definition to the current module + mnm <- getModuleName + let ident = mkIdentText mnm nm + t <- liftTCM scConstant' (ModuleIdentifier ident) def_tm def_tp + liftTCM scRegisterGlobal ident t + liftTCM scModifyModule mnm $ \m -> + insDef m $ Def { defIdent = ident, + defQualifier = NoQualifier, + defType = def_tp, + defBody = Just def_tm }) >> + processDecls rest + +processDecls (Un.TypeDecl NoQualifier (PosPair p nm) _ : _) = + atPos p $ throwTCError $ DeclError nm "Definition without defining equation" +processDecls (Un.TypeDecl _ (PosPair p nm) _ : + Un.TermDef (PosPair _ ((== nm) -> True)) _ _ : _) = + atPos p $ throwTCError $ DeclError nm "Primitive or axiom with definition" +processDecls (Un.TypeDecl q (PosPair p nm) tp : rest) = + (atPos p $ + do typed_tp <- typeInferComplete tp + void $ ensureSort $ typedType typed_tp + mnm <- getModuleName + let ident = mkIdentText mnm nm + let nmi = ModuleIdentifier ident + i <- liftTCM scFreshGlobalVar + liftTCM scRegisterName i nmi + let def_tp = typedVal typed_tp + let ec = EC i nmi def_tp + t <- liftTCM scFlatTermF (Primitive ec) + liftTCM scRegisterGlobal ident t + liftTCM scModifyModule mnm $ \m -> + insDef m $ Def { defIdent = ident, + defQualifier = q, + defType = typedVal typed_tp, + defBody = Nothing }) >> + processDecls rest +processDecls (Un.TermDef (PosPair p nm) _ _ : _) = + atPos p $ throwTCError $ DeclError nm "Dangling definition without a type" +processDecls (Un.DataDecl (PosPair p nm) param_ctx dt_tp c_decls : rest) = + -- This top line makes sure that we process the rest of the decls after the + -- main body of the code below, which processes just the current data decl + (>> processDecls rest) $ atPos p $ + -- Step 1: type-check the parameters + typeInferCompleteInCtx param_ctx $ \params -> do + let dtParams = map (\(x,tp,_) -> (x,tp)) params + let param_sort = maxSort (map (\(_,_,s) -> s) params) + let err :: String -> TCM a + err msg = throwTCError $ DeclError nm msg + + -- Step 2: type-check the type given for d, and make sure it is of the form + -- (i1:ix1) -> ... -> (in:ixn) -> Type s for some sort s. Then form the full + -- type of d as (p1:param1) -> ... -> (i1:ix1) -> ... -> Type s + (dt_ixs, dtSort) <- + case Un.asPiList dt_tp of + (ixs, Un.Sort _ s) -> return (ixs, s) + _ -> err "Wrong form for type of datatype" + dt_ixs_typed <- typeInferCompleteCtx dt_ixs + let dtIndices = map (\(x,tp,_) -> (x,tp)) dt_ixs_typed + ixs_max_sort = maxSort (map (\(_,_,s) -> s) dt_ixs_typed) + dtType <- (liftTCM scPiList (dtParams ++ dtIndices) + =<< liftTCM scSort dtSort) + + -- Step 3: do the necessary universe inclusion checking for any predicative + -- (non-Prop) inductive type, which includes: + -- + -- 1. All ix types must be of sort dtSort; AND + -- 2. All param types must be of sort dtSort+1 + if dtSort /= propSort && param_sort > sortOf dtSort then + err ("Universe level of parameters should be no greater" ++ + " than that of the datatype") + else return () + if dtSort /= propSort && ixs_max_sort > dtSort then + err ("Universe level of indices should be strictly contained" ++ + " in that of the datatype") + else return () + + -- Step 4: Add d as an empty datatype, so we can typecheck the constructors + mnm <- getModuleName + let dtName = mkIdentText mnm nm + let dt = DataType { dtCtors = [], .. } + liftTCM scModifyModule mnm (\m -> beginDataType m dt) + + -- Step 5: typecheck the constructors, and build Ctors for them + typed_ctors <- + mapM (\(Un.Ctor (PosPair p' c) ctx body) -> + (c,) <$> typeInferComplete (Un.Pi p' ctx body)) c_decls + ctors <- + case ctxBindingsOfTerms dtParams of + ExistsTp p_ctx -> + case ctxBindingsOfTerms dtIndices of + ExistsTp ix_ctx -> + forM typed_ctors $ \(c, typed_tp) -> + -- Check that the universe level of the type of each constructor + (case asSort (typedType typed_tp) of + Just ctor_sort + | dtSort /= propSort && ctor_sort > dtSort -> + err ("Universe level of constructors should be strictly" ++ + " contained in that of the datatype") + Just _ -> return () + Nothing -> error ("Internal error: type of the type of" ++ + " constructor is not a sort!")) >> + let tp = typedVal typed_tp in + case mkCtorArgStruct dtName p_ctx ix_ctx tp of + Just arg_struct -> + liftTCM scBuildCtor dtName (mkIdentText mnm c) + (map (mkIdentText mnm . fst) typed_ctors) + arg_struct + Nothing -> err ("Malformed type form constructor: " ++ show c) + + -- Step 6: complete the datatype with the given ctors + liftTCM scModifyModule mnm (\m -> completeDataType m dtName ctors) + + +-- | Typecheck a module and, on success, insert it into the current context +tcInsertModule :: SharedContext -> Un.Module -> IO () +tcInsertModule sc (Un.Module (PosPair _ mnm) imports decls) = do + let myfail :: String -> IO a + myfail msg = scUnloadModule sc mnm >> fail msg + -- First, insert an empty module for mnm + scLoadModule sc $ emptyModule mnm + -- Next, process all the imports + forM_ imports $ \imp -> + do i_exists <- scModuleIsLoaded sc (val $ Un.importModName imp) + i <- if i_exists then scFindModule sc $ val $ Un.importModName imp else + myfail $ "Imported module not found: " ++ show mnm + scModifyModule sc mnm + (insImport (Un.nameSatsConstraint (Un.importConstraints imp) + . identName . resolvedNameIdent) i) + -- Finally, process all the decls + decls_res <- runTCM (processDecls decls) sc (Just mnm) [] + case decls_res of + Left err -> myfail $ unlines $ prettyTCError err + Right _ -> return () + + +-- +-- Helper functions for type-checking modules +-- + +-- | Pattern match a nested pi-abstraction, like 'asPiList', but only match as +-- far as the supplied list of variables, and use them as the new names +matchPiWithNames :: [LocalName] -> Term -> Maybe ([(LocalName, Term)], Term) +matchPiWithNames [] tp = return ([], tp) +matchPiWithNames (var:vars) (asPi -> Just (_, arg_tp, body_tp)) = + do (ctx,body) <- matchPiWithNames vars body_tp + return ((var,arg_tp):ctx,body) +matchPiWithNames _ _ = Nothing diff --git a/saw-core/src/Verifier/SAW/TypedAST.hs b/saw-core/src/Verifier/SAW/TypedAST.hs new file mode 100644 index 0000000000..f629082438 --- /dev/null +++ b/saw-core/src/Verifier/SAW/TypedAST.hs @@ -0,0 +1,122 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{- | +Module : Verifier.SAW.TypedAST +Copyright : Galois, Inc. 2012-2015 +License : BSD3 +Maintainer : jhendrix@galois.com +Stability : experimental +Portability : non-portable (language extensions) +-} + +module Verifier.SAW.TypedAST + ( -- * Module operations. + Module + , emptyModule + , ModuleName, mkModuleName + , moduleName + , preludeName + , ModuleMap + , ModuleDecl(..) + , moduleDecls + , allModuleDecls + , moduleDataTypes + , moduleImports + , findDataType + , findDataTypeInMap + , moduleCtors + , findCtor + , findCtorInMap + , moduleDefs + , allModuleDefs + , findDef + , insImport + , insDataType + , insDef + , moduleActualDefs + , allModuleActualDefs + , modulePrimitives + , allModulePrimitives + , moduleAxioms + , allModuleAxioms + -- * Data types and definitions. + , DataType(..) + , Ctor(..) + , ctorNumParams + , CtorArg(..) + , Def(..) + , DefQualifier(..) + -- * Terms and associated operations. + , incVarsSimpleTerm + , piArgCount + , TermF(..) + , FlatTermF(..) + , unwrapTermF + , zipWithFlatTermF + , freesTermF + , termToPat + + , PPOpts(..) + , defaultPPOpts + , ppTerm + , ppTermDepth + , showTerm + , scPrettyTerm + , scPrettyTermInCtx + -- * Primitive types. + , Sort, mkSort, propSort, sortOf, maxSort + , Ident(..), identName, mkIdent + , NameInfo(..), toShortName, toAbsoluteName + , parseIdent + , isIdent + , DeBruijnIndex + , FieldName + , LocalName + , ExtCns(..) + , VarIndex + -- * Utility functions + , BitSet, emptyBitSet, inBitSet, unionBitSets, intersectBitSets + , decrBitSet, completeBitSet + ) where + +import Control.Exception (assert) + +import Prelude hiding (all, foldr) + +import Verifier.SAW.Module +import Verifier.SAW.Term.Functor +import Verifier.SAW.Term.Pretty + +-- | Returns the number of nested pi expressions. +piArgCount :: Term -> Int +piArgCount = go 0 + where go i t = case unwrapTermF t of + Pi _ _ rhs -> go (i+1) rhs + _ -> i + +-- | @instantiateVars f l t@ substitutes each dangling bound variable +-- @LocalVar j t@ with the term @f i j t@, where @i@ is the number of +-- binders surrounding @LocalVar j t@. +instantiateVars :: (DeBruijnIndex -> DeBruijnIndex -> Term) + -> DeBruijnIndex -> Term -> Term +instantiateVars f initialLevel = go initialLevel + where go :: DeBruijnIndex -> Term -> Term + go l (unwrapTermF -> tf) = + case tf of + FTermF ftf -> Unshared $ FTermF $ fmap (go l) ftf + App x y -> Unshared $ App (go l x) (go l y) + Constant{} -> Unshared tf -- assume rhs is a closed term, so leave it unchanged + Lambda i tp rhs -> Unshared $ Lambda i (go l tp) (go (l+1) rhs) + Pi i lhs rhs -> Unshared $ Pi i (go l lhs) (go (l+1) rhs) + LocalVar i + | i < l -> Unshared $ LocalVar i + | otherwise -> f l i + +-- | @incVars j k t@ increments free variables at least @j@ by @k@. +-- e.g., incVars 1 2 (C ?0 ?1) = C ?0 ?3 +incVarsSimpleTerm :: DeBruijnIndex -> DeBruijnIndex -> Term -> Term +incVarsSimpleTerm _ 0 = id +incVarsSimpleTerm initialLevel j = assert (j > 0) $ instantiateVars fn initialLevel + where fn _ i = Unshared $ LocalVar (i+j) diff --git a/saw-core/src/Verifier/SAW/UnionFind.hs b/saw-core/src/Verifier/SAW/UnionFind.hs new file mode 100644 index 0000000000..1615bf1da5 --- /dev/null +++ b/saw-core/src/Verifier/SAW/UnionFind.hs @@ -0,0 +1,195 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{- | +Module : Verifier.SAW.UnionFind +Copyright : Galois, Inc. 2012-2015 +License : BSD3 +Maintainer : jhendrix@galois.com +Stability : experimental +Portability : non-portable (language extensions) +-} + +module Verifier.SAW.UnionFind ( + AssertResult(..) + , assertSucceeded + -- * Class operations + , Class + , UnionFind + , empty + , Action + , runAction + , classRep + , freshClass + , areEqual + , setEqual + , setUnequal + -- * Class descriptions + , readClassDesc + , writeClassDesc + , modifyClassDesc + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative (Applicative) +#endif +import Control.Monad.State.Strict +import Data.List (foldl') +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Data.Set as Set + +-- Types {{{1 + +type ClassIndex = Int + +-- | Equivalence class in union find structure. +newtype Class d = Class ClassIndex + +data ClassState d = NonRep !ClassIndex + | Rep { + _classNeqs :: [ClassIndex] -- ^ Classes not equal to this class + , _classSize :: !Int -- ^ Size of class + , _classDesc :: d -- ^ Class descriptor + } + +data UnionFind d = UFS { + ufsCount :: !Int + , ufsMap :: !(Map ClassIndex (ClassState d)) + } + +-- | Returns union find struct with no classes. +empty :: UnionFind d +empty = UFS { ufsCount = 0, ufsMap = Map.empty } + +-- | Monad with scoped union find support. +newtype Action d a = UF { _unUF :: State (UnionFind d) a } + deriving (Functor, Applicative, Monad) + +-- | Runs union find computation. +runAction :: UnionFind d -> Action d a -> (a, UnionFind d) +runAction s (UF m) = runState m s + +-- Class operations {{{1 + +-- | Get class description +classRep :: Class d -> Action d (Class d) +classRep (Class r) = UF $ do + m <- gets ufsMap + let impl i prev = do + case Map.lookup i m of + Nothing -> error $ "classRep: Illegal index " ++ show i + Just (NonRep next) -> impl next (i:prev) + Just Rep{} -> do + let updateRep ma j = Map.insert j (NonRep i) ma + modify $ \s -> s { ufsMap = foldl' updateRep (ufsMap s) prev } + return (Class i) + impl r [] + +-- | Creates a new class with the given descriptor. +freshClass :: d -> Action d (Class d) +freshClass d = UF $ do + UFS { ufsCount = c, ufsMap = m } <- get + put UFS { ufsCount = c + 1, ufsMap = Map.insert c (Rep [] 1 d) m } + return $ Class c + +-- | Return true if two classes are equal. +areEqual :: Class d -> Class d -> Action d Bool +areEqual cx cy = do + Class rx <- classRep cx + Class ry <- classRep cy + return (rx == ry) + +toClassIdx :: Class d -> ClassIndex +toClassIdx (Class c) = c + +data AssertResult = AssertSuccess | AssertFailed | AssertRedundant + deriving (Eq, Show) + +assertSucceeded :: AssertResult -> Bool +assertSucceeded AssertSuccess = True +assertSucceeded AssertFailed = False +assertSucceeded AssertRedundant = True + +-- | Attempt to set two equivalence classes to be equal. +-- Returns true if attempt succeeded, and false is classes are +-- previously set inequal. +setEqual :: Class d + -> Class d + -> d -- ^ Descriptor for union class. + -> Action d AssertResult +setEqual x y d = do + Class xr <- classRep x + Class yr <- classRep y + if xr == yr + then return AssertRedundant + else do + m <- UF $ gets ufsMap + let Rep xne xsz _xd = m Map.! xr + let Rep yne ysz _yd = m Map.! yr + xElts <- fmap (map toClassIdx) $ mapM classRep (map Class xne) + yElts <- fmap (map toClassIdx) $ mapM classRep (map Class yne) + if xr `elem` yElts || yr `elem` xElts + then return AssertFailed + else do + let neqs = Set.toList $ Set.fromList $ xElts ++ yElts + UF $ modify $ \s -> + if xsz < ysz + then do + s { ufsMap = + Map.insert xr (NonRep yr) $ + Map.insert yr (Rep neqs (xsz + ysz) d) $ + ufsMap s } + else do + s { ufsMap = + Map.insert xr (Rep neqs (xsz + ysz) d) $ + Map.insert yr (NonRep xr) $ + ufsMap s } + return AssertSuccess + +-- | Attempt to set two equivalence classes to be unequal. +-- Returns true if attempt succeeded, and false is classes are +-- previously set equal. +setUnequal :: Class d -> Class d -> Action d AssertResult +setUnequal x y = do + Class xr <- classRep x + Class yr <- classRep y + if xr == yr + then return AssertFailed + else do + m <- UF $ gets ufsMap + let Rep xne xsz xd = m Map.! xr + let Rep yne _ _ = m Map.! yr + xElts <- fmap (map toClassIdx) $ mapM classRep (map Class xne) + yElts <- fmap (map toClassIdx) $ mapM classRep (map Class yne) + if xr `elem` yElts || yr `elem` xElts + then return AssertRedundant + else do + UF $ modify $ \s -> s { ufsMap = Map.insert xr (Rep (yr:xne) xsz xd) (ufsMap s) } + return AssertSuccess + +-- Class descriptions {{{1 + +-- | Get a class description +readClassDesc :: Class d -> Action d d +readClassDesc c = do + Class rC <- classRep c + m <- UF $ gets ufsMap + let Rep _ _ desc = m Map.! rC + return desc + +-- | Set a class description +writeClassDesc :: Class d -> d -> Action d () +writeClassDesc c d = do + Class rC <- classRep c + UF $ modify $ \s -> + let Rep dis sz _ = (ufsMap s) Map.! rC + in s { ufsMap = Map.insert rC (Rep dis sz d) (ufsMap s) } + +-- | Modify a class description +modifyClassDesc :: Class d -> (d -> d) -> Action d () +modifyClassDesc c fn = do + Class rC <- classRep c + UF $ modify $ \s -> + let Rep dis sz desc = (ufsMap s) Map.! rC + in s { ufsMap = Map.insert rC (Rep dis sz (fn desc)) (ufsMap s) } + diff --git a/saw-core/src/Verifier/SAW/Unique.hs b/saw-core/src/Verifier/SAW/Unique.hs new file mode 100644 index 0000000000..317254e915 --- /dev/null +++ b/saw-core/src/Verifier/SAW/Unique.hs @@ -0,0 +1,21 @@ +{- | +Module : Verifier.SAW.Unique +Copyright : Galois, Inc. 2012-2015 +License : BSD3 +Maintainer : huffman@galois.com +Stability : experimental +Portability : non-portable (language extensions) +-} + +module Verifier.SAW.Unique (getUniqueInt) where + +import Data.IORef +import System.IO.Unsafe (unsafePerformIO) + +globalRef :: IORef Int +{-# NOINLINE globalRef #-} +globalRef = unsafePerformIO (newIORef 0) + +-- | Get the next unique integer, and increment the global counter +getUniqueInt :: IO Int +getUniqueInt = atomicModifyIORef' globalRef (\x -> (x+1, x)) diff --git a/saw-core/src/Verifier/SAW/UntypedAST.hs b/saw-core/src/Verifier/SAW/UntypedAST.hs new file mode 100644 index 0000000000..47134b3afc --- /dev/null +++ b/saw-core/src/Verifier/SAW/UntypedAST.hs @@ -0,0 +1,255 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +{- | +Module : Verifier.SAW.UntypedAST +Copyright : Galois, Inc. 2012-2015 +License : BSD3 +Maintainer : jhendrix@galois.com +Stability : experimental +Portability : non-portable (language extensions) +-} + +module Verifier.SAW.UntypedAST + ( Module(..) + , ModuleName, mkModuleName + , Decl(..) + , Import(..) + , ImportConstraint(..) + , nameSatsConstraint + , CtorDecl(..) + , Term(..) + , TermVar(..) + , termVarString + , termVarLocalName + , TermCtx + , asApp + , asPiList + , mkTupleValue + , mkTupleType + , mkTupleSelector + , FieldName + , Sort, mkSort, propSort, sortOf + , badTerm + , module Verifier.SAW.Position + , moduleName + , moduleTypedDecls + , moduleDataDecls + , moduleCtorDecls + , moduleTypedDataDecls + , moduleTypedCtorDecls + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>)) +#endif +import Data.Text (Text) +import qualified Data.Text as Text + +import qualified Language.Haskell.TH.Syntax as TH +import Numeric.Natural + +import Verifier.SAW.Position +import Verifier.SAW.TypedAST + ( ModuleName, mkModuleName + , Sort, mkSort, propSort, sortOf + , FieldName, DefQualifier + , LocalName + ) + +data Term + = Name (PosPair Text) + | Sort Pos Sort + | App Term Term + | Lambda Pos TermCtx Term + | Pi Pos TermCtx Term + | Recursor (Maybe ModuleName) (PosPair Text) + | UnitValue Pos + | UnitType Pos + -- | New-style records + | RecordValue Pos [(PosPair FieldName, Term)] + | RecordType Pos [(PosPair FieldName, Term)] + | RecordProj Term FieldName + -- | Simple pairs + | PairValue Pos Term Term + | PairType Pos Term Term + | PairLeft Term + | PairRight Term + -- | Identifies a type constraint on the term, i.e., a type ascription + | TypeConstraint Term Pos Term + | NatLit Pos Natural + | StringLit Pos Text + -- | Vector literal. + | VecLit Pos [Term] + | BadTerm Pos + deriving (Show, TH.Lift) + +-- | A pattern used for matching a variable. +data TermVar + = TermVar (PosPair LocalName) + | UnusedVar Pos + deriving (Eq, Ord, Show, TH.Lift) + +-- | Return the 'String' name associated with a 'TermVar' +termVarString :: TermVar -> String +termVarString (TermVar (PosPair _ str)) = Text.unpack str +termVarString (UnusedVar _) = "_" + +-- | Return the 'LocalName' associated with a 'TermVar' +termVarLocalName :: TermVar -> LocalName +termVarLocalName (TermVar (PosPair _ str)) = str +termVarLocalName (UnusedVar _) = "_" + +-- | A context of 0 or more variable bindings, with types +type TermCtx = [(TermVar,Term)] + +instance Positioned Term where + pos t = + case t of + Name i -> pos i + Sort p _ -> p + Lambda p _ _ -> p + App x _ -> pos x + Pi p _ _ -> p + Recursor _ i -> pos i + UnitValue p -> p + UnitType p -> p + RecordValue p _ -> p + RecordType p _ -> p + RecordProj x _ -> pos x + PairValue p _ _ -> p + PairType p _ _ -> p + PairLeft x -> pos x + PairRight x -> pos x + TypeConstraint _ p _ -> p + NatLit p _ -> p + StringLit p _ -> p + VecLit p _ -> p + BadTerm p -> p + +instance Positioned TermVar where + pos (TermVar i) = pos i + pos (UnusedVar p) = p + +badTerm :: Pos -> Term +badTerm = BadTerm + +-- | A constructor declaration of the form @c (x1 :: tp1) .. (xn :: tpn) :: tp@ +data CtorDecl = Ctor (PosPair Text) TermCtx Term + deriving (Show, TH.Lift) + +-- | A top-level declaration in a saw-core file +data Decl + = TypeDecl DefQualifier (PosPair Text) Term + -- ^ A declaration of something having a type, where the declaration + -- qualifier states what flavor of thing it is + | DataDecl (PosPair Text) TermCtx Term [CtorDecl] + -- ^ A declaration of an inductive data types, with a name, a parameter + -- context, a return type, and a list of constructor declarations + | TermDef (PosPair Text) [TermVar] Term + -- ^ A declaration of a term having a definition, with variables + | TypedDef (PosPair Text) [(TermVar, Term)] Term Term + -- ^ A definition of something with a specific type, with parameters + deriving (Show, TH.Lift) + +-- | A set of constraints on what 'String' names to import from a module +data ImportConstraint + = SpecificImports [String] + -- ^ Only import the given names + | HidingImports [String] + -- ^ Import all but the given names + deriving (Eq, Ord, Show, TH.Lift) + +-- | An import declaration +data Import = Import { importModName :: PosPair ModuleName + -- ^ The name of the module to import + , importConstraints :: Maybe ImportConstraint + -- ^ The constraints on what to import + } + deriving (Show, TH.Lift) + +-- | Test whether a 'String' name satisfies the constraints of an 'Import' +nameSatsConstraint :: Maybe ImportConstraint -> String -> Bool +nameSatsConstraint Nothing _ = True +nameSatsConstraint (Just (SpecificImports ns)) n = elem n ns +nameSatsConstraint (Just (HidingImports ns)) n = notElem n ns + + +-- | A module declaration gives: +-- * A name for the module; +-- * A list of imports; AND +-- * A list of top-level declarations +data Module = Module (PosPair ModuleName) [Import] [Decl] + deriving (Show, TH.Lift) + +moduleName :: Module -> ModuleName +moduleName (Module (PosPair _ mnm) _ _) = mnm + +-- | Get a list of all names (i.e., definitions, axioms, or primitives) declared +-- in a module, along with their types and qualifiers +moduleTypedDecls :: Module -> [(Text, Term)] +moduleTypedDecls (Module _ _ decls) = concatMap helper decls where + helper :: Decl -> [(Text, Term)] + helper (TypeDecl _ (PosPair _ nm) tm) = [(nm,tm)] + helper _ = [] + +-- | Get a list of all datatypes declared in a module +moduleDataDecls :: Module -> [(Text, TermCtx, Term, [CtorDecl])] +moduleDataDecls (Module _ _ decls) = concatMap helper decls where + helper :: Decl -> [(Text, TermCtx, Term, [CtorDecl])] + helper (DataDecl (PosPair _ nm) params tp ctors) = [(nm, params, tp, ctors)] + helper _ = [] + +moduleTypedDataDecls :: Module -> [(Text, Term)] +moduleTypedDataDecls = + map (\(nm,p_ctx,tp,_) -> + (nm, Pi (pos tp) p_ctx tp)) . moduleDataDecls + +-- | Get a list of all constructors declared in a module, along with the context +-- of parameters for each one +moduleCtorDecls :: Module -> [(TermCtx,CtorDecl)] +moduleCtorDecls = + concatMap (\(_,p_ctx,_,ctors) -> map (p_ctx,) ctors) . moduleDataDecls + +-- | Get a list of the names and types of all the constructors in a module +moduleTypedCtorDecls :: Module -> [(Text, Term)] +moduleTypedCtorDecls = + concatMap (\(_,p_ctx,_,ctors) -> + map (\(Ctor (PosPair _ nm) ctx tp) -> + (nm, Pi (pos tp) (p_ctx ++ ctx) tp)) ctors) + . moduleDataDecls + +asPiList :: Term -> (TermCtx,Term) +asPiList (Pi _ ctx1 body1) = + let (ctx2,body2) = asPiList body1 in + (ctx1 ++ ctx2, body2) +asPiList t = ([], t) + +asApp :: Term -> (Term,[Term]) +asApp = go [] + where go l (App t u) = go (u:l) t + go l t = (t,l) + +-- | Build a tuple value @(x1, .., xn)@. +mkTupleValue :: Pos -> [Term] -> Term +mkTupleValue p [] = UnitValue p +mkTupleValue _ [x] = x +mkTupleValue p (x:xs) = PairValue (pos x) x (mkTupleValue p xs) + +-- | Build a tuple type @#(x1, .., xn)@. +mkTupleType :: Pos -> [Term] -> Term +mkTupleType p [] = UnitType p +mkTupleType _ [x] = x +mkTupleType p (x:xs) = PairType (pos x) x (mkTupleType p xs) + +-- | Build a projection @t.i@ of a tuple. NOTE: This function does not +-- work to access the last component in a tuple, since it always +-- generates a @PairLeft@. +mkTupleSelector :: Term -> Natural -> Term +mkTupleSelector t i + | i == 1 = PairLeft t + | i > 1 = mkTupleSelector (PairRight t) (i - 1) + | otherwise = error "mkTupleSelector: non-positive index" diff --git a/saw-core/src/Verifier/SAW/Utils.hs b/saw-core/src/Verifier/SAW/Utils.hs new file mode 100644 index 0000000000..a18ef6662c --- /dev/null +++ b/saw-core/src/Verifier/SAW/Utils.hs @@ -0,0 +1,44 @@ +{- | +Module : Verifier.SAW.Utils +Copyright : Galois, Inc. 2012-2015 +License : BSD3 +Maintainer : jhendrix@galois.com +Stability : experimental +Portability : non-portable (language extensions) + +Provides utility functions about general data structured used by SAW. +Declarations here should refer primarily to terms defined in other packages. +SAW-specific declarations should be stored in separate modules. +-} + +{-# LANGUAGE Trustworthy, TemplateHaskell #-} + +module Verifier.SAW.Utils + ( internalError + , panic + , sumBy + ) where + +import Data.Foldable + +import Panic hiding (panic) +import qualified Panic as Panic + +sumBy :: (Foldable t, Num b) => (a -> b) -> t a -> b +sumBy f = foldl' fn 0 + where fn e v = e + f v + +internalError :: String -> a +internalError msg = error $ "internal: " ++ msg + +data SawCore = SawCore + +panic :: HasCallStack => String -> [String] -> a +panic = Panic.panic SawCore + +instance PanicComponent SawCore where + panicComponentName _ = "SawCore" + panicComponentIssues _ = "https://github.com/GaloisInc/saw-script/issues" + + {-# Noinline panicComponentRevision #-} + panicComponentRevision = $useGitRevision diff --git a/saw-core/tests/src/Tests.hs b/saw-core/tests/src/Tests.hs new file mode 100644 index 0000000000..367abc1e65 --- /dev/null +++ b/saw-core/tests/src/Tests.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE DoAndIfThenElse #-} + +{- | +Copyright : Galois, Inc. 2012-2015 +License : BSD3 +Maintainer : jhendrix@galois.com +Stability : experimental +Portability : non-portable (language extensions) +-} + +module Main where + +import Test.Tasty +import Test.Tasty.Options +import Test.Tasty.Ingredients +import Test.Tasty.Runners.AntXML +import Test.Tasty.QuickCheck +import Data.Proxy + +import Tests.CacheTests +import Tests.Parser +import Tests.SharedTerm +import Tests.Rewriter + +main :: IO () +main = defaultMainWithIngredients ingrs tests + +ingrs :: [Ingredient] +ingrs = + [ antXMLRunner + -- explicitly including this option keeps the test suite from failing due + -- to passing the '--quickcheck-tests' option on the command line + , includingOptions [ Option (Proxy :: Proxy QuickCheckTests) ] + ] + ++ + defaultIngredients + +tests :: TestTree +tests = + testGroup "SAWCore" + [ testGroup "SharedTerm" sharedTermTests + , testGroup "Parser" parserTests + , testGroup "Rewriter" rewriter_tests + , testGroup "Cache" cacheTests + ] diff --git a/saw-core/tests/src/Tests/CacheTests.hs b/saw-core/tests/src/Tests/CacheTests.hs new file mode 100644 index 0000000000..3539e63303 --- /dev/null +++ b/saw-core/tests/src/Tests/CacheTests.hs @@ -0,0 +1,123 @@ +{- +Copyright : Galois, Inc. 2019 +License : BSD3 +Maintainer : kquick@galois.com +Stability : experimental +Portability : portable +-} + +module Tests.CacheTests + ( cacheTests + ) +where + +import Control.Monad +import Control.Monad.ST +import Data.Ref ( C ) +import Test.Tasty +import Test.Tasty.HUnit +import Verifier.SAW.Cache + + +cacheTests :: [TestTree] +cacheTests = + [ cacheMapTestIO + , cacheMapTestST + , intMapTestIO + , intMapTestST + ] + +-- | Tests that a normal cache map can be used that will memoize +-- values in the IO monad. +cacheMapTestIO :: TestTree +cacheMapTestIO = + testGroup "normal map IO tests" + [ + testCase "String->Bool small test" $ + cTestA newCacheMap [ ("hello", True), ("world", False) ] + , testCase "String->String test" $ + cTestA newCacheMap [ ("hello", "world"), ("world", "fair"), ("Goodbye", "!") ] + , testCase "Int->Char test" $ + cTestA newCacheMap [ (9 :: Int, 'n'), (3, 't'), (-427, 'f'), (0, 'z') ] + ] + +cacheMapTestST :: TestTree +cacheMapTestST = + testGroup "normal map ST tests" + [ + testCase "String->Bool small test" $ + stToIO $ cTestA newCacheMap [ ("hello", True), ("world", False) ] + , testCase "String->String test" $ + stToIO $ cTestA newCacheMap [ ("hello", "world"), ("world", "fair"), ("Goodbye", "!") ] + , testCase "Int->Char test" $ + stToIO $ cTestA newCacheMap [ (9 :: Int, 'n'), (3, 't'), (-427, 'f'), (0, 'z') ] + ] + +-- | Tests that a normal cache map can be used that will memoize +-- values in the IO monad. +intMapTestIO :: TestTree +intMapTestIO = + testGroup "int map IO tests" + [ + testCase "intmap Bool small test" $ + cTestA newCacheIntMap [ (11, True), (0, False) ] + , testCase "intmap Int test" $ + cTestA newCacheIntMap [ (1, 0 :: Int), (0, -5), (-5, 39) ] + , testCase "intmap String test" $ + cTestA newCacheIntMap [ (1, "True"), (0, "not yet"), (-5, "negative"), (3248902, "big") ] + ] + + +-- | Tests that a normal cache map can be used that will memoize +-- values in the IO monad. +intMapTestST :: TestTree +intMapTestST = + testGroup "int map IO tests" + [ + testCase "intmap Bool small test" $ + stToIO $ cTestA newCacheIntMap [ (11, True), (0, False) ] + , testCase "intmap Int test" $ + stToIO $ cTestA newCacheIntMap [ (1, 0 :: Int), (0, -5), (-5, 39) ] + , testCase "intmap String test" $ + stToIO $ cTestA newCacheIntMap [ (1, "True"), (0, "not yet"), (-5, "negative"), (3248902, "big") ] + ] + + +-- Always pass at least 2 entries in the keyval array, keys and values should be independently unique +cTestA :: (C m, Eq k, Eq v, Show k, Show v) => + m (Cache m k v) -> [(k,v)] -> m () +cTestA mkCache keyvals = do + c1 <- mkCache -- will cache the keyvals + c2 <- mkCache -- will separately cache all keys equal to the same val (the first) + let (k0, v0) = head keyvals + let (kOmega, vOmega) = last keyvals + + -- Verify a value can be added, and once it is added, it does not + -- need to be recomputed (i.e. it is memoized) + v0' <- useCache c1 k0 (return v0) + v0'' <- useCache c1 k0 (error "should not be called") + unless (v0 == v0') $ error "initial cache store failed" + unless (v0 == v0'') $ error "cached value retrieval failed" + + vOmega' <- useCache c2 k0 (return vOmega) + vOmega'' <- useCache c2 k0 (return v0) + unless (vOmega == vOmega') $ error "second cache initial store failed" + unless (v0' /= vOmega') $ error "caches are not independent" + unless (vOmega == vOmega'') $ error "initial cache value is not persistent" + + -- Verify all the other values can similarly be cached once, and + -- that they are distinct from the initial value. + forM_ (tail keyvals) $ \(k,v) -> do + vx <- useCache c1 k (return v) + unless (v == vx) $ error "incorrect value stored" + vy <- useCache c1 k (error "must not be called for vy") + unless (v == vy) $ error "incorrect value cached" + vo <- useCache c1 k0 (error "must not be called for vo") + when (vy == vo) $ error "value collision" + vz <- useCache c1 k (error "must not be called for vz") + unless (v == vz) $ error "correct value not still cached" + v2 <- useCache c2 k (return vOmega) + unless (vOmega == v2) $ error "incorrect stored in second cache" + if k == kOmega + then unless (v2 == vz) $ error "caches can share values" + else unless (v2 /= vz) $ error "caches are independent for all keys" diff --git a/saw-core/tests/src/Tests/Parser.hs b/saw-core/tests/src/Tests/Parser.hs new file mode 100644 index 0000000000..29d9b5d439 --- /dev/null +++ b/saw-core/tests/src/Tests/Parser.hs @@ -0,0 +1,45 @@ +{- | +Copyright : Galois, Inc. 2012-2015 +License : BSD3 +Maintainer : jhendrix@galois.com +Stability : experimental +Portability : non-portable (language extensions) +-} + +module Tests.Parser where + +import Test.Tasty +import Test.Tasty.HUnit +import Verifier.SAW.Module +import Verifier.SAW.Prelude +import Verifier.SAW.SharedTerm +import Verifier.SAW.Term.Functor + + +checkGroundTerm :: Term -> Bool +checkGroundTerm t = looseVars t == emptyBitSet + +namedMsg :: Ident -> String -> String +namedMsg sym msg = "In " ++ show sym ++ ": " ++ msg + +checkDef :: Def -> Assertion +checkDef d = do + let sym = defIdent d + let tp = defType d + assertBool (namedMsg sym "Type is not ground.") (checkGroundTerm tp) + case defBody d of + Nothing -> return () + Just body -> + assertBool (namedMsg sym "Body is not ground.") (checkGroundTerm body) + +checkPrelude :: Assertion +checkPrelude = + do sc <- mkSharedContext + scLoadPreludeModule sc + modmap <- scGetModuleMap sc + mapM_ checkDef $ allModuleDefs modmap + +parserTests :: [TestTree] +parserTests = + [ testCase "preludeModule" checkPrelude + ] diff --git a/saw-core/tests/src/Tests/Rewriter.hs b/saw-core/tests/src/Tests/Rewriter.hs new file mode 100644 index 0000000000..66854f7539 --- /dev/null +++ b/saw-core/tests/src/Tests/Rewriter.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Copyright : Galois, Inc. 2012-2015 +License : BSD3 +Maintainer : jhendrix@galois.com +Stability : experimental +Portability : non-portable (language extensions) +-} + +module Tests.Rewriter + ( rewriter_tests + ) where + + +import Verifier.SAW.Conversion +import Verifier.SAW.Prelude +import Verifier.SAW.Rewriter +import Verifier.SAW.SharedTerm + +import Test.Tasty +import Test.Tasty.HUnit + +scMkTerm :: SharedContext -> TermBuilder Term -> IO Term +scMkTerm sc t = runTermBuilder t (scGlobalDef sc) (scTermF sc) + +rewriter_tests :: [TestTree] +rewriter_tests = + [ prelude_bveq_sameL_test ] + +prelude_bveq_sameL_test :: TestTree +prelude_bveq_sameL_test = + testCase "prelude_bveq_sameL_test" $ do + sc0 <- mkSharedContext + scLoadPreludeModule sc0 + let eqs = [ "Prelude.bveq_sameL" ] + ss <- scSimpset sc0 [] eqs [] + let sc = rewritingSharedContext sc0 ss + natType <- scMkTerm sc (mkDataType "Prelude.Nat" [] []) + n <- scFreshGlobal sc "n" natType + let boolType = mkDataType "Prelude.Bool" [] [] + bvType <- scMkTerm sc (mkDataType "Prelude.Vec" [] [pure n, boolType]) + x <- scFreshGlobal sc "x" bvType + z <- scFreshGlobal sc "z" bvType + let lhs = + mkGlobalDef "Prelude.bvEq" + `pureApp` n + `pureApp` x + `mkApp` (mkGlobalDef "Prelude.bvAdd" `pureApp` n `pureApp` x `pureApp` z) + let rhs = + mkGlobalDef "Prelude.bvEq" + `pureApp` n + `mkApp` (mkGlobalDef "Prelude.bvNat" `pureApp` n `mkApp` mkNatLit 0) + `pureApp` z + lhs_term <- scMkTerm sc lhs + rhs_term <- scMkTerm sc rhs + assertEqual "Incorrect conversion\n" lhs_term rhs_term diff --git a/saw-core/tests/src/Tests/SharedTerm.hs b/saw-core/tests/src/Tests/SharedTerm.hs new file mode 100644 index 0000000000..fa028a7b79 --- /dev/null +++ b/saw-core/tests/src/Tests/SharedTerm.hs @@ -0,0 +1,33 @@ +{- +Copyright : Galois, Inc. 2012-2015 +License : BSD3 +Maintainer : jhendrix@galois.com +Stability : experimental +Portability : non-portable (language extensions) +-} + +module Tests.SharedTerm + ( sharedTermTests + ) where + +import Control.Monad +import Test.Tasty +import Test.Tasty.HUnit +import Verifier.SAW.Prelude +import Verifier.SAW.SharedTerm + + +sharedTermTests :: [TestTree] +sharedTermTests = + [ preludeSharedSmokeTest + ] + +-- | Tests that a shared context for the prelude can be created, +-- along with a single term. +preludeSharedSmokeTest :: TestTree +preludeSharedSmokeTest = + testCase "preludeSharedSmokeTest" $ do + sc <- mkSharedContext + scLoadPreludeModule sc + void $ scApplyPrelude_Bool sc + return () diff --git a/saw-core/tools/extcore-info.hs b/saw-core/tools/extcore-info.hs new file mode 100644 index 0000000000..220d046f36 --- /dev/null +++ b/saw-core/tools/extcore-info.hs @@ -0,0 +1,24 @@ +{- | +Copyright : Galois, Inc. 2012-2014 +License : BSD3 +Maintainer : jhendrix@galois.com +Stability : experimental +Portability : non-portable (language extensions) +-} + +module Main where + +import System.Environment (getArgs) + +import Verifier.SAW + +processFile :: FilePath -> IO () +processFile file = do + sc <- mkSharedContext + scLoadPreludeModule sc + tm <- scReadExternal sc =<< readFile file + putStrLn $ "Shared size: " ++ show (scSharedSize tm) + putStrLn $ "Tree size: " ++ show (scTreeSize tm) + +main :: IO () +main = mapM_ processFile =<< getArgs