diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,59 @@ +# 3.4.0 -- 2025-11-07 + +## Language changes + +* When running validation commands (`:check`, `:prove`, `:exhaust`, etc.) + without an explicit argument, we now run only the properties in the + currently *focused module*. This is a change in behavior, because previously + we used to run all properties in the currently opened *file*. This change + is only noticable when working with nested modules. The new behavior works + better when these commands are used from docstrings (e.g., with the + new behavior, writing `:check` on a submodule, will only check the properties + in that submodule, as expected). + +* When running the `:check-docstrings` command, `Bit` properties (e.g. `property + p = True`) will be checked with `:exhaust`, unless their docstrings contain + code blocks understood by `:check-docstrings`. + ([#1842](https://github.com/GaloisInc/cryptol/issues/1842)) + +* `foreign` function declarations now support an optional calling convention + keyword. See the [manual + section](https://galoisinc.github.io/cryptol/master/FFI.html#calling-conventions) + for more information. + +* Add an `abstract` calling convention, where Cryptol values are marshalled + using an abstract interface. See the [manual + section](https://galoisinc.github.io/cryptol/master/FFI.html#the-abstract-calling-convention) + for more information. + +* Allow an explicit `;` separator between `case` branches. This change removes the + unreachable code in the grammar for `case` and `where` expressions with explicit + `{` and `}` that was never reachable due to the way the layout rule worked. + +* Add `w4-rme` prover. This prover works on goals using booleans and bit vectors. + It's particularly suited to problems using Galois field arithmetic. It does not + call out to an external solver. Use `:set prover = w4-rme` to enable it. + +## Bug fixes + +* Fix a discrepency between the behavior of `:check-docstrings` when run + on the REPL vs. when run with a project. + ([#1903](https://github.com/GaloisInc/cryptol/issues/1903)) + +* Fix #1696, which corrected an incorrect simplification rule, leading to + panics. + +* Allow changing the `tcSolver` setting to non-Z3 solvers (e.g., CVC5) without + crashing. ([#1874](https://github.com/GaloisInc/cryptol/issues/1874)) + +* Fix browsing of `main` modules. + crashing. ([#1874](https://github.com/GaloisInc/cryptol/issues/1857)) + +## New Features + +* New REPL command `:saw` to run SAW on a SAW file, usable in docstrings. + [#1835](https://github.com/GaloisInc/cryptol/issues/1835) + # 3.3.0 -- 2025-03-21 ## Language changes @@ -295,6 +351,9 @@ error is in the length of the sequence of field `b`. ## Bug fixes + +* Fix an issue where `:t` did not take into account module level type +parameters when pretty printing type signature (closes issue #1867). * The What4 backend now properly supports Boolector 3.2.2 or later. diff --git a/cryptol-repl-internal/REPL/Haskeline.hs b/cryptol-repl-internal/REPL/Haskeline.hs --- a/cryptol-repl-internal/REPL/Haskeline.hs +++ b/cryptol-repl-internal/REPL/Haskeline.hs @@ -23,7 +23,7 @@ import Cryptol.Utils.Ident(modNameToText, interactiveName) import qualified Control.Exception as X -import Control.Monad (guard, join) +import Control.Monad (guard, join, unless) import qualified Control.Monad.Trans.Class as MTL #if !MIN_VERSION_haskeline(0,8,0) import Control.Monad.Trans.Control @@ -153,7 +153,9 @@ InteractiveBatch _ -> True replAction = - do status <- loadCryRC cryrc + do colorOk <- canDisplayColor + unless colorOk (setDocAnnotStyle NoAnnot) + status <- loadCryRC cryrc if crSuccess status then do begin case projectConfig of diff --git a/cryptol.buildinfo.json b/cryptol.buildinfo.json new file mode 100644 --- /dev/null +++ b/cryptol.buildinfo.json @@ -0,0 +1,5 @@ +{ + "hash": null, + "branch": null, + "dirty": null +} diff --git a/cryptol.cabal b/cryptol.cabal --- a/cryptol.cabal +++ b/cryptol.cabal @@ -1,6 +1,6 @@ Cabal-version: 2.4 Name: cryptol -Version: 3.3.0 +Version: 3.4.0 Synopsis: Cryptol: The Language of Cryptography Description: Cryptol is a domain-specific language for specifying cryptographic algorithms. A Cryptol implementation of an algorithm resembles its mathematical specification more closely than an implementation in a general purpose language. For more, see . License: BSD-3-Clause @@ -13,11 +13,12 @@ Category: Language Build-type: Simple extra-source-files: bench/data/*.cry - lib/*.cry lib/*.z3 + lib/*.cry lib/*.smt2 lib/*.h + cryptol.buildinfo.json extra-doc-files: CHANGES.md -data-files: **/*.cry **/*.z3 +data-files: **/*.cry **/*.smt2 **/*.h data-dir: lib source-repository head @@ -28,7 +29,7 @@ type: git location: https://github.com/GaloisInc/cryptol.git -- add a tag on release branches - tag: 3.3.0 + tag: 3.4.0 flag static @@ -47,6 +48,7 @@ Default-language: Haskell2010 Build-depends: base >= 4.9 && < 5, + aeson >= 2.0 && < 2.3, arithmoi >= 0.12, async >= 2.2 && < 2.3, base-compat >= 0.6 && < 0.13, @@ -75,7 +77,9 @@ pretty, prettyprinter >= 1.7.0, pretty-show, + primitive, process >= 1.2, + rme-what4 ^>= 0.1, sbv >= 9.1 && < 10.11, simple-smt >= 0.9.8, stm >= 2.4, @@ -98,6 +102,7 @@ if flag(ffi) build-depends: hgmp, libffi >= 0.2 + include-dirs: lib if os(windows) build-depends: Win32 else @@ -112,6 +117,7 @@ Cryptol.Parser.Token, Cryptol.Parser.Layout, Cryptol.Parser.AST, + Cryptol.Parser.AST.Builder, Cryptol.Parser.Position, Cryptol.Parser.Names, Cryptol.Parser.Name, @@ -159,6 +165,7 @@ Cryptol.TypeCheck.TypePat, Cryptol.TypeCheck.SimpType, Cryptol.TypeCheck.AST, + Cryptol.TypeCheck.Docstrings, Cryptol.TypeCheck.Parseable, Cryptol.TypeCheck.Monad, Cryptol.TypeCheck.Infer, @@ -200,12 +207,13 @@ Cryptol.IR.FreeVars, Cryptol.IR.TraverseNames, + Cryptol.IR.Builder, + Cryptol.IR.Prove, Cryptol.Backend, Cryptol.Backend.Arch, Cryptol.Backend.Concrete, - Cryptol.Backend.FFI, - Cryptol.Backend.FFI.Error, + Cryptol.Backend.FloatHelpers, Cryptol.Backend.Monad, Cryptol.Backend.SeqMap, @@ -217,6 +225,13 @@ Cryptol.Eval.Concrete, Cryptol.Eval.Env, Cryptol.Eval.FFI, + Cryptol.Eval.FFI.ForeignSrc, + Cryptol.Eval.FFI.Error, + Cryptol.Eval.FFI.C, + Cryptol.Eval.FFI.Abstract, + Cryptol.Eval.FFI.Abstract.Call, + Cryptol.Eval.FFI.Abstract.Export, + Cryptol.Eval.FFI.Abstract.Import, Cryptol.Eval.FFI.GenHeader, Cryptol.Eval.Generic, Cryptol.Eval.Prims, diff --git a/cryptol/Main.hs b/cryptol/Main.hs --- a/cryptol/Main.hs +++ b/cryptol/Main.hs @@ -221,6 +221,10 @@ , "addition to the default locations" ] ) + , ( "CRYPTOL_SAW" + , [ "Sets the command to use when running SAW via the `:saw` command" + ] + ) , ( "EDITOR" , [ "Sets the editor executable to use when opening an editor" , "via the `:edit` command" diff --git a/lib/CryptolTC.smt2 b/lib/CryptolTC.smt2 new file mode 100644 --- /dev/null +++ b/lib/CryptolTC.smt2 @@ -0,0 +1,358 @@ +; ------------------------------------------------------------------------------ +; Basic datatypes + +(declare-datatypes ((InfNat 0)) + ( ((mk-infnat (value Int) (isFin Bool) (isErr Bool))) + ) +) + +(declare-datatypes ((MaybeBool 0)) + ( ((mk-mb (prop Bool) (isErrorProp Bool))) + ) +) + +(define-fun cryBool ((x Bool)) MaybeBool + (mk-mb x false) +) + +(define-fun cryErrProp () MaybeBool + (mk-mb false true) +) + +(define-fun cryInf () InfNat + (mk-infnat 0 false false) +) + +(define-fun cryNat ((x Int)) InfNat + (mk-infnat x true false) +) + +(define-fun cryErr () InfNat + (mk-infnat 0 false true) +) + +; ------------------------------------------------------------------------------ +; Cryptol version of logic + + +(define-fun cryEq ((x InfNat) (y InfNat)) MaybeBool + (ite (or (isErr x) (isErr y)) cryErrProp (cryBool + (ite (isFin x) + (ite (isFin y) (= (value x) (value y)) false) + (not (isFin y)) + ))) +) + +(define-fun cryNeq ((x InfNat) (y InfNat)) MaybeBool + (ite (or (isErr x) (isErr y)) cryErrProp (cryBool + (ite (isFin x) + (ite (isFin y) (not (= (value x) (value y))) true) + (isFin y) + ))) +) + +(define-fun cryFin ((x InfNat)) MaybeBool + (ite (isErr x) cryErrProp (cryBool + (isFin x))) +) + +(define-fun cryGeq ((x InfNat) (y InfNat)) MaybeBool + (ite (or (isErr x) (isErr y)) cryErrProp (cryBool + (ite (isFin x) + (ite (isFin y) (>= (value x) (value y)) false) + true + ))) +) + +(define-fun cryAnd ((x MaybeBool) (y MaybeBool)) MaybeBool + (ite (or (isErrorProp x) (isErrorProp y)) cryErrProp + (cryBool (and (prop x) (prop y))) + ) +) + + +(define-fun cryTrue () MaybeBool + (cryBool true) +) + + +(declare-fun cryPrimeUnknown (Int) Bool) + +(define-fun cryPrime ((x InfNat)) MaybeBool + (ite (isErr x) cryErrProp + (cryBool (and (isFin x) (cryPrimeUnknown (value x))))) +) + + +; ------------------------------------------------------------------------------ +; Basic Cryptol assume/assert + + +(define-fun cryVar ((x InfNat)) Bool + (and (not (isErr x)) (>= (value x) 0)) +) + +(define-fun cryAssume ((x MaybeBool)) Bool + (ite (isErrorProp x) true (prop x)) +) + +(declare-fun cryUnknown () Bool) + +(define-fun cryProve ((x MaybeBool)) Bool + (ite (isErrorProp x) cryUnknown (not (prop x))) +) + + + +; ------------------------------------------------------------------------------ +; Arithmetic + + +(define-fun cryAdd ((x InfNat) (y InfNat)) InfNat + (ite (or (isErr x) (isErr y)) cryErr + (ite (isFin x) + (ite (isFin y) (cryNat (+ (value x) (value y))) cryInf) + cryInf + )) +) + +(define-fun crySub ((x InfNat) (y InfNat)) InfNat + (ite (or (isErr x) (isErr y) (not (isFin y))) cryErr + (ite (isFin x) + (ite (>= (value x) (value y)) (cryNat (- (value x) (value y))) cryErr) + cryInf + )) +) + +(define-fun cryMul ((x InfNat) (y InfNat)) InfNat + (ite (or (isErr x) (isErr y)) cryErr + (ite (isFin x) + (ite (isFin y) (cryNat (* (value x) (value y))) + (ite (= (value x) 0) (cryNat 0) cryInf)) + (ite (and (isFin y) (= (value y) 0)) (cryNat 0) cryInf) + )) +) + +(define-fun cryDiv ((x InfNat) (y InfNat)) InfNat + (ite (or (isErr x) (isErr y) (not (isFin x))) cryErr + (ite (isFin y) + (ite (= (value y) 0) cryErr (cryNat (div (value x) (value y)))) + (cryNat 0) + )) +) + +(define-fun cryMod ((x InfNat) (y InfNat)) InfNat + (ite (or (isErr x) (isErr y) (not (isFin x))) cryErr + (ite (isFin y) + (ite (= (value y) 0) cryErr (cryNat (mod (value x) (value y)))) + x + )) +) + + + +(define-fun cryMin ((x InfNat) (y InfNat)) InfNat + (ite (or (isErr x) (isErr y)) cryErr + (ite (isFin x) + (ite (isFin y) + (ite (<= (value x) (value y)) x y) + x) + y + )) +) + +(define-fun cryMax ((x InfNat) (y InfNat)) InfNat + (ite (or (isErr x) (isErr y)) cryErr + (ite (isFin x) + (ite (isFin y) + (ite (<= (value x) (value y)) y x) + y) + x + )) +) + + +(declare-fun cryWidthUnknown (Int) Int) + +; Some axioms about cryWidthUnknown +(define-fun k_2_to_64 () Int 18446744073709551616) +(define-fun k_2_to_65 () Int 36893488147419103232) + +(assert (forall ((x Int)) (or (> (cryWidthUnknown x) 64) (< x k_2_to_64)))) +(assert (forall ((x Int)) (or (> x (cryWidthUnknown x)) (< x k_2_to_64)))) + +; This helps the #548 property +(assert (forall ((x Int)) (or (>= 65 (cryWidthUnknown x)) (>= x k_2_to_65)))) + + +(assert (forall ((x Int) (y Int)) + (=> (>= x y) + (>= (cryWidthUnknown x) (cryWidthUnknown y))))) + + +; this helps #548. It seems to be quite slow, however. +; (assert (forall ((x Int) (y Int)) +; (=> +; (> y (cryWidthUnknown x)) +; (>= y (cryWidthUnknown (* 2 x))) +; ) +; )) + + + +(define-fun cryWidthTable ((x Int)) Int + (ite (< x 1) 0 + (ite (< x 2) 1 + (ite (< x 4) 2 + (ite (< x 8) 3 + (ite (< x 16) 4 + (ite (< x 32) 5 + (ite (< x 64) 6 + (ite (< x 128) 7 + (ite (< x 256) 8 + (ite (< x 512) 9 + (ite (< x 1024) 10 + (ite (< x 2048) 11 + (ite (< x 4096) 12 + (ite (< x 8192) 13 + (ite (< x 16384) 14 + (ite (< x 32768) 15 + (ite (< x 65536) 16 + (ite (< x 131072) 17 + (ite (< x 262144) 18 + (ite (< x 524288) 19 + (ite (< x 1048576) 20 + (ite (< x 2097152) 21 + (ite (< x 4194304) 22 + (ite (< x 8388608) 23 + (ite (< x 16777216) 24 + (ite (< x 33554432) 25 + (ite (< x 67108864) 26 + (ite (< x 134217728) 27 + (ite (< x 268435456) 28 + (ite (< x 536870912) 29 + (ite (< x 1073741824) 30 + (ite (< x 2147483648) 31 + (ite (< x 4294967296) 32 + (ite (< x 8589934592) 33 + (ite (< x 17179869184) 34 + (ite (< x 34359738368) 35 + (ite (< x 68719476736) 36 + (ite (< x 137438953472) 37 + (ite (< x 274877906944) 38 + (ite (< x 549755813888) 39 + (ite (< x 1099511627776) 40 + (ite (< x 2199023255552) 41 + (ite (< x 4398046511104) 42 + (ite (< x 8796093022208) 43 + (ite (< x 17592186044416) 44 + (ite (< x 35184372088832) 45 + (ite (< x 70368744177664) 46 + (ite (< x 140737488355328) 47 + (ite (< x 281474976710656) 48 + (ite (< x 562949953421312) 49 + (ite (< x 1125899906842624) 50 + (ite (< x 2251799813685248) 51 + (ite (< x 4503599627370496) 52 + (ite (< x 9007199254740992) 53 + (ite (< x 18014398509481984) 54 + (ite (< x 36028797018963968) 55 + (ite (< x 72057594037927936) 56 + (ite (< x 144115188075855872) 57 + (ite (< x 288230376151711744) 58 + (ite (< x 576460752303423488) 59 + (ite (< x 1152921504606846976) 60 + (ite (< x 2305843009213693952) 61 + (ite (< x 4611686018427387904) 62 + (ite (< x 9223372036854775808) 63 + (ite (< x 18446744073709551616) 64 + (cryWidthUnknown x)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) +) + +(define-fun cryWidth ((x InfNat)) InfNat + (ite (isErr x) cryErr + (ite (isFin x) (cryNat (cryWidthTable (value x))) + cryInf + )) +) + +(declare-fun cryExpUnknown (Int Int) Int) + +(assert (forall ((x Int) (y Int)) + (=> (and (> y 0) (> x 0)) + (>= (cryExpUnknown x y) x)))) + +(define-fun cryExpTable ((x Int) (y Int)) Int + (ite (= y 0) 1 + (ite (= y 1) x + (ite (= x 0) 0 + (cryExpUnknown x y)))) +) + +(define-fun cryExp ((x InfNat) (y InfNat)) InfNat + (ite (or (isErr x) (isErr y)) cryErr + (ite (isFin x) + (ite (isFin y) + (cryNat (cryExpTable (value x) (value y))) + (ite (< (value x) 2) x cryInf)) + (ite (isFin y) + (ite (= (value y) 0) (cryNat 1) cryInf) + cryInf) + )) +) + +(define-fun cryCeilDiv ((x InfNat) (y InfNat)) InfNat + (ite (or (isErr x) (isErr y) (not (isFin y))) cryErr + (ite (= (value y) 0) cryErr + (ite (not (isFin x)) cryInf + (cryNat (- (div (- (value x)) (value y)))) + ))) +) + +(define-fun cryCeilMod ((x InfNat) (y InfNat)) InfNat + (ite (or (isErr x) (isErr y) (not (isFin y))) cryErr + (ite (= (value y) 0) cryErr + (ite (not (isFin x)) (cryNat 0) + (cryNat (mod (- (value x)) (value y))) + ))) +) + +(define-fun cryLenFromThenTo ((x InfNat) (y InfNat) (z InfNat)) InfNat + (ite (or (isErr x) (not (isFin x)) + (isErr y) (not (isFin y)) + (isErr z) (not (isFin z)) + (= (value x) (value y))) cryErr (cryNat + (ite (> (value x) (value y)) + (ite (> (value z) (value x)) 0 (+ (div (- (value x) (value z)) + (- (value x) (value y))) 1)) + (ite (< (value z) (value x)) 0 (+ (div (- (value z) (value x)) + (- (value y) (value x))) 1)) + ))) +) + + +; --- + + +; (declare-fun L () InfNat) +; (declare-fun w () InfNat) +; +; (assert (cryVar L)) +; (assert (cryVar w)) +; +; (assert (cryAssume (cryFin w))) +; (assert (cryAssume (cryGeq w (cryNat 1)))) +; (assert (cryAssume (cryGeq (cryMul (cryNat 2) w) (cryWidth L)))) +; +; (assert (cryProve +; (cryGeq +; (cryMul +; (cryCeilDiv +; (cryAdd (cryNat 1) (cryAdd L (cryMul (cryNat 2) w))) +; (cryMul (cryNat 16) w)) +; (cryMul (cryNat 16) w)) +; (cryAdd (cryNat 1) (cryAdd L (cryMul (cryNat 2) w)))))) +; +; (check-sat) + + diff --git a/lib/CryptolTC.z3 b/lib/CryptolTC.z3 deleted file mode 100644 --- a/lib/CryptolTC.z3 +++ /dev/null @@ -1,358 +0,0 @@ -; ------------------------------------------------------------------------------ -; Basic datatypes - -(declare-datatypes () - ( (InfNat (mk-infnat (value Int) (isFin Bool) (isErr Bool))) - ) -) - -(declare-datatypes () - ( (MaybeBool (mk-mb (prop Bool) (isErrorProp Bool))) - ) -) - -(define-fun cryBool ((x Bool)) MaybeBool - (mk-mb x false) -) - -(define-fun cryErrProp () MaybeBool - (mk-mb false true) -) - -(define-fun cryInf () InfNat - (mk-infnat 0 false false) -) - -(define-fun cryNat ((x Int)) InfNat - (mk-infnat x true false) -) - -(define-fun cryErr () InfNat - (mk-infnat 0 false true) -) - -; ------------------------------------------------------------------------------ -; Cryptol version of logic - - -(define-fun cryEq ((x InfNat) (y InfNat)) MaybeBool - (ite (or (isErr x) (isErr y)) cryErrProp (cryBool - (ite (isFin x) - (ite (isFin y) (= (value x) (value y)) false) - (not (isFin y)) - ))) -) - -(define-fun cryNeq ((x InfNat) (y InfNat)) MaybeBool - (ite (or (isErr x) (isErr y)) cryErrProp (cryBool - (ite (isFin x) - (ite (isFin y) (not (= (value x) (value y))) true) - (isFin y) - ))) -) - -(define-fun cryFin ((x InfNat)) MaybeBool - (ite (isErr x) cryErrProp (cryBool - (isFin x))) -) - -(define-fun cryGeq ((x InfNat) (y InfNat)) MaybeBool - (ite (or (isErr x) (isErr y)) cryErrProp (cryBool - (ite (isFin x) - (ite (isFin y) (>= (value x) (value y)) false) - true - ))) -) - -(define-fun cryAnd ((x MaybeBool) (y MaybeBool)) MaybeBool - (ite (or (isErrorProp x) (isErrorProp y)) cryErrProp - (cryBool (and (prop x) (prop y))) - ) -) - - -(define-fun cryTrue () MaybeBool - (cryBool true) -) - - -(declare-fun cryPrimeUnknown (Int) Bool) - -(define-fun cryPrime ((x InfNat)) MaybeBool - (ite (isErr x) cryErrProp - (cryBool (and (isFin x) (cryPrimeUnknown (value x))))) -) - - -; ------------------------------------------------------------------------------ -; Basic Cryptol assume/assert - - -(define-fun cryVar ((x InfNat)) Bool - (and (not (isErr x)) (>= (value x) 0)) -) - -(define-fun cryAssume ((x MaybeBool)) Bool - (ite (isErrorProp x) true (prop x)) -) - -(declare-fun cryUnknown () Bool) - -(define-fun cryProve ((x MaybeBool)) Bool - (ite (isErrorProp x) cryUnknown (not (prop x))) -) - - - -; ------------------------------------------------------------------------------ -; Arithmetic - - -(define-fun cryAdd ((x InfNat) (y InfNat)) InfNat - (ite (or (isErr x) (isErr y)) cryErr - (ite (isFin x) - (ite (isFin y) (cryNat (+ (value x) (value y))) cryInf) - cryInf - )) -) - -(define-fun crySub ((x InfNat) (y InfNat)) InfNat - (ite (or (isErr x) (isErr y) (not (isFin y))) cryErr - (ite (isFin x) - (ite (>= (value x) (value y)) (cryNat (- (value x) (value y))) cryErr) - cryInf - )) -) - -(define-fun cryMul ((x InfNat) (y InfNat)) InfNat - (ite (or (isErr x) (isErr y)) cryErr - (ite (isFin x) - (ite (isFin y) (cryNat (* (value x) (value y))) - (ite (= (value x) 0) (cryNat 0) cryInf)) - (ite (and (isFin y) (= (value y) 0)) (cryNat 0) cryInf) - )) -) - -(define-fun cryDiv ((x InfNat) (y InfNat)) InfNat - (ite (or (isErr x) (isErr y) (not (isFin x))) cryErr - (ite (isFin y) - (ite (= (value y) 0) cryErr (cryNat (div (value x) (value y)))) - (cryNat 0) - )) -) - -(define-fun cryMod ((x InfNat) (y InfNat)) InfNat - (ite (or (isErr x) (isErr y) (not (isFin x))) cryErr - (ite (isFin y) - (ite (= (value y) 0) cryErr (cryNat (mod (value x) (value y)))) - x - )) -) - - - -(define-fun cryMin ((x InfNat) (y InfNat)) InfNat - (ite (or (isErr x) (isErr y)) cryErr - (ite (isFin x) - (ite (isFin y) - (ite (<= (value x) (value y)) x y) - x) - y - )) -) - -(define-fun cryMax ((x InfNat) (y InfNat)) InfNat - (ite (or (isErr x) (isErr y)) cryErr - (ite (isFin x) - (ite (isFin y) - (ite (<= (value x) (value y)) y x) - y) - x - )) -) - - -(declare-fun cryWidthUnknown (Int) Int) - -; Some axioms about cryWidthUnknown -(define-fun k_2_to_64 () Int 18446744073709551616) -(define-fun k_2_to_65 () Int 36893488147419103232) - -(assert (forall ((x Int)) (or (> (cryWidthUnknown x) 64) (< x k_2_to_64)))) -(assert (forall ((x Int)) (or (> x (cryWidthUnknown x)) (< x k_2_to_64)))) - -; This helps the #548 property -(assert (forall ((x Int)) (or (>= 65 (cryWidthUnknown x)) (>= x k_2_to_65)))) - - -(assert (forall ((x Int) (y Int)) - (=> (>= x y) - (>= (cryWidthUnknown x) (cryWidthUnknown y))))) - - -; this helps #548. It seems to be quite slow, however. -; (assert (forall ((x Int) (y Int)) -; (=> -; (> y (cryWidthUnknown x)) -; (>= y (cryWidthUnknown (* 2 x))) -; ) -; )) - - - -(define-fun cryWidthTable ((x Int)) Int - (ite (< x 1) 0 - (ite (< x 2) 1 - (ite (< x 4) 2 - (ite (< x 8) 3 - (ite (< x 16) 4 - (ite (< x 32) 5 - (ite (< x 64) 6 - (ite (< x 128) 7 - (ite (< x 256) 8 - (ite (< x 512) 9 - (ite (< x 1024) 10 - (ite (< x 2048) 11 - (ite (< x 4096) 12 - (ite (< x 8192) 13 - (ite (< x 16384) 14 - (ite (< x 32768) 15 - (ite (< x 65536) 16 - (ite (< x 131072) 17 - (ite (< x 262144) 18 - (ite (< x 524288) 19 - (ite (< x 1048576) 20 - (ite (< x 2097152) 21 - (ite (< x 4194304) 22 - (ite (< x 8388608) 23 - (ite (< x 16777216) 24 - (ite (< x 33554432) 25 - (ite (< x 67108864) 26 - (ite (< x 134217728) 27 - (ite (< x 268435456) 28 - (ite (< x 536870912) 29 - (ite (< x 1073741824) 30 - (ite (< x 2147483648) 31 - (ite (< x 4294967296) 32 - (ite (< x 8589934592) 33 - (ite (< x 17179869184) 34 - (ite (< x 34359738368) 35 - (ite (< x 68719476736) 36 - (ite (< x 137438953472) 37 - (ite (< x 274877906944) 38 - (ite (< x 549755813888) 39 - (ite (< x 1099511627776) 40 - (ite (< x 2199023255552) 41 - (ite (< x 4398046511104) 42 - (ite (< x 8796093022208) 43 - (ite (< x 17592186044416) 44 - (ite (< x 35184372088832) 45 - (ite (< x 70368744177664) 46 - (ite (< x 140737488355328) 47 - (ite (< x 281474976710656) 48 - (ite (< x 562949953421312) 49 - (ite (< x 1125899906842624) 50 - (ite (< x 2251799813685248) 51 - (ite (< x 4503599627370496) 52 - (ite (< x 9007199254740992) 53 - (ite (< x 18014398509481984) 54 - (ite (< x 36028797018963968) 55 - (ite (< x 72057594037927936) 56 - (ite (< x 144115188075855872) 57 - (ite (< x 288230376151711744) 58 - (ite (< x 576460752303423488) 59 - (ite (< x 1152921504606846976) 60 - (ite (< x 2305843009213693952) 61 - (ite (< x 4611686018427387904) 62 - (ite (< x 9223372036854775808) 63 - (ite (< x 18446744073709551616) 64 - (cryWidthUnknown x)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) -) - -(define-fun cryWidth ((x InfNat)) InfNat - (ite (isErr x) cryErr - (ite (isFin x) (cryNat (cryWidthTable (value x))) - cryInf - )) -) - -(declare-fun cryExpUnknown (Int Int) Int) - -(assert (forall ((x Int) (y Int)) - (=> (and (> y 0) (> x 0)) - (>= (cryExpUnknown x y) x)))) - -(define-fun cryExpTable ((x Int) (y Int)) Int - (ite (= y 0) 1 - (ite (= y 1) x - (ite (= x 0) 0 - (cryExpUnknown x y)))) -) - -(define-fun cryExp ((x InfNat) (y InfNat)) InfNat - (ite (or (isErr x) (isErr y)) cryErr - (ite (isFin x) - (ite (isFin y) - (cryNat (cryExpTable (value x) (value y))) - (ite (< (value x) 2) x cryInf)) - (ite (isFin y) - (ite (= (value y) 0) (cryNat 1) cryInf) - cryInf) - )) -) - -(define-fun cryCeilDiv ((x InfNat) (y InfNat)) InfNat - (ite (or (isErr x) (isErr y) (not (isFin y))) cryErr - (ite (= (value y) 0) cryErr - (ite (not (isFin x)) cryInf - (cryNat (- (div (- (value x)) (value y)))) - ))) -) - -(define-fun cryCeilMod ((x InfNat) (y InfNat)) InfNat - (ite (or (isErr x) (isErr y) (not (isFin y))) cryErr - (ite (= (value y) 0) cryErr - (ite (not (isFin x)) (cryNat 0) - (cryNat (mod (- (value x)) (value y))) - ))) -) - -(define-fun cryLenFromThenTo ((x InfNat) (y InfNat) (z InfNat)) InfNat - (ite (or (isErr x) (not (isFin x)) - (isErr y) (not (isFin y)) - (isErr z) (not (isFin z)) - (= (value x) (value y))) cryErr (cryNat - (ite (> (value x) (value y)) - (ite (> (value z) (value x)) 0 (+ (div (- (value x) (value z)) - (- (value x) (value y))) 1)) - (ite (< (value z) (value x)) 0 (+ (div (- (value z) (value x)) - (- (value y) (value x))) 1)) - ))) -) - - -; --- - - -; (declare-fun L () InfNat) -; (declare-fun w () InfNat) -; -; (assert (cryVar L)) -; (assert (cryVar w)) -; -; (assert (cryAssume (cryFin w))) -; (assert (cryAssume (cryGeq w (cryNat 1)))) -; (assert (cryAssume (cryGeq (cryMul (cryNat 2) w) (cryWidth L)))) -; -; (assert (cryProve -; (cryGeq -; (cryMul -; (cryCeilDiv -; (cryAdd (cryNat 1) (cryAdd L (cryMul (cryNat 2) w))) -; (cryMul (cryNat 16) w)) -; (cryMul (cryNat 16) w)) -; (cryAdd (cryNat 1) (cryAdd L (cryMul (cryNat 2) w)))))) -; -; (check-sat) - - diff --git a/lib/cry_ffi.h b/lib/cry_ffi.h new file mode 100644 --- /dev/null +++ b/lib/cry_ffi.h @@ -0,0 +1,169 @@ +#pragma once + +#include +#include + +// A convenince macro to call a method on an object. +#define CRY_FFI(obj, f, args...) ((obj)->f((obj)->self, args)) + +/** Imports foreign values into Cryptol. +This should be used when a foreign function needs to return a result +to the Cryptol interpreter. Cryptol values are imported as follows: + + Bit: + send_bool(value); + + Float32, Float64: + send_double(value); + + Integer, Z: + uint64_t* digits = send_new_large_int(size); + // write value into `digits` + send_sign(sign); + + [n] + | n <= 64 send_small_uint(value) or + send_small_sint(value) + | otherwise send Integer (as above) + (like receiving an Integer, but without a sign) + + [n] a + send `n` values of type `a` + + Rational: + send 2 Integers (as above): 1st is numerator, 2nd denominator. + + Tagged sum: + send_tag(&tag); send fields based on the tag; + The constructor number corresponds to the order of the declaration. + + Tuple, record, newtype: + send the elements one after the other. + The fields of records and newtypes are sent in alphabetical order. +*/ +struct CryValImporter { + /** This should be passed to all the function pointers. + It captures the current state of the importing process. + */ + void* self; + + /** Make a boolean value: 0: false, > 0: true. + This is used to send Bit values. + */ + void (*send_bool)(void*, uint8_t); + + /** Make a small unsigned integer, which fits in an uint64_t. + This is used to send words [n] (n <= 64). + */ + void (*send_small_uint)(void*, uint64_t); + + /** Make a small signed integer, which fits in an int64_t. + This is used to send words [n] (n <= 64). + */ + void (*send_small_sint)(void*, int64_t); + + /** Make a floating point value. + This is used to send Float32 and Float64 values. + */ + void (*send_double)(void*, double); + + /** Start building a sum type. + The size_t argument is the number of the constructor. + */ + void (*send_tag)(void*, size_t); + + /** Start building an Integer, a Z value, or a large word [n] (n > 64). + The size argument is the number of uint64_t digits we need. + The result is a buffer where the digits should be placed, + least significant first. + */ + uint64_t* (*send_new_large_int)(void*, size_t); + + /** Finish bulding an Integer, a Z value, or a large word [n] (n > 64). + The sign argument is 1 for negative, and 0 for non-negative. + */ + void (*send_sign)(void*, uint8_t); +}; + + +/** Exports Cryptol values into a foreign environment. +This should be used to get a foreign function's arguments from the +Cryptol interpreter. Cryptol values are exported as follows: + + Bit: + recv_u8(&value); + + Float32, Float64: + recv_double(&value); + + Integer, Z: + recv_u8(&sign); recv_u64(&size); recv_u64_digits(value); + + numeric type parameter: + recv_u64(&value); + if (value == (maxBound :: uint64_t)) then receive an Integer (as above). + + [n] + | n <= 8 recv_u8(&value) + | 8 < n && n <= 64 recv_u64(&value) + | otherwise recv_u64(&size); recv_u64_digits(value); + (like receiving an Integer, but without a sign) + + [n] a + receive `n` values of type `a` + + Rational: + receive 2 Integers (as above): 1st is numerator, 2nd denominator. + + Tagged sum: + recv_u64(&tag); receive fields based on the tag; + The constructor number corresponds to the order of the declaration. + + Tuple, record, newtype: + Receive the elements one after the other. + The fields of records and newtypes are received in alphabetical order. +*/ +struct CryValExporter { + /** This should be passed to all function pointers. + It captures the current state of the exporting process. + */ + void *self; + + /** Get a uint8_t. This is used to receive: + + * The value of a Bit + * The value of a small words [n] (n <= 8) + * The sign of an Integer or Z value + + Returns 0 on success. + */ + uint32_t (*recv_u8)(void*, uint8_t*); + + /** Get a double. This is used to receive the value of a Float32 or Float64. + + Returns 0 on success. + */ + uint32_t (*recv_double)(void*, double*); + + /* Get a uint64_t. This is used to receive: + + * The value of a small numeric type parameter + * The value of a word [n] (8 < n && n <= 64) + * The size of an Integer or Z value + * The size of a large numeric type parameter + * The tag of a sum type + + Returns 0 on success. + */ + uint32_t (*recv_u64)(void*, uint64_t*); + + /** Receive the uint64_t digits of an Integer, a Z value, a large numeric type + parameter, or a large word [n] (n > 64). These are placed in the provided + buffer, starting with the least significant one. The buffer should be big + enough to fit the digits. + + Returns 0 on success. + */ + uint32_t (*recv_u64_digits)(void*, uint64_t*); +}; + diff --git a/src/Cryptol/Backend/FFI.hs b/src/Cryptol/Backend/FFI.hs deleted file mode 100644 --- a/src/Cryptol/Backend/FFI.hs +++ /dev/null @@ -1,284 +0,0 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} - --- | The implementation of loading and calling external functions from shared --- libraries. -module Cryptol.Backend.FFI - ( ForeignSrc - , getForeignSrcPath - , loadForeignSrc - , unloadForeignSrc - , foreignLibPath -#ifdef FFI_ENABLED - , ForeignImpl - , loadForeignImpl - , FFIArg - , FFIRet - , SomeFFIArg (..) - , callForeignImpl -#endif - ) - where - -import Control.DeepSeq - -import Cryptol.Backend.FFI.Error - -#ifdef FFI_ENABLED - -import Control.Concurrent.MVar -import Control.Exception -import Control.Monad -import Data.Bifunctor -import Data.Maybe -import Data.Word -import Foreign hiding (newForeignPtr) -import Foreign.C.Types -import Foreign.Concurrent -import Foreign.LibFFI -import System.Directory (canonicalizePath, doesFileExist) -import System.FilePath ((-<.>)) -import System.Info (os) -import System.IO.Error - -#if defined(mingw32_HOST_OS) -import System.Win32.DLL -#else -import System.Posix.DynamicLinker -#endif - -import Cryptol.Utils.Panic - -#else - -import GHC.Generics - -#endif - -#ifdef FFI_ENABLED - --- | A source from which we can retrieve implementations of foreign functions. -data ForeignSrc = ForeignSrc - { -- | The file path of the 'ForeignSrc'. - foreignSrcPath :: FilePath - -- | The 'ForeignPtr' wraps the pointer returned by 'dlopen', where the - -- finalizer calls 'dlclose' when the library is no longer needed. We keep - -- references to the 'ForeignPtr' in each foreign function that is in the - -- evaluation environment, so that the shared library will stay open as long - -- as there are references to it. - , foreignSrcFPtr :: ForeignPtr () - -- | We support explicit unloading of the shared library so we keep track of - -- if it has already been unloaded, and if so the finalizer does nothing. - -- This is updated atomically when the library is unloaded. - , foreignSrcLoaded :: MVar Bool } - -instance Show ForeignSrc where - show = show . foreignSrcFPtr - -instance NFData ForeignSrc where - rnf ForeignSrc {..} = foreignSrcFPtr `seq` foreignSrcLoaded `deepseq` () - --- | Get the file path of the 'ForeignSrc'. -getForeignSrcPath :: ForeignSrc -> Maybe FilePath -getForeignSrcPath = Just . foreignSrcPath - --- | Load a 'ForeignSrc' for the given __Cryptol__ file path. The file path of --- the shared library that we try to load is the same as the Cryptol file path --- except with a platform specific extension. -loadForeignSrc :: FilePath -> IO (Either FFILoadError ForeignSrc) -loadForeignSrc = loadForeignLib >=> traverse \(foreignSrcPath, ptr) -> do - foreignSrcLoaded <- newMVar True - foreignSrcFPtr <- newForeignPtr ptr (unloadForeignSrc' foreignSrcLoaded ptr) - pure ForeignSrc {..} - - --- | Given the path to a Cryptol module, compute the location of the shared --- library we'd like to load. If FFI is supported, returns the location and --- whether or not it actually exists on disk. Otherwise, returns Nothing. -foreignLibPath :: FilePath -> IO (Maybe (FilePath, Bool)) -foreignLibPath path = do - path' <- canonicalizePath path - let libPaths = map (path' -<.>) exts - search ps = - case ps of - [] -> pure ((, False) <$> listToMaybe libPaths) - p : more -> do - yes <- doesFileExist p - if yes then pure (Just (p, True)) else search more - search libPaths - where - exts = - case os of - "mingw32" -> ["dll"] - "darwin" -> ["dylib","so"] - _ -> ["so"] - -loadForeignLib :: FilePath -> IO (Either FFILoadError (FilePath, Ptr ())) -loadForeignLib path = - do mb <- foreignLibPath path - case mb of - Just (libPath, True) -> - tryLoad (CantLoadFFISrc path) (open libPath) - _ -> - pure (Left (CantLoadFFISrc path "File not found")) - - where open libPath = do -#if defined(mingw32_HOST_OS) - ptr <- loadLibrary libPath -#else - -- RTLD_NOW so we can make sure that the symbols actually exist at - -- module loading time - ptr <- undl <$> dlopen libPath [RTLD_NOW] -#endif - pure (libPath, ptr) - --- | Explicitly unload a 'ForeignSrc' immediately instead of waiting for the --- garbage collector to do it. This can be useful if you want to immediately --- load the same library again to pick up new changes. --- --- The 'ForeignSrc' __must not__ be used in any way after this is called, --- including calling 'ForeignImpl's loaded from it. -unloadForeignSrc :: ForeignSrc -> IO () -unloadForeignSrc ForeignSrc {..} = withForeignPtr foreignSrcFPtr $ - unloadForeignSrc' foreignSrcLoaded - -unloadForeignSrc' :: MVar Bool -> Ptr () -> IO () -unloadForeignSrc' loaded lib = modifyMVar_ loaded \l -> do - when l $ unloadForeignLib lib - pure False - -unloadForeignLib :: Ptr () -> IO () -#if defined(mingw32_HOST_OS) -unloadForeignLib = freeLibrary -#else -unloadForeignLib = dlclose . DLHandle -#endif - -withForeignSrc :: ForeignSrc -> (Ptr () -> IO a) -> IO a -withForeignSrc ForeignSrc {..} f = withMVar foreignSrcLoaded - \case - True -> withForeignPtr foreignSrcFPtr f - False -> - panic "[FFI] withForeignSrc" ["Use of foreign library after unload"] - --- | An implementation of a foreign function. -data ForeignImpl = ForeignImpl - { foreignImplFun :: FunPtr () - -- | We don't need this to call the function but we want to keep the library - -- around as long as we still have a function from it so that it isn't - -- unloaded too early. - , foreignImplSrc :: ForeignSrc - } - --- | Load a 'ForeignImpl' with the given name from the given 'ForeignSrc'. -loadForeignImpl :: ForeignSrc -> String -> IO (Either FFILoadError ForeignImpl) -loadForeignImpl foreignImplSrc name = - withForeignSrc foreignImplSrc \lib -> - tryLoad (CantLoadFFIImpl name) do - foreignImplFun <- loadForeignFunPtr lib name - pure ForeignImpl {..} - -loadForeignFunPtr :: Ptr () -> String -> IO (FunPtr ()) -#if defined(mingw32_HOST_OS) -loadForeignFunPtr source symbol = do - addr <- getProcAddress source symbol - pure $ castPtrToFunPtr addr -#else -loadForeignFunPtr = dlsym . DLHandle -#endif - -tryLoad :: (String -> FFILoadError) -> IO a -> IO (Either FFILoadError a) -tryLoad err = fmap (first $ err . displayException) . tryIOError - --- | Types which can be converted into libffi arguments. --- --- The Storable constraint is so that we can put them in arrays. -class Storable a => FFIArg a where - ffiArg :: a -> Arg - -instance FFIArg Word8 where - ffiArg = argWord8 - -instance FFIArg Word16 where - ffiArg = argWord16 - -instance FFIArg Word32 where - ffiArg = argWord32 - -instance FFIArg Word64 where - ffiArg = argWord64 - -instance FFIArg CFloat where - ffiArg = argCFloat - -instance FFIArg CDouble where - ffiArg = argCDouble - -instance FFIArg (Ptr a) where - ffiArg = argPtr - -instance FFIArg CSize where - ffiArg = argCSize - --- | Types which can be returned from libffi. --- --- The Storable constraint is so that we can put them in arrays. -class Storable a => FFIRet a where - ffiRet :: RetType a - -instance FFIRet Word8 where - ffiRet = retWord8 - -instance FFIRet Word16 where - ffiRet = retWord16 - -instance FFIRet Word32 where - ffiRet = retWord32 - -instance FFIRet Word64 where - ffiRet = retWord64 - -instance FFIRet CFloat where - ffiRet = retCFloat - -instance FFIRet CDouble where - ffiRet = retCDouble - -instance FFIRet () where - ffiRet = retVoid - --- | Existential wrapper around a 'FFIArg'. -data SomeFFIArg = forall a. FFIArg a => SomeFFIArg a - --- | Call a 'ForeignImpl' with the given arguments. The type parameter decides --- how the return value should be converted into a Haskell value. -callForeignImpl :: forall a. FFIRet a => ForeignImpl -> [SomeFFIArg] -> IO a -callForeignImpl ForeignImpl {..} xs = withForeignSrc foreignImplSrc \_ -> - callFFI foreignImplFun (ffiRet @a) $ map toArg xs - where toArg (SomeFFIArg x) = ffiArg x - -#else - -data ForeignSrc = ForeignSrc deriving (Show, Generic, NFData) - -getForeignSrcPath :: ForeignSrc -> Maybe FilePath -getForeignSrcPath _ = Nothing - -loadForeignSrc :: FilePath -> IO (Either FFILoadError ForeignSrc) -loadForeignSrc _ = pure $ Right ForeignSrc - -unloadForeignSrc :: ForeignSrc -> IO () -unloadForeignSrc _ = pure () - -foreignLibPath :: FilePath -> IO (Maybe (FilePath, Bool)) -foreignLibPath _ = pure Nothing - -#endif diff --git a/src/Cryptol/Backend/FFI/Error.hs b/src/Cryptol/Backend/FFI/Error.hs deleted file mode 100644 --- a/src/Cryptol/Backend/FFI/Error.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE Safe #-} - --- | Errors from dynamic loading of shared libraries for FFI. -module Cryptol.Backend.FFI.Error where - -import Control.DeepSeq -import qualified Data.List.NonEmpty as NE -import Data.List.NonEmpty (NonEmpty) -import GHC.Generics - -import Cryptol.Utils.PP -import Cryptol.ModuleSystem.Name - -data FFILoadError - = CantLoadFFISrc - FilePath -- ^ Path to cryptol module - String -- ^ Error message - | CantLoadFFIImpl - String -- ^ Function name - String -- ^ Error message - | FFIDuplicates (NonEmpty Name) - | FFIInFunctor Name - deriving (Show, Generic, NFData) - -instance PP FFILoadError where - ppPrec _ e = - case e of - CantLoadFFISrc path msg -> - hang ("Could not load foreign source for module located at" - <+> text path <.> colon) - 4 (text msg) - CantLoadFFIImpl name _msg -> - "Could not load foreign implementation for binding" <+> text name - -- We don't print the OS error message for more consistent test output - -- hang ("Could not load foreign implementation for binding" - -- <+> text name <.> colon) - -- 4 (text _msg) - FFIDuplicates xs -> - hang "Multiple foreign declarations with the same name:" - 4 (backticks (pp (nameIdent (NE.head xs))) <+> - "defined at" <+> align (vcat (map (pp . nameLoc) (NE.toList xs)))) - FFIInFunctor x -> - hang (pp (nameLoc x) <.> ":") - 4 "Foreign declaration" <+> backticks (pp (nameIdent x)) <+> - "may not appear in a parameterized module." diff --git a/src/Cryptol/Backend/Monad.hs b/src/Cryptol/Backend/Monad.hs --- a/src/Cryptol/Backend/Monad.hs +++ b/src/Cryptol/Backend/Monad.hs @@ -34,11 +34,14 @@ , Unsupported(..) , EvalError(..) , EvalErrorEx(..) +, ImportErrorMessage(..) +, ImportThing(..) , evalPanic , wordTooWide , WordTooWide(..) ) where +import Data.Text(Text) import Control.Concurrent import Control.Concurrent.STM @@ -217,7 +220,7 @@ delayFill :: Eval a {- ^ Computation to delay -} -> Maybe (Eval a) {- ^ Optional backup computation to run if a tight loop is detected -} -> - String {- ^ message for the <> exception if a tight loop is detected -} -> + String {- ^ message for the LoopError exception if a tight loop is detected -} -> Eval (Eval a) delayFill e@(Ready _) _ _ = return e delayFill e@(Thunk _) _ _ = return e @@ -426,8 +429,26 @@ | FFINotSupported Name -- ^ Foreign function cannot be called | FFITypeNumTooBig Name TParam Integer -- ^ Number passed to foreign function -- as a type argument is too large + | FFIImportError ImportErrorMessage -- ^ a problem with the result of an FFI call deriving Typeable +data ImportErrorMessage = + ProtocolMismatch ImportThing ImportThing -- ^ Expected, got + | PartialValue + | UnexpectedData + | TagOutOfBounds Int + | Unsupported Text + | BadWordValue + | BadRationalValue + | FFINotEnabled + deriving Typeable + +data ImportThing = AValue | AFloat | ATag | ASign + deriving Typeable + + + + instance PP EvalError where ppPrec _ e = case e of InvalidIndex (Just i) -> text "invalid sequence index:" <+> integer i @@ -436,12 +457,15 @@ NegativeExponent -> text "negative exponent" LogNegative -> text "logarithm of negative" UserError x -> text "Run-time error:" <+> text x - LoopError x -> vcat [ text "<>" <+> text x + LoopError x -> vcat [ text "<>" <+> text x , text "This usually occurs due to an improper recursive definition," , text "but may also result from retrying a previously interrupted" , text "computation (e.g., after CTRL^C). In that case, you may need to" , text "`:reload` the current module to reset to a good state." ] + -- NOTE: using '<>' to distinguish this + -- error from a blackhole detected by GHC, which + -- would display '<>' BadRoundingMode r -> "invalid rounding mode" <+> integer r BadValue x -> "invalid input for" <+> backticks (text x) NoPrim x -> text "unimplemented primitive:" <+> pp x @@ -462,6 +486,34 @@ where con = case mbCon of Just c -> "for constructor" <+> backticks (text c) Nothing -> mempty + FFIImportError msg -> pp msg + +instance PP ImportErrorMessage where + ppPrec _ e = + case e of + ProtocolMismatch a b -> vcat + [ "Value mismatch:" + , " * Expected:" <+> pp a + , " * Got:" <+> pp b + ] + PartialValue -> "Partial value" + UnexpectedData -> "Unexpected data" + TagOutOfBounds n -> "Tag out of bounds:" <+> int n + Unsupported n -> "Unsupported" <+> pp n + BadWordValue -> "Bad word value" + BadRationalValue -> "Bad rational value" + FFINotEnabled -> "FFI is not enabled" + +instance PP ImportThing where + ppPrec _ e = + case e of + AValue -> "a value" + ATag -> "a tag" + ASign -> "a sign" + AFloat -> "a float" + + + instance Show EvalError where show = show . pp diff --git a/src/Cryptol/Eval.hs b/src/Cryptol/Eval.hs --- a/src/Cryptol/Eval.hs +++ b/src/Cryptol/Eval.hs @@ -812,6 +812,6 @@ where f env = case dDefinition d of - DPrim -> evalPanic "evalMatch" ["Unexpected local primitive"] - DForeign _ _ -> evalPanic "evalMatch" ["Unexpected local foreign"] - DExpr e -> evalExpr sym env e + DPrim -> evalPanic "evalMatch" ["Unexpected local primitive"] + DForeign {} -> evalPanic "evalMatch" ["Unexpected local foreign"] + DExpr e -> evalExpr sym env e diff --git a/src/Cryptol/Eval/Concrete.hs b/src/Cryptol/Eval/Concrete.hs --- a/src/Cryptol/Eval/Concrete.hs +++ b/src/Cryptol/Eval/Concrete.hs @@ -119,14 +119,11 @@ ETuple <$> (zipWithM go ts =<< lift (sequence tvs)) (TVBit, VBit b) -> pure (prim (if b then "True" else "False")) - (TVInteger, VInteger i) -> - pure $ ETApp (ETApp (prim "number") (tNum i)) tInteger - (TVIntMod n, VInteger i) -> - pure $ ETApp (ETApp (prim "number") (tNum i)) (tIntMod (tNum n)) - + (TVInteger, VInteger i) -> pure (intlit i) + (TVIntMod n, VInteger i) -> pure (numlit i (tIntMod (tNum n))) (TVRational, VRational (SRational n d)) -> - do let n' = ETApp (ETApp (prim "number") (tNum n)) tInteger - let d' = ETApp (ETApp (prim "number") (tNum d)) tInteger + do let n' = intlit n + let d' = intlit d pure $ EApp (EApp (prim "ratio") n') d' (TVFloat e p, VFloat i) -> @@ -136,7 +133,7 @@ pure $ EList ses (tValTy b) (TVSeq n TVBit, VWord wval) -> do BV _ v <- lift (asWordVal Concrete wval) - pure $ ETApp (ETApp (prim "number") (tNum v)) (tWord (tNum n)) + pure (numlit v (tWord (tNum n))) (_,VStream{}) -> mzero (_,VFun{}) -> mzero @@ -144,6 +141,17 @@ (_,VNumPoly{}) -> mzero _ -> mismatch where + -- Make a literal of type Integer + intlit n + | n < 0 = EApp (EProofApp (ETApp (prim "negate") tInteger)) + (numlit (-n) tInteger) + | otherwise = numlit n tInteger + + -- Make a non-negative literal of the given type + numlit i t = + EProofApp (ETApp (ETApp (prim "number") (tNum (i::Integer))) t) + + mismatch :: forall a. ChoiceT Eval a mismatch = do doc <- lift (ppValue Concrete defaultPPOpts val) diff --git a/src/Cryptol/Eval/FFI.hs b/src/Cryptol/Eval/FFI.hs --- a/src/Cryptol/Eval/FFI.hs +++ b/src/Cryptol/Eval/FFI.hs @@ -1,15 +1,7 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE BlockArguments #-} {-# LANGUAGE CPP #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} -- | Evaluation of foreign functions. module Cryptol.Eval.FFI @@ -17,43 +9,34 @@ , evalForeignDecls ) where -import Cryptol.Backend.FFI -import Cryptol.Backend.FFI.Error -import Cryptol.Eval -import Cryptol.TypeCheck.AST -import Cryptol.TypeCheck.FFI.FFIType - +import Cryptol.Eval.FFI.ForeignSrc + ( ForeignSrc) #ifdef FFI_ENABLED +import Cryptol.Eval.FFI.ForeignSrc + (ForeignImpl, loadForeignImpl ) +#else +import Cryptol.Parser.AST (ForeignMode) +#endif +import Cryptol.Eval.FFI.Error ( FFILoadError ) +import Cryptol.Eval (Eval, EvalEnv ) +import Cryptol.TypeCheck.AST + ( Name, FFI(..), TVar(TVBound), findForeignDecls ) +import Cryptol.TypeCheck.FFI.FFIType ( FFIFunType(..) ) -import Control.Exception(bracket_) -import Data.Either -import Data.Foldable -import Data.IORef -import Data.Proxy -import Data.Ratio -import Data.Traversable -import Data.Word -import Foreign -import Foreign.C.Types -import GHC.Float -import LibBF (bfFromDouble, bfToDouble, - pattern NearEven) -import Numeric.GMP.Raw.Unsafe -import Numeric.GMP.Utils +#ifdef FFI_ENABLED -import Cryptol.Backend +import Data.Either(partitionEithers) +import Data.Traversable(for) import Cryptol.Backend.Concrete -import Cryptol.Backend.FloatHelpers import Cryptol.Backend.Monad -import Cryptol.Backend.SeqMap import Cryptol.Eval.Env import Cryptol.Eval.Prims import Cryptol.Eval.Type import Cryptol.Eval.Value import Cryptol.ModuleSystem.Name -import Cryptol.TypeCheck.Solver.InfNat import Cryptol.Utils.Ident -import Cryptol.Utils.RecordMap +import Cryptol.Eval.FFI.C(callForeignC) +import Cryptol.Eval.FFI.Abstract(callForeignAbstract) #endif @@ -66,377 +49,44 @@ -- -- This is a separate pass from the main evaluation functions in "Cryptol.Eval" -- since it only works for the Concrete backend. -evalForeignDecls :: ForeignSrc -> [(Name, FFIFunType)] -> EvalEnv -> +evalForeignDecls :: ForeignSrc -> [(Name, FFI)] -> EvalEnv -> Eval ([FFILoadError], EvalEnv) evalForeignDecls fsrc decls env = io do - (errs, prims) <- partitionEithers <$> for decls \(name, ffiFunType) -> - fmap ((name,) . foreignPrimPoly name ffiFunType) <$> + (errs, prims) <- partitionEithers <$> for decls \(name, cc) -> + fmap ((name,) . foreignPrimPoly cc name) <$> loadForeignImpl fsrc (unpackIdent $ nameIdent name) pure (errs, foldr (uncurry bindVarDirect) env prims) -- | Generate a 'Prim' value representing the given foreign function, containing -- all the code necessary to marshal arguments and return values and do the -- actual FFI call. -foreignPrimPoly :: Name -> FFIFunType -> ForeignImpl -> Prim Concrete -foreignPrimPoly name fft impl = buildNumPoly (ffiTParams fft) mempty - where -- Add type lambdas for the type parameters and build a type environment - -- that we can look up later to compute e.g. array sizes. - -- - -- Given [p1, p2, ..., pk] {}, returns - -- PNumPoly \n1 -> PNumPoly \n2 -> ... PNumPoly \nk -> - -- foreignPrim name fft impl {p1 = n1, p2 = n2, ..., pk = nk} - buildNumPoly (tp:tps) tenv = PNumPoly \n -> - buildNumPoly tps $ bindTypeVar (TVBound tp) (Left n) tenv - buildNumPoly [] tenv = foreignPrim name fft impl tenv - --- | Methods for obtaining a return value. The producer of this type must supply --- both 1) a polymorphic IO object directly containing a return value that the --- consumer can instantiate at any 'FFIRet' type, and 2) an effectful function --- that takes some output arguments and modifies what they are pointing at to --- store a return value. The consumer can choose which one to use. -data GetRet = GetRet - { getRetAsValue :: forall a. FFIRet a => IO a - , getRetAsOutArgs :: [SomeFFIArg] -> IO () } - --- | Operations needed for returning a basic reference type. -data BasicRefRet a = BasicRefRet - { -- | Initialize the object before passing to foreign function. - initBasicRefRet :: Ptr a -> IO () - -- | Free the object after returning from foreign function and obtaining - -- return value. - , clearBasicRefRet :: Ptr a -> IO () - -- | Convert the object to a Cryptol value. - , marshalBasicRefRet :: a -> Eval (GenValue Concrete) } +foreignPrimPoly :: FFI -> Name -> ForeignImpl -> Prim Concrete +foreignPrimPoly cc name impl = + case cc of + CallC t -> foreignPrim t (callForeignC name t impl) + CallAbstract t -> foreignPrim t (callForeignAbstract name t impl) --- | Generate the monomorphic part of the foreign 'Prim', given a 'TypeEnv' --- containing all the type arguments we have already received. -foreignPrim :: Name -> FFIFunType -> ForeignImpl -> TypeEnv -> Prim Concrete -foreignPrim name FFIFunType {..} impl tenv = buildFun ffiArgTypes [] +-- | Generate a Prim for a foreign functions. +foreignPrim :: + FFIFunType t -> + (TypeEnv -> [(t,GenValue s)] -> SEval s (GenValue s)) -> + Prim s +foreignPrim ft k = buildNumPoly (ffiTParams ft) mempty where - - -- Build up the 'Prim' function for the FFI call. - -- - -- Given [t1, t2 ... tm] we return - -- PStrict \v1 -> PStrict \v2 -> ... PStrict \vm -> PPrim $ - -- marshalArg t1 v1 \a1 -> - -- marshalArg t2 v2 \a2 -> ... marshalArg tm vm \am -> - -- marshalRet ffiRetType GetRet - -- { getRetAsValue = callForeignImpl impl [n1, ..., nk, a1, ..., am] - -- , getRetAsOutArgs = \[o1, ..., ol] -> - -- callForeignImpl impl [n1, ..., nk, a1, ..., am, o1, ..., ol] } - buildFun :: [FFIType] -> [(FFIType, GenValue Concrete)] -> Prim Concrete - buildFun (argType:argTypes) typesAndVals = PStrict \val -> - buildFun argTypes $ typesAndVals ++ [(argType, val)] - buildFun [] typesAndVals = PPrim $ - marshalArgs typesAndVals \inArgs -> do - tyArgs <- traverse marshalTyArg ffiTParams - let tyInArgs = tyArgs ++ inArgs - marshalRet ffiRetType GetRet - { getRetAsValue = callForeignImpl impl tyInArgs - , getRetAsOutArgs = callForeignImpl impl . (tyInArgs ++) } - - -- Look up the value of a type parameter in the type environment and marshal - -- it. - marshalTyArg :: TParam -> Eval SomeFFIArg - marshalTyArg tp - | n <= toInteger (maxBound :: CSize) = - pure $ SomeFFIArg @CSize $ fromInteger n - | otherwise = raiseError Concrete $ FFITypeNumTooBig name tp n - where n = evalFinType $ TVar $ TVBound tp - - -- Marshal the given value as the given FFIType and call the given function - -- with the results. A single Cryptol argument may correspond to any number of - -- C arguments, so the callback takes a list. - -- - -- NOTE: the result must be used only in the callback since it may have a - -- limited lifetime (e.g. pointer returned by alloca). - marshalArg :: - FFIType -> - GenValue Concrete -> - ([SomeFFIArg] -> Eval a) -> - Eval a - - marshalArg FFIBool val f = f [SomeFFIArg @Word8 (fromBool (fromVBit val))] - - marshalArg (FFIBasic (FFIBasicVal t)) val f = - getMarshalBasicValArg t \doExport -> - do arg <- doExport val - f [SomeFFIArg arg] - - marshalArg (FFIBasic (FFIBasicRef t)) val f = - getMarshalBasicRefArg t \doExport -> - -- Since we need to do Eval actions in an IO callback, we need to manually - -- unwrap and wrap the Eval datatype - Eval \stk -> - doExport val \arg -> - with arg \ptr -> - runEval stk (f [SomeFFIArg ptr]) - - marshalArg (FFIArray (map evalFinType -> sizes) bt) val f = - case bt of - - FFIBasicVal t -> - getMarshalBasicValArg t \doExport -> - -- Since we need to do Eval actions in an IO callback, - -- we need to manually unwrap and wrap the Eval datatype - Eval \stk -> - marshalArrayArg stk \v k -> - k =<< runEval stk (doExport v) - - FFIBasicRef t -> Eval \stk -> - getMarshalBasicRefArg t \doExport -> - marshalArrayArg stk doExport - - where marshalArrayArg stk doExport = - allocaArray (fromInteger (product sizes)) \ptr -> do - -- Traverse the nested sequences and write the elements to the - -- array in order. - -- ns is the dimensions of the values we are currently - -- processing. - -- vs is the values we are currently processing. - -- nvss is the stack of previous ns and vs that we keep track of - -- that we push onto when we start processing a nested sequence - -- and pop off when we finish processing the current ones. - -- i is the index into the array. - - let - -- write next element of multi-dimensional array - write (n:ns) (v:vs) nvss !i = - do vs' <- traverse (runEval stk) - (enumerateSeqMap n (fromVSeq v)) - write ns vs' ((n, vs):nvss) i - - -- write next element in flat array - write [] (v:vs) nvss !i = - doExport v \rep -> - do pokeElemOff ptr i rep - write [] vs nvss (i + 1) - - -- finished with flat array, do next element of multi-d array - write ns [] ((n, vs):nvss) !i = write (n:ns) vs nvss i + buildNumPoly (tp:tps) tenv = PNumPoly \n -> + buildNumPoly tps (bindTypeVar (TVBound tp) (Left n) tenv) + buildNumPoly [] tenv = buildArgs tenv (ffiArgTypes ft) [] - -- done - write _ _ [] _ = pure () + buildArgs tenv (argType:argTypes) typesAndVals = PStrict \val -> + buildArgs tenv argTypes ((argType,val) : typesAndVals) + buildArgs tenv [] typesAndVals = PPrim (k tenv (reverse typesAndVals)) - write sizes [val] [] 0 - runEval stk $ f [SomeFFIArg ptr] - - marshalArg (FFITuple types) val f = - do vals <- sequence (fromVTuple val) - marshalArgs (types `zip` vals) f - - marshalArg (FFIRecord typeMap) val f = - do vals <- traverse (`lookupRecord` val) (displayOrder typeMap) - marshalArgs (displayElements typeMap `zip` vals) f - - -- Call marshalArg on a bunch of arguments and collect the results together - -- (in the order of the arguments). - marshalArgs :: - [(FFIType, GenValue Concrete)] -> - ([SomeFFIArg] -> Eval a) -> - Eval a - marshalArgs typesAndVals f = go typesAndVals [] - where - go [] args = f (concat (reverse args)) - go ((t, v):tvs) prevArgs = - marshalArg t v \currArgs -> - go tvs (currArgs : prevArgs) - - -- Given an FFIType and a GetRet, obtain a return value and convert it to a - -- Cryptol value. The return value is obtained differently depending on the - -- FFIType. - marshalRet :: FFIType -> GetRet -> Eval (GenValue Concrete) - marshalRet FFIBool gr = - do rep <- io (getRetAsValue gr @Word8) - pure (VBit (toBool rep)) - - marshalRet (FFIBasic (FFIBasicVal t)) gr = - getMarshalBasicValRet t \doImport -> - do rep <- io (getRetAsValue gr) - doImport rep - - marshalRet (FFIBasic (FFIBasicRef t)) gr = - getBasicRefRet t \how -> - Eval \stk -> - alloca \ptr -> - bracket_ (initBasicRefRet how ptr) (clearBasicRefRet how ptr) - do getRetAsOutArgs gr [SomeFFIArg ptr] - rep <- peek ptr - runEval stk (marshalBasicRefRet how rep) - - marshalRet (FFIArray (map evalFinType -> sizes) bt) gr = - Eval \stk -> do - let totalSize = fromInteger (product sizes) - getResult marshal ptr = do - getRetAsOutArgs gr [SomeFFIArg ptr] - let tyv = case bt of - FFIBasicVal bv -> case bv of - FFIWord len _ -> TVSeq len TVBit - FFIFloat e p _ -> TVFloat e p - FFIBasicRef br -> case br of - FFIInteger Nothing -> TVInteger - FFIInteger (Just z) -> TVIntMod $ evalFinType z - FFIRational -> TVRational - - let build (n:ns) !i = do - -- We need to be careful to actually run this here and not just - -- stick the IO action into the sequence with io, or else we - -- will read from the array after it is deallocated. - vs <- for [0 .. fromInteger n - 1] \j -> - build ns (i * fromInteger n + j) - runEval stk $ - mkSeq Concrete (Nat n) tyv (finiteSeqMap Concrete (map pure vs)) - build [] !i = do - e <- peekElemOff ptr i - runEval stk (marshal e) - - build sizes 0 - - case bt of - - FFIBasicVal t -> - getMarshalBasicValRet t \doImport -> - allocaArray totalSize (getResult doImport) - - FFIBasicRef t -> - getBasicRefRet t \how -> - allocaArray totalSize \ptr -> - do let forEach f = for_ [0 .. totalSize - 1] (f . advancePtr ptr) - bracket_ (forEach (initBasicRefRet how)) - (forEach (clearBasicRefRet how)) - (getResult (marshalBasicRefRet how) ptr) - - marshalRet (FFITuple types) gr = VTuple <$> marshalMultiRet types gr - - marshalRet (FFIRecord typeMap) gr = - VRecord . recordFromFields . zip (displayOrder typeMap) <$> - marshalMultiRet (displayElements typeMap) gr - - -- Obtain multiple return values as output arguments for a composite return - -- type. Each return value is fully evaluated but put back in an Eval since - -- VTuple and VRecord expect it. - marshalMultiRet :: [FFIType] -> GetRet -> Eval [Eval (GenValue Concrete)] - -- Since IO callbacks are involved we just do the whole thing in IO and wrap - -- it in an Eval at the end. This should be fine since we are not changing - -- the (Cryptol) call stack. - marshalMultiRet types gr = Eval \stk -> do - -- We use this IORef hack here since we are calling marshalRet recursively - -- but marshalRet doesn't let us return any extra information from the - -- callback through to the result of the function. So we remember the result - -- as a side effect. - vals <- newIORef [] - let go [] args = getRetAsOutArgs gr args - go (t:ts) prevArgs = do - val <- runEval stk $ marshalRet t $ getRetFromAsOutArgs \currArgs -> - go ts (prevArgs ++ currArgs) - modifyIORef' vals (val :) - go types [] - map pure <$> readIORef vals - - -- | Call the callback with a 'BasicRefRet' for the given type. - getBasicRefRet :: FFIBasicRefType -> - (forall a. Storable a => BasicRefRet a -> b) -> b - getBasicRefRet (FFIInteger mbMod) f = f BasicRefRet - { initBasicRefRet = mpz_init - , clearBasicRefRet = mpz_clear - , marshalBasicRefRet = \mpz -> do - n <- io $ peekInteger' mpz - VInteger <$> - case mbMod of - Nothing -> pure n - Just m -> intToZn Concrete (evalFinType m) n } - getBasicRefRet FFIRational f = f BasicRefRet - { initBasicRefRet = mpq_init - , clearBasicRefRet = mpq_clear - , marshalBasicRefRet = \mpq -> do - r <- io $ peekRational' mpq - pure $ VRational $ SRational (numerator r) (denominator r) } - - -- Evaluate a finite numeric type expression. - evalFinType :: Type -> Integer - evalFinType = finNat' . evalNumType tenv - --- | Given a way to 'getRetAsOutArgs', create a 'GetRet', where the --- 'getRetAsValue' simply allocates a temporary space to call 'getRetAsOutArgs' --- on. This is useful for return types that we know how to obtain directly as a --- value but need to obtain as an output argument when multiple return values --- are involved. -getRetFromAsOutArgs :: ([SomeFFIArg] -> IO ()) -> GetRet -getRetFromAsOutArgs f = GetRet - { getRetAsValue = alloca \ptr -> do - f [SomeFFIArg ptr] - peek ptr - , getRetAsOutArgs = f } - --- | Given a 'FFIBasicValType', call the callback with a marshalling function --- that marshals values to the 'FFIArg' type corresponding to the --- 'FFIBasicValType'. The callback must be able to handle marshalling functions --- that marshal to any 'FFIArg' type. -getMarshalBasicValArg :: - FFIBasicValType -> - (forall rep. - FFIArg rep => - (GenValue Concrete -> Eval rep) -> - result) -> - result - -getMarshalBasicValArg (FFIWord _ s) f = withWordType s \(_ :: p t) -> - f @t $ fmap (fromInteger . bvVal) . fromVWord Concrete "getMarshalBasicValArg" - -getMarshalBasicValArg (FFIFloat _ _ s) f = - case s of - -- LibBF can only convert to 'Double' directly, so we do that first then - -- convert to 'Float', which should not result in any loss of precision if - -- the original data was 32-bit anyways. - FFIFloat32 -> f $ pure . CFloat . double2Float . toDouble - FFIFloat64 -> f $ pure . CDouble . toDouble - where - toDouble = fst . bfToDouble NearEven . bfValue . fromVFloat - --- | Given a 'FFIBasicValType', call the callback with an unmarshalling function --- from the 'FFIRet' type corresponding to the 'FFIBasicValType' to Cryptol --- values. The callback must be able to handle unmarshalling functions from any --- 'FFIRet' type. -getMarshalBasicValRet :: FFIBasicValType -> - (forall a. FFIRet a => (a -> Eval (GenValue Concrete)) -> b) -> b -getMarshalBasicValRet (FFIWord n s) f = withWordType s \(_ :: p t) -> - f @t $ word Concrete n . toInteger -getMarshalBasicValRet (FFIFloat e p s) f = - case s of - FFIFloat32 -> f $ toValue . \case CFloat x -> float2Double x - FFIFloat64 -> f $ toValue . \case CDouble x -> x - where toValue = pure . VFloat . BF e p . bfFromDouble - --- | Call the callback with the Word type corresponding to the given --- 'FFIWordSize'. -withWordType :: FFIWordSize -> - (forall a. (FFIArg a, FFIRet a, Integral a) => Proxy a -> b) -> b -withWordType FFIWord8 f = f $ Proxy @Word8 -withWordType FFIWord16 f = f $ Proxy @Word16 -withWordType FFIWord32 f = f $ Proxy @Word32 -withWordType FFIWord64 f = f $ Proxy @Word64 - --- | Given a 'FFIBasicRefType', call the callback with a marshalling function --- that takes a Cryptol value and calls its callback with the 'Storable' type --- corresponding to the 'FFIBasicRefType'. -getMarshalBasicRefArg :: FFIBasicRefType -> - (forall rep. - Storable rep => - (GenValue Concrete -> (rep -> IO val) -> IO val) -> - result) -> - result -getMarshalBasicRefArg (FFIInteger _) f = f \val g -> - withInInteger' (fromVInteger val) g -getMarshalBasicRefArg FFIRational f = f \val g -> do - let SRational {..} = fromVRational val - withInRational' (sNum % sDenom) g - #else -- | Dummy implementation for when FFI is disabled. Does not add anything to -- the environment or report any errors. -evalForeignDecls :: ForeignSrc -> [(Name, FFIFunType)] -> EvalEnv -> +evalForeignDecls :: ForeignSrc -> [(Name, FFI)] -> EvalEnv -> Eval ([FFILoadError], EvalEnv) evalForeignDecls _ _ env = pure ([], env) diff --git a/src/Cryptol/Eval/FFI/Abstract.hs b/src/Cryptol/Eval/FFI/Abstract.hs new file mode 100644 --- /dev/null +++ b/src/Cryptol/Eval/FFI/Abstract.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE CPP #-} +-- | How to call foreign function, following the "abstract" calling convention +module Cryptol.Eval.FFI.Abstract where + +#ifdef FFI_ENABLED + +import Cryptol.Utils.Panic(panic) +import Cryptol.ModuleSystem.Name(Name) +import Cryptol.TypeCheck.Type(Type(..), TVar(..)) +import Cryptol.TypeCheck.FFI.FFIType +import Cryptol.Eval.FFI.ForeignSrc(ForeignImpl) +import Cryptol.Eval.Type(TypeEnv,evalType,evalNumType,finNat') +import Cryptol.Eval.Value +import Cryptol.Backend.Monad +import Cryptol.Backend.Concrete +import Cryptol.Eval.FFI.Abstract.Export(exportSizes,exportValues) +import Cryptol.Eval.FFI.Abstract.Call(runFFI) + + +-- | Call a foreign function that follows the \"abstract\" calling convention. +callForeignAbstract :: + Name {- ^ Name of foreign function -} -> + FFIFunType Type {- ^ FFI type -} -> + ForeignImpl {- ^ Address of foreign worker -} -> + TypeEnv {- ^ Values for numeric type parameters -} -> + [(Type, GenValue Concrete)] {- ^ Function arguments -} -> + Eval (GenValue Concrete) +callForeignAbstract nm ty impl tenv args = + case evalType tenv (ffiRetType ty) of + Right resT -> + do let targs = exportSizes (map evalFinType (ffiTParams ty)) [] + allArgs <- exportValues (map (pure . snd) args) targs + mb <- io (runFFI allArgs resT impl) + case mb of + Right a -> a + Left err -> raiseError Concrete (FFIImportError err) + Left _ -> panic "callForeginAbstract" ["Result type is a number"] + + + where + evalFinType = finNat' . evalNumType tenv . TVar . TVBound + +#endif diff --git a/src/Cryptol/Eval/FFI/Abstract/Call.hsc b/src/Cryptol/Eval/FFI/Abstract/Call.hsc new file mode 100644 --- /dev/null +++ b/src/Cryptol/Eval/FFI/Abstract/Call.hsc @@ -0,0 +1,96 @@ +{-# Language CPP #-} +-- | Calling a foreign function +module Cryptol.Eval.FFI.Abstract.Call where + +#ifdef FFI_ENABLED + +#include "cry_ffi.h" + +import Foreign +import Foreign.C.Types(CSize(..)) +import Cryptol.Eval.Type(TValue) +import Cryptol.Eval.FFI.ForeignSrc +import Cryptol.Eval.FFI.Abstract.Import +import Cryptol.Eval.FFI.Abstract.Export + + +foreign export ccall cry_bool :: Import Word8 +foreign import ccall "&cry_bool" cry_bool_addr :: FunPtr (Import Word8) + +foreign export ccall cry_small_uint :: Import Word64 +foreign import ccall "&cry_small_uint" cry_small_uint_addr :: FunPtr (Import Word64) + +foreign export ccall cry_small_sint :: Import Int64 +foreign import ccall "&cry_small_sint" cry_small_sint_addr :: FunPtr (Import Int64) + +foreign export ccall cry_double :: Import Double +foreign import ccall "&cry_double" cry_double_addr :: FunPtr (Import Double) + +foreign export ccall cry_large_int :: LargeIntFun +foreign import ccall "&cry_large_int" cry_large_int_addr :: FunPtr LargeIntFun + +foreign export ccall cry_sign :: Import Word8 +foreign import ccall "&cry_sign" cry_sign_addr :: FunPtr (Import Word8) + +foreign export ccall cry_tag :: Import CSize +foreign import ccall "&cry_tag" cry_tag_addr :: FunPtr (Import CSize) + +foreign export ccall cry_recv_u8 :: Export Word8 +foreign import ccall "&cry_recv_u8" cry_recv_u8_addr :: FunPtr (Export Word8) + +foreign export ccall cry_recv_u64 :: Export Word64 +foreign import ccall "&cry_recv_u64" cry_recv_u64_addr :: FunPtr (Export Word64) + +foreign export ccall cry_recv_u64_digits :: Export Word64 +foreign import ccall "&cry_recv_u64_digits" cry_recv_u64_digits_addr :: FunPtr (Export Word64) + +foreign export ccall cry_recv_double :: Export Double +foreign import ccall "&cry_recv_double" cry_recv_double_addr :: FunPtr (Export Double) + + + +runFFI :: + [ExportVal] {-^ Reversed, see `exportValues` -} -> + TValue {-^ Type of result -} -> + ForeignImpl {- ^ Foreign function -} -> + IO (Either ImportErrorMessage Value) {- ^ Result of call, or an error -} +runFFI args ty k = + allocaBytes #{size struct CryValImporter} $ \robj -> + allocaBytes #{size struct CryValExporter} $ \aobj -> + + do expS <- cryStartExport args + #{poke struct CryValExporter, self} aobj expS + #{poke struct CryValExporter, recv_u8} aobj cry_recv_u8_addr + #{poke struct CryValExporter, recv_u64} aobj cry_recv_u64_addr + #{poke struct CryValExporter, recv_double} aobj cry_recv_double_addr + #{poke struct CryValExporter, recv_u64_digits} aobj cry_recv_u64_digits_addr + impS <- cryStartImport ty + #{poke struct CryValImporter, self} robj impS + #{poke struct CryValImporter, send_bool} robj cry_bool_addr + #{poke struct CryValImporter, send_small_uint} robj cry_small_uint_addr + #{poke struct CryValImporter, send_small_sint} robj cry_small_sint_addr + #{poke struct CryValImporter, send_double} robj cry_double_addr + #{poke struct CryValImporter, send_tag} robj cry_tag_addr + #{poke struct CryValImporter, send_new_large_int} robj cry_large_int_addr + #{poke struct CryValImporter, send_sign} robj cry_sign_addr + callForeignImpl k [SomeFFIArg aobj, SomeFFIArg robj] :: IO () + + -- callFFI k retVoid [argPtr aobj, argPtr robj] + cryEndExport expS + cryFinishImport impS + +#else + +import Cryptol.Eval.FFI.Abstract.Export (ExportVal) +import Cryptol.Eval.FFI.Abstract.Import (Value, ImportErrorMessage(..)) +import Cryptol.Eval.Type (TValue) +import Foreign.Ptr (Ptr) + +runFFI :: + [ExportVal] -> + TValue -> + (Ptr cryValExporter -> Ptr cryValBuilder -> IO ()) -> + IO (Either ImportErrorMessage Value) +runFFI _args _ty _k = pure (Left FFINotEnabled) + +#endif diff --git a/src/Cryptol/Eval/FFI/Abstract/Export.hs b/src/Cryptol/Eval/FFI/Abstract/Export.hs new file mode 100644 --- /dev/null +++ b/src/Cryptol/Eval/FFI/Abstract/Export.hs @@ -0,0 +1,253 @@ +{-# Language OverloadedStrings, BangPatterns, MagicHash #-} +module Cryptol.Eval.FFI.Abstract.Export + ( ExportVal + , ExporterErrorMessage(..) + , Export + , exportValue, exportValues, exportSizes + , cryStartExport, cryEndExport + , cry_recv_u8 + , cry_recv_u64 + , cry_recv_u64_digits + , cry_recv_double + ) where + +import Data.Text(Text) +import qualified Data.Vector as Vector +import qualified Data.IntMap as IntMap +import Control.Exception(Exception,throw) +import Data.IORef(IORef,newIORef,readIORef,writeIORef) +import LibBF +import Foreign + ( Word8, Word32, Word64, StablePtr, Ptr, Storable(poke), + newStablePtr, freeStablePtr, castPtrToStablePtr, deRefStablePtr ) +import GHC.Num ( Integer(IN, IS, IP) ) +import GHC.Base(Int(..)) +import Data.Primitive.PrimArray + ( copyPrimArrayToPtr, sizeofPrimArray, PrimArray(..) ) + +import Cryptol.Utils.RecordMap ( canonicalFields ) +import Cryptol.Eval.Value ( Backend(SWord, SEval), GenValue(..) ) +import Cryptol.Eval.Type(conFields) +import Cryptol.Backend.FloatHelpers +import Cryptol.Backend.Concrete ( BV(BV), Concrete(..) ) +import Cryptol.Backend.Monad(Eval) +import Cryptol.Backend.SeqMap (enumerateSeqMap) +import Cryptol.Backend(SRational(..)) +import Cryptol.Backend.WordValue(asWordVal) + +data ExportVal = + EV8 !Word8 -- ^ Bit, integer sign + | EV64 !Word64 -- ^ Buffer size, sum tag + | EVDouble !Double -- ^ A double + | EVInteger !Integer -- ^ Integer, Z, Word, components of Rational + + +data ExporterErrorMessage = + UnsupportedValue Text + | MalformedSum + deriving Show + +instance Exception ExporterErrorMessage + +type Value = SEval Concrete (GenValue Concrete) + +-- Serialize a value into its external representation. +exportValue :: GenValue Concrete -> [ExportVal] -> Eval [ExportVal] +exportValue v = + case v of + VRecord rmap -> doRec rmap + VTuple vs -> exportValues vs + VSeq n sm -> exportValues (enumerateSeqMap n sm) + + -- 1. tag, 2. constructor values + VEnum tag mp + | 0 <= tag && tag <= toInteger (maxBound :: Int) + , let n = fromInteger tag + , Just con <- IntMap.lookup n mp -> + exportValues (Vector.toList (conFields con)) . (EV64 (fromIntegral n) :) + + | otherwise -> throw MalformedSum + + VBit b -> pure . exportBit b + VInteger i -> pure . exportInteger i + VRational r -> pure . exportRational r + VFloat f + | bfExpWidth f == 8 && bfPrecWidth f == 24 + || bfExpWidth f == 11 && bfPrecWidth f == 53 -> + pure . exportDouble (bfValue f) + | otherwise -> throw (UnsupportedValue "non-standard float") + + VWord w -> \start -> + do wv <- asWordVal Concrete w + pure (exportWord wv start) + + + VStream {} -> throw (UnsupportedValue "infinte stream") + VFun {} -> throw (UnsupportedValue "function") + VPoly {} -> throw (UnsupportedValue "polymorphic") + VNumPoly {} -> throw (UnsupportedValue "polymorphic") + where + doRec rmap = exportValues (map snd (canonicalFields rmap)) + + +-- | Export some top-level sizes. +-- Exported as `u64` if it is less than `2^64-1`. +-- Otherwise exported as: `(2^64-1 : u64)` followed by an unsigned integer +exportSizes :: [Integer] -> [ExportVal] -> [ExportVal] +exportSizes xs = + case xs of + [] -> id + x : more -> exportSizes more . exportSize x + +-- | Export a type-level size. +-- Exported as `u64` if it is less than `2^64-1`. +-- Otherwise exported as: `(2^64-1 : u64)` followed by an unsigned integer +exportSize :: Integer -> [ExportVal] -> [ExportVal] +exportSize n start + | n < toInteger m = EV64 (fromInteger n) : start + | otherwise = exportInteger n (EV64 m : start) + where m = maxBound :: Word64 + +exportDouble :: BigFloat -> [ExportVal] -> [ExportVal] +exportDouble bf = (EVDouble d :) + where + (!d,_) = bfToDouble NearAway bf + +-- | Encoding of a bit: 0 or 1 +exportBit :: Bool -> [ExportVal] -> [ExportVal] +exportBit b = (EV8 u8 :) + where + !u8 = if b then 1 else 0 + +-- | Encoding for an integer: sign, buffer size, digits +exportInteger :: Integer -> [ExportVal] -> [ExportVal] +exportInteger i = \start -> EVInteger i : EV64 size : EV8 sign : start + where + !sign = if i < 0 then 1 else 0 + !size = integerSize i + +-- | Encoding of a rational: numerator, denominator; both are integers +exportRational :: SRational Concrete -> [ExportVal] -> [ExportVal] +exportRational r = exportInteger (sDenom r) . exportInteger (sNum r) + +-- | Encoding of a word: buffer size, digits +exportWord :: SWord Concrete -> [ExportVal] -> [ExportVal] +exportWord (BV sz i) = \start -> + if sz <= 8 then EV8 (fromInteger i) : start else + if sz <= 64 then EV64 (fromInteger i) : start else + EVInteger i : EV64 size : start + where + !size = integerSize i + +-- | Export a sequence of values: tuples, records, sequences. +-- Note that empty sequences don't have any representation. +exportValues :: [Value] -> [ExportVal] -> Eval [ExportVal] +exportValues vs done = + case vs of + mv : more -> + do v <- mv + exportValues more =<< exportValue v done + [] -> pure done + + +-- | How many Word64s do we need to represent this integer. +integerSize :: Integer -> Word64 +integerSize i = + case i of + IS _ -> 1 + IP x -> getSize (PrimArray x) + IN x -> getSize (PrimArray x) + where + getSize :: PrimArray Word64 -> Word64 + getSize x = fromIntegral (sizeofPrimArray x) + + + +cryStartExport :: + [ExportVal] {-| REVERSED. Send these to foreign. -} -> + IO (StablePtr (IORef [ExportVal])) +cryStartExport vs = + do ref <- newIORef (reverse vs) + newStablePtr ref + +-- | Get the next data item to export. +-- We assume that this is the only place to manipulate the reference +-- so there's not a race condition. Note that it is also important +-- that we access these from the same thread, otherwise we may miss +-- some of the writes etc. This should be OK because FFI calls should +-- all be happening on the same thread. +cryExportNext :: + StablePtr (IORef [ExportVal]) -> IO (Either Word32 ExportVal) +cryExportNext ptr = + do ref <- deRefStablePtr ptr + xs <- readIORef ref + case xs of + x : more -> writeIORef ref more >> pure (Right x) + [] -> pure (Left maxBound) + +cryEndExport :: StablePtr (IORef [ExportVal]) -> IO () +cryEndExport = freeStablePtr + + +type Export a = Ptr () -> Ptr a -> IO Word32 + +-- | Get the next data item, which should be uint8_t +cry_recv_u8 :: Export Word8 +cry_recv_u8 self out = + do mb <- cryExportNext (castPtrToStablePtr self) + case mb of + Left err -> pure err + Right d -> + case d of + EV8 w -> poke out w >> pure 0 + EV64 {} -> pure 2 + EVInteger {} -> pure 3 + EVDouble {} -> pure 4 + + +-- | Get the next data item, which shoudl be uint64_t +cry_recv_u64 :: Export Word64 +cry_recv_u64 self out = + do mb <- cryExportNext (castPtrToStablePtr self) + case mb of + Left err -> pure err + Right d -> + case d of + EV8 {} -> pure 1 + EV64 w -> poke out w >> pure 0 + EVInteger {} -> pure 3 + EVDouble {} -> pure 4 + + +-- | Get the digits for an integer +cry_recv_u64_digits :: Export Word64 +cry_recv_u64_digits self out = + do mb <- cryExportNext (castPtrToStablePtr self) + case mb of + Left err -> pure err + Right d -> + case d of + EV8 {} -> pure 1 + EV64 {} -> pure 2 + EVDouble {} -> pure 4 + EVInteger i -> + do case i of + IS x -> poke out (fromIntegral (abs (I# x))) + IP x -> doCopy (PrimArray x) + IN x -> doCopy (PrimArray x) + pure 0 + where + doCopy :: PrimArray Word64 -> IO () + doCopy x = copyPrimArrayToPtr out x 0 (sizeofPrimArray x) + +cry_recv_double :: Export Double +cry_recv_double self out = + do mb <- cryExportNext (castPtrToStablePtr self) + case mb of + Left err -> pure err + Right d -> + case d of + EV8 {} -> pure 1 + EV64 {} -> pure 2 + EVInteger {} -> pure 3 + EVDouble dbl -> poke out dbl >> pure 0 diff --git a/src/Cryptol/Eval/FFI/Abstract/Import.hs b/src/Cryptol/Eval/FFI/Abstract/Import.hs new file mode 100644 --- /dev/null +++ b/src/Cryptol/Eval/FFI/Abstract/Import.hs @@ -0,0 +1,345 @@ +{-# Language OverloadedStrings #-} +{-# Language BlockArguments #-} +{-# Language LambdaCase #-} +-- | Export builders for Cryptol values +module Cryptol.Eval.FFI.Abstract.Import ( + cryStartImport, + cryFinishImport, + cry_bool, + cry_small_uint, + cry_small_sint, + cry_large_int, + cry_sign, + cry_tag, + cry_double, + Value, + Import, + LargeIntFun, + ImportErrorMessage(..) + )where + +import qualified Data.IntMap as IntMap +import Data.List(intersperse) +import Data.Vector(Vector) +import qualified Data.Vector as Vector +import Data.IORef +import LibBF(bfFromDouble) +import Foreign +import Foreign.C.Types(CSize(..) ) +import Control.Monad.Primitive(PrimState) +import GHC.Num.Compat(bigNatToInteger, bigNatToNegInteger) +import Data.Primitive.PrimArray(MutablePrimArray(..), PrimArray(..), + mutablePrimArrayContents, newPinnedPrimArray, unsafeFreezePrimArray) + +import Cryptol.Utils.PP +import Cryptol.Backend.FloatHelpers +import Cryptol.Utils.RecordMap +import Cryptol.TypeCheck.Solver.InfNat +import Cryptol.Eval.Type +import Cryptol.Eval.Value +import Cryptol.Backend.Monad +import Cryptol.Backend.Concrete +import Cryptol.Backend.SeqMap + +import Cryptol.Backend + + +type Value = SEval Concrete (GenValue Concrete) + +-- | Imported Cryptol values (aka \"context\") +data Importer = + Building [Frame] -- ^ A partial value + | Done Value -- ^ Fully built value + | Error ImportErrorMessage + -- ^ Something went wrong + -- XXX: It'd be nice to store the [Frame] here as well, + -- but that's a bit of a pain because of missing `Show` instances... + +data Mk = + Mk { mkPrec :: Int, mkPP :: [Doc] -> Doc + , mkVal :: [Value] -> Either ImportErrorMessage Value + } + +-- | Describes what we are missing +data Frame = + NeedVal + -- ^ A primitive value + + | NeedDouble Integer Integer + -- ^ We are expecting a double to make the given floating point number + + | NeedSign (MutablePrimArray (PrimState IO) Word64) + -- ^ This is a step of making a BigInt. + -- We've allocated a buffer and are waiting for it to be filled with the + -- base-64 digits of of a big int (least significant first), + -- and to be told what the sign should be. + + | NeedMany Mk [Value] [TValue] + -- ^ A compound value, fields are like this: + -- * Constructor for the value + -- * Parts of the value we have + -- * Types of the parts of the values we still need, + -- not counting the hole. + + | NeedOneOf (Vector (ConInfo TValue)) + -- ^ Sum type value, which needs a constructor tag to proceed. + +-- | Fill the "hole" with the given value. +haveValue :: Value -> [Frame] -> Importer +haveValue v fs = + case fs of + [] -> Done v + f : more -> + case f of + NeedVal -> haveValue v more + NeedDouble {} -> Error (ProtocolMismatch AFloat AValue) + NeedMany mk vs ts -> + let done = v : vs in + case ts of + [] -> case mkVal mk (reverse done) of + Left err -> Error err + Right a -> haveValue a more + t : ts' -> needValue t (NeedMany mk done ts' : more) + NeedOneOf {} -> Error (ProtocolMismatch ATag AValue) + NeedSign {} -> Error (ProtocolMismatch ASign AValue) + +-- | Provide a constructor tag +haveTag :: Int -> [Frame] -> Importer +haveTag n fs0 = + case fs0 of + [] -> Error UnexpectedData + f : fs -> + case f of + NeedVal -> Error (ProtocolMismatch AValue ATag) + NeedDouble {} -> Error (ProtocolMismatch AFloat ATag) + NeedMany {} -> Error (ProtocolMismatch AValue ATag) + NeedSign {} -> Error (ProtocolMismatch ASign ATag) + NeedOneOf opts -> + case opts Vector.!? n of + Nothing -> Error (TagOutOfBounds n) + Just ci -> + case Vector.toList (conFields ci) of + [] -> haveValue (mkV []) fs + t : ts -> + needValue t (NeedMany (Mk 10 ppV (Right . mkV)) [] ts : fs) + where + ppV xs = pp (conIdent ci) <+> hsep xs + + mkV :: [Value] -> Value + mkV vs = pure (VEnum + (toInteger n) + (IntMap.singleton n + ci { conFields = Vector.fromList vs })) + + +haveSign :: Bool -> [Frame] -> IO Importer +haveSign isPos fs0 = + case fs0 of + [] -> pure (Error UnexpectedData) + f : fs -> + case f of + NeedVal -> mismatch AValue + NeedDouble {} -> mismatch AValue + NeedMany {} -> mismatch AValue + NeedOneOf {} -> mismatch ATag + NeedSign buf -> + do PrimArray fbuf <- unsafeFreezePrimArray buf + let i = if isPos then bigNatToInteger fbuf else bigNatToNegInteger fbuf + i `seq` pure (haveValue (pure (VInteger i)) fs) + where + mismatch x = pure (Error (ProtocolMismatch x ASign)) + +haveFloat :: Double -> [Frame] -> Importer +haveFloat d fs0 = + case fs0 of + [] -> Error UnexpectedData + f : fs -> + case f of + NeedDouble e p -> haveValue v fs + where v = pure (VFloat (BF e p (bfFromDouble d))) :: Value + NeedVal -> Error (ProtocolMismatch AValue AFloat) + NeedMany {} -> Error (ProtocolMismatch AValue AFloat) + NeedOneOf {} -> Error (ProtocolMismatch ATag AFloat) + NeedSign {} -> Error (ProtocolMismatch ASign AFloat) + + +-- | Make a "hole" of the given type. +needValue :: TValue -> [Frame] -> Importer +needValue tval fs = + case tval of + TVBit -> Building (NeedVal : fs) + TVInteger -> Building (NeedVal : fs) + TVIntMod _ -> Building (NeedVal : fs) + TVFloat e p -> Building (NeedDouble e p : fs) + + TVRational -> + Building (NeedVal : NeedMany (Mk 10 ppV mkV) [] [TVInteger] : fs) + where + ppV xs = "Rational" <+> hsep xs + mkV xs = + case xs of + [Ready (VInteger i), Ready (VInteger j)] -> + Right (VRational <$> ratio Concrete i j) + _ -> Left BadRationalValue + + TVSeq len elT -> + case elT of + TVBit -> Building (NeedVal : NeedMany (Mk 10 ppV mkV) [] [] : fs) + where + ppV xs = "Word" <+> integer len <+> hsep xs + mkV xs = + case xs of + [Ready (VInteger i)] -> Right (word Concrete len i) + _ -> Left BadWordValue + + _ | len < 1 -> haveValue (mkV []) fs + | otherwise -> + needValue elT (NeedMany (Mk 0 ppV (Right . mkV)) [] ts : fs) + where + ppV xs = brackets (commaSep xs) + mkV xs = mkSeq Concrete (Nat len) elT (finiteSeqMap Concrete xs) + ts = replicate (fromInteger len - 1) elT + + TVTuple tys -> + case tys of + [] -> haveValue (mkV []) fs + t : ts -> needValue t (NeedMany (Mk 0 ppV (Right . mkV)) [] ts : fs) + where + ppV xs = parens (commaSep xs) + mkV = pure . VTuple + + TVRec rmp -> doRec rmp + + TVNominal _ _ nv -> + case nv of + TVAbstract -> Error (Unsupported "abstract") + TVStruct rmp -> doRec rmp + TVEnum cons -> Building (NeedOneOf cons : fs) + + TVFun {} -> Error (Unsupported "function") + TVStream {} -> Error (Unsupported "infinite stream") + TVArray {} -> Error (Unsupported "array") + + where + doRec rmp = + case ts of + [] -> haveValue (mkV []) fs + t : ts' -> needValue t (NeedMany (Mk 0 ppV (Right . mkV)) [] ts' : fs) + where + (ls,ts) = unzip (canonicalFields rmp) + mkV vs = pure (VRecord (recordFromFields (zip ls vs))) + ppV xs = braces (commaSep (zipWith ppF ls xs)) + ppF x y = pp x <+> "_" <+> y + + +ppValPrec :: Int -> Value -> Doc +ppValPrec p v = + case ppValuePrec Concrete defaultPPOpts p =<< v of + Ready doc -> doc + _ -> "" + +instance PP Frame where + ppPrec _ f = + case f of + NeedVal -> "_" + NeedDouble e p -> parens ("_" <+> ":" <+> "Float" <+> integer e <+> integer p) + NeedMany mk vs ts -> + let p = mkPrec mk + args = map (ppValPrec p) vs ++ ["_"] ++ map (ppPrec p . tValTy) ts + in mkPP mk args + NeedOneOf vs -> + hsep (intersperse "|" (map (pp . conIdent) (Vector.toList vs))) + NeedSign {} -> "BigNum _" + + + +-------------------------------------------------------------------------------- + +cryStartImport :: TValue -> IO (StablePtr (IORef Importer)) +cryStartImport ty = + do ref <- newIORef (needValue ty []) + newStablePtr ref + +cryFinishImport :: + StablePtr (IORef Importer) -> IO (Either ImportErrorMessage Value) +cryFinishImport ptr = + do ref <- deRefStablePtr ptr + freeStablePtr ptr + builder <- readIORef ref + pure $! + case builder of + Done v -> Right v + Error e -> Left e + Building _ -> Left PartialValue + + +-------------------------------------------------------------------------------- + + + + +modifyState :: ([Frame] -> Importer) -> Ptr () -> IO () +modifyState how ptr = + do ref <- deRefStablePtr (castPtrToStablePtr ptr) + modifyIORef' ref \case + Error err -> Error err + Done _ -> Error UnexpectedData + Building fs -> how fs + + +-- | This function assumes that we are the only ones modifying the +-- builder state, so we don't need to worry about race conditions. +modifyStateIO :: ([Frame] -> IO Importer) -> Ptr () -> IO () +modifyStateIO how ptr = + do ref <- deRefStablePtr (castPtrToStablePtr ptr) + builder <- readIORef ref + newS <- case builder of + Error err -> pure (Error err) + Done _ -> pure (Error UnexpectedData) + Building fs -> how fs + newS `seq` writeIORef ref newS + + + +type Import a = Ptr () -> a -> IO () + +-- | Receive a bool value +cry_bool :: Import Word8 +cry_bool self b = modifyState (haveValue $! v) self + where + v = if b == 0 then pure (VBit False) else pure (VBit True) + +-- | Receive a double value +cry_double :: Import Double +cry_double self b = modifyState (haveFloat $! b) self + +-- | Receive a small unsigned integer that fits in 64-bits +cry_small_uint :: Import Word64 +cry_small_uint self i = modifyState (haveValue $! v) self + where + v = pure $! VInteger $! toInteger i + +-- | Receive a small signed integer that fits in 64-bits +cry_small_sint :: Import Int64 +cry_small_sint self i = modifyState (haveValue $! v) self + where + v = pure $! VInteger $! toInteger i + + +-- | Receive an integer that's larger than 64-bits. +-- This is part 1 of a 2 step process. +type LargeIntFun = Ptr () -> CSize -> IO (Ptr Word64) +cry_large_int :: LargeIntFun +cry_large_int ptr sz = + do arr <- newPinnedPrimArray (fromIntegral sz) + modifyState (\fs -> Building (NeedSign arr : fs)) ptr + pure (mutablePrimArrayContents arr) + +-- | Finish building a large integer. +-- The argument is 1 for negative, 0 for non-negative. +cry_sign :: Import Word8 +cry_sign self sign = modifyStateIO (haveSign (sign == 0)) self + +-- | Receive a tag for a sum type. +cry_tag :: Import CSize +cry_tag self c = modifyState (haveTag $! fromIntegral c) self diff --git a/src/Cryptol/Eval/FFI/C.hs b/src/Cryptol/Eval/FFI/C.hs new file mode 100644 --- /dev/null +++ b/src/Cryptol/Eval/FFI/C.hs @@ -0,0 +1,385 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} +-- | How to call foreign functions following the C-style calling convention. + +#ifdef FFI_ENABLED + +module Cryptol.Eval.FFI.C (callForeignC) where +import Cryptol.Eval.FFI.ForeignSrc + +import Cryptol.Eval +import Cryptol.TypeCheck.AST +import Cryptol.TypeCheck.FFI.FFIType + +import Control.Exception(bracket_) +import Data.Foldable +import Data.IORef +import Data.Proxy +import Data.Ratio +import Data.Traversable +import Data.Word +import Foreign +import Foreign.C.Types +import GHC.Float +import LibBF (bfFromDouble, bfToDouble, + pattern NearEven) +import Numeric.GMP.Raw.Unsafe +import Numeric.GMP.Utils + +import Cryptol.Backend +import Cryptol.Backend.Concrete +import Cryptol.Backend.FloatHelpers +import Cryptol.Backend.Monad +import Cryptol.Backend.SeqMap +import Cryptol.Eval.Type +import Cryptol.Eval.Value +import Cryptol.TypeCheck.Solver.InfNat +import Cryptol.Utils.RecordMap + + +-- | Methods for obtaining a return value. The producer of this type must supply +-- both 1) a polymorphic IO object directly containing a return value that the +-- consumer can instantiate at any 'FFIRet' type, and 2) an effectful function +-- that takes some output arguments and modifies what they are pointing at to +-- store a return value. The consumer can choose which one to use. +data GetRet = GetRet + { getRetAsValue :: forall a. FFIRet a => IO a + , getRetAsOutArgs :: [SomeFFIArg] -> IO () } + +-- | Operations needed for returning a basic reference type. +data BasicRefRet a = BasicRefRet + { -- | Initialize the object before passing to foreign function. + initBasicRefRet :: Ptr a -> IO () + -- | Free the object after returning from foreign function and obtaining + -- return value. + , clearBasicRefRet :: Ptr a -> IO () + -- | Convert the object to a Cryptol value. + , marshalBasicRefRet :: a -> Eval (GenValue Concrete) } + + +-- | Call a foreign function, which follows the C style calling convetion. +callForeignC :: + Name {- ^ Name of foregin function -} -> + FFIFunType FFIType {- ^ FFI type -} -> + ForeignImpl {- ^ Address of foreign worker -} -> + TypeEnv {- ^ Values for numeric type parametres -} -> + [(FFIType, GenValue Concrete)] {- ^ Function arguments -} -> + Eval (GenValue Concrete) +callForeignC name FFIFunType {..} impl tenv typesAndVals = + marshalArgs typesAndVals \inArgs -> do + tyArgs <- traverse marshalTyArg ffiTParams + let tyInArgs = tyArgs ++ inArgs + marshalRet ffiRetType GetRet + { getRetAsValue = callForeignImpl impl tyInArgs + , getRetAsOutArgs = callForeignImpl impl . (tyInArgs ++) } + where + -- Look up the value of a type parameter in the type environment and marshal + -- it. + marshalTyArg :: TParam -> Eval SomeFFIArg + marshalTyArg tp + | n <= toInteger (maxBound :: CSize) = + pure $ SomeFFIArg @CSize $ fromInteger n + | otherwise = raiseError Concrete $ FFITypeNumTooBig name tp n + where n = evalFinType $ TVar $ TVBound tp + + -- Marshal the given value as the given FFIType and call the given function + -- with the results. A single Cryptol argument may correspond to any number of + -- C arguments, so the callback takes a list. + -- + -- NOTE: the result must be used only in the callback since it may have a + -- limited lifetime (e.g. pointer returned by alloca). + marshalArg :: + FFIType -> + GenValue Concrete -> + ([SomeFFIArg] -> Eval a) -> + Eval a + + marshalArg FFIBool val f = f [SomeFFIArg @Word8 (fromBool (fromVBit val))] + + marshalArg (FFIBasic (FFIBasicVal t)) val f = + getMarshalBasicValArg t \doExport -> + do arg <- doExport val + f [SomeFFIArg arg] + + marshalArg (FFIBasic (FFIBasicRef t)) val f = + getMarshalBasicRefArg t \doExport -> + -- Since we need to do Eval actions in an IO callback, we need to manually + -- unwrap and wrap the Eval datatype + Eval \stk -> + doExport val \arg -> + with arg \ptr -> + runEval stk (f [SomeFFIArg ptr]) + + marshalArg (FFIArray (map evalFinType -> sizes) bt) val f = + case bt of + + FFIBasicVal t -> + getMarshalBasicValArg t \doExport -> + -- Since we need to do Eval actions in an IO callback, + -- we need to manually unwrap and wrap the Eval datatype + Eval \stk -> + marshalArrayArg stk \v k -> + k =<< runEval stk (doExport v) + + FFIBasicRef t -> Eval \stk -> + getMarshalBasicRefArg t \doExport -> + marshalArrayArg stk doExport + + where marshalArrayArg stk doExport = + allocaArray (fromInteger (product sizes)) \ptr -> do + -- Traverse the nested sequences and write the elements to the + -- array in order. + -- ns is the dimensions of the values we are currently + -- processing. + -- vs is the values we are currently processing. + -- nvss is the stack of previous ns and vs that we keep track of + -- that we push onto when we start processing a nested sequence + -- and pop off when we finish processing the current ones. + -- i is the index into the array. + + let + -- write next element of multi-dimensional array + write (n:ns) (v:vs) nvss !i = + do vs' <- traverse (runEval stk) + (enumerateSeqMap n (fromVSeq v)) + write ns vs' ((n, vs):nvss) i + + -- write next element in flat array + write [] (v:vs) nvss !i = + doExport v \rep -> + do pokeElemOff ptr i rep + write [] vs nvss (i + 1) + + -- finished with flat array, do next element of multi-d array + write ns [] ((n, vs):nvss) !i = write (n:ns) vs nvss i + + -- done + write _ _ [] _ = pure () + + + write sizes [val] [] 0 + runEval stk $ f [SomeFFIArg ptr] + + marshalArg (FFITuple types) val f = + do vals <- sequence (fromVTuple val) + marshalArgs (types `zip` vals) f + + marshalArg (FFIRecord typeMap) val f = + do vals <- traverse (`lookupRecord` val) (displayOrder typeMap) + marshalArgs (displayElements typeMap `zip` vals) f + + -- Call marshalArg on a bunch of arguments and collect the results together + -- (in the order of the arguments). + marshalArgs :: + [(FFIType, GenValue Concrete)] -> + ([SomeFFIArg] -> Eval a) -> + Eval a + marshalArgs tysVs f = go tysVs [] + where + go [] args = f (concat (reverse args)) + go ((t, v):tvs) prevArgs = + marshalArg t v \currArgs -> + go tvs (currArgs : prevArgs) + + -- Given an FFIType and a GetRet, obtain a return value and convert it to a + -- Cryptol value. The return value is obtained differently depending on the + -- FFIType. + marshalRet :: FFIType -> GetRet -> Eval (GenValue Concrete) + marshalRet FFIBool gr = + do rep <- io (getRetAsValue gr @Word8) + pure (VBit (toBool rep)) + + marshalRet (FFIBasic (FFIBasicVal t)) gr = + getMarshalBasicValRet t \doImport -> + do rep <- io (getRetAsValue gr) + doImport rep + + marshalRet (FFIBasic (FFIBasicRef t)) gr = + getBasicRefRet t \how -> + Eval \stk -> + alloca \ptr -> + bracket_ (initBasicRefRet how ptr) (clearBasicRefRet how ptr) + do getRetAsOutArgs gr [SomeFFIArg ptr] + rep <- peek ptr + runEval stk (marshalBasicRefRet how rep) + + marshalRet (FFIArray (map evalFinType -> sizes) bt) gr = + Eval \stk -> do + let totalSize = fromInteger (product sizes) + getResult marshal ptr = do + getRetAsOutArgs gr [SomeFFIArg ptr] + let tyv = case bt of + FFIBasicVal bv -> case bv of + FFIWord len _ -> TVSeq len TVBit + FFIFloat e p _ -> TVFloat e p + FFIBasicRef br -> case br of + FFIInteger Nothing -> TVInteger + FFIInteger (Just z) -> TVIntMod $ evalFinType z + FFIRational -> TVRational + + let build (n:ns) !i = do + -- We need to be careful to actually run this here and not just + -- stick the IO action into the sequence with io, or else we + -- will read from the array after it is deallocated. + vs <- for [0 .. fromInteger n - 1] \j -> + build ns (i * fromInteger n + j) + runEval stk $ + mkSeq Concrete (Nat n) tyv (finiteSeqMap Concrete (map pure vs)) + build [] !i = do + e <- peekElemOff ptr i + runEval stk (marshal e) + + build sizes 0 + + case bt of + + FFIBasicVal t -> + getMarshalBasicValRet t \doImport -> + allocaArray totalSize (getResult doImport) + + FFIBasicRef t -> + getBasicRefRet t \how -> + allocaArray totalSize \ptr -> + do let forEach f = for_ [0 .. totalSize - 1] (f . advancePtr ptr) + bracket_ (forEach (initBasicRefRet how)) + (forEach (clearBasicRefRet how)) + (getResult (marshalBasicRefRet how) ptr) + + marshalRet (FFITuple types) gr = VTuple <$> marshalMultiRet types gr + + marshalRet (FFIRecord typeMap) gr = + VRecord . recordFromFields . zip (displayOrder typeMap) <$> + marshalMultiRet (displayElements typeMap) gr + + -- Obtain multiple return values as output arguments for a composite return + -- type. Each return value is fully evaluated but put back in an Eval since + -- VTuple and VRecord expect it. + marshalMultiRet :: [FFIType] -> GetRet -> Eval [Eval (GenValue Concrete)] + -- Since IO callbacks are involved we just do the whole thing in IO and wrap + -- it in an Eval at the end. This should be fine since we are not changing + -- the (Cryptol) call stack. + marshalMultiRet types gr = Eval \stk -> do + -- We use this IORef hack here since we are calling marshalRet recursively + -- but marshalRet doesn't let us return any extra information from the + -- callback through to the result of the function. So we remember the result + -- as a side effect. + vals <- newIORef [] + let go [] args = getRetAsOutArgs gr args + go (t:ts) prevArgs = do + val <- runEval stk $ marshalRet t $ getRetFromAsOutArgs \currArgs -> + go ts (prevArgs ++ currArgs) + modifyIORef' vals (val :) + go types [] + map pure <$> readIORef vals + + -- | Call the callback with a 'BasicRefRet' for the given type. + getBasicRefRet :: FFIBasicRefType -> + (forall a. Storable a => BasicRefRet a -> b) -> b + getBasicRefRet (FFIInteger mbMod) f = f BasicRefRet + { initBasicRefRet = mpz_init + , clearBasicRefRet = mpz_clear + , marshalBasicRefRet = \mpz -> do + n <- io $ peekInteger' mpz + VInteger <$> + case mbMod of + Nothing -> pure n + Just m -> intToZn Concrete (evalFinType m) n } + getBasicRefRet FFIRational f = f BasicRefRet + { initBasicRefRet = mpq_init + , clearBasicRefRet = mpq_clear + , marshalBasicRefRet = \mpq -> do + r <- io $ peekRational' mpq + pure $ VRational $ SRational (numerator r) (denominator r) } + + -- Evaluate a finite numeric type expression. + evalFinType :: Type -> Integer + evalFinType = finNat' . evalNumType tenv + + + +-- | Given a way to 'getRetAsOutArgs', create a 'GetRet', where the +-- 'getRetAsValue' simply allocates a temporary space to call 'getRetAsOutArgs' +-- on. This is useful for return types that we know how to obtain directly as a +-- value but need to obtain as an output argument when multiple return values +-- are involved. +getRetFromAsOutArgs :: ([SomeFFIArg] -> IO ()) -> GetRet +getRetFromAsOutArgs f = GetRet + { getRetAsValue = alloca \ptr -> do + f [SomeFFIArg ptr] + peek ptr + , getRetAsOutArgs = f } + +-- | Given a 'FFIBasicValType', call the callback with a marshalling function +-- that marshals values to the 'FFIArg' type corresponding to the +-- 'FFIBasicValType'. The callback must be able to handle marshalling functions +-- that marshal to any 'FFIArg' type. +getMarshalBasicValArg :: + FFIBasicValType -> + (forall rep. + FFIArg rep => + (GenValue Concrete -> Eval rep) -> + result) -> + result + +getMarshalBasicValArg (FFIWord _ s) f = withWordType s \(_ :: p t) -> + f @t $ fmap (fromInteger . bvVal) . fromVWord Concrete "getMarshalBasicValArg" + +getMarshalBasicValArg (FFIFloat _ _ s) f = + case s of + -- LibBF can only convert to 'Double' directly, so we do that first then + -- convert to 'Float', which should not result in any loss of precision if + -- the original data was 32-bit anyways. + FFIFloat32 -> f $ pure . CFloat . double2Float . toDouble + FFIFloat64 -> f $ pure . CDouble . toDouble + where + toDouble = fst . bfToDouble NearEven . bfValue . fromVFloat + +-- | Given a 'FFIBasicValType', call the callback with an unmarshalling function +-- from the 'FFIRet' type corresponding to the 'FFIBasicValType' to Cryptol +-- values. The callback must be able to handle unmarshalling functions from any +-- 'FFIRet' type. +getMarshalBasicValRet :: FFIBasicValType -> + (forall a. FFIRet a => (a -> Eval (GenValue Concrete)) -> b) -> b +getMarshalBasicValRet (FFIWord n s) f = withWordType s \(_ :: p t) -> + f @t $ word Concrete n . toInteger +getMarshalBasicValRet (FFIFloat e p s) f = + case s of + FFIFloat32 -> f $ toValue . \case CFloat x -> float2Double x + FFIFloat64 -> f $ toValue . \case CDouble x -> x + where toValue = pure . VFloat . BF e p . bfFromDouble + +-- | Call the callback with the Word type corresponding to the given +-- 'FFIWordSize'. +withWordType :: FFIWordSize -> + (forall a. (FFIArg a, FFIRet a, Integral a) => Proxy a -> b) -> b +withWordType FFIWord8 f = f $ Proxy @Word8 +withWordType FFIWord16 f = f $ Proxy @Word16 +withWordType FFIWord32 f = f $ Proxy @Word32 +withWordType FFIWord64 f = f $ Proxy @Word64 + +-- | Given a 'FFIBasicRefType', call the callback with a marshalling function +-- that takes a Cryptol value and calls its callback with the 'Storable' type +-- corresponding to the 'FFIBasicRefType'. +getMarshalBasicRefArg :: FFIBasicRefType -> + (forall rep. + Storable rep => + (GenValue Concrete -> (rep -> IO val) -> IO val) -> + result) -> + result +getMarshalBasicRefArg (FFIInteger _) f = f \val g -> + withInInteger' (fromVInteger val) g +getMarshalBasicRefArg FFIRational f = f \val g -> do + let SRational {..} = fromVRational val + withInRational' (sNum % sDenom) g + +#else +module Cryptol.Eval.FFI.C where +#endif diff --git a/src/Cryptol/Eval/FFI/Error.hs b/src/Cryptol/Eval/FFI/Error.hs new file mode 100644 --- /dev/null +++ b/src/Cryptol/Eval/FFI/Error.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Safe #-} + +-- | Errors from dynamic loading of shared libraries for FFI. +module Cryptol.Eval.FFI.Error where + +import Control.DeepSeq +import qualified Data.List.NonEmpty as NE +import Data.List.NonEmpty (NonEmpty) +import GHC.Generics + +import Cryptol.Utils.PP +import Cryptol.ModuleSystem.Name + +data FFILoadError + = CantLoadFFISrc + FilePath -- ^ Path to cryptol module + String -- ^ Error message + | CantLoadFFIImpl + String -- ^ Function name + String -- ^ Error message + | FFIDuplicates (NonEmpty Name) + | FFIInFunctor Name + deriving (Show, Generic, NFData) + +instance PP FFILoadError where + ppPrec _ e = + case e of + CantLoadFFISrc path msg -> + hang ("Could not load foreign source for module located at" + <+> text path <.> colon) + 4 (text msg) + CantLoadFFIImpl name _msg -> + "Could not load foreign implementation for binding" <+> text name + -- We don't print the OS error message for more consistent test output + -- hang ("Could not load foreign implementation for binding" + -- <+> text name <.> colon) + -- 4 (text _msg) + FFIDuplicates xs -> + hang "Multiple foreign declarations with the same name:" + 4 (backticks (pp (nameIdent (NE.head xs))) <+> + "defined at" <+> align (vcat (map (pp . nameLoc) (NE.toList xs)))) + FFIInFunctor x -> + hang (pp (nameLoc x) <.> ":") + 4 "Foreign declaration" <+> backticks (pp (nameIdent x)) <+> + "may not appear in a parameterized module." diff --git a/src/Cryptol/Eval/FFI/ForeignSrc.hs b/src/Cryptol/Eval/FFI/ForeignSrc.hs new file mode 100644 --- /dev/null +++ b/src/Cryptol/Eval/FFI/ForeignSrc.hs @@ -0,0 +1,284 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} + +-- | The implementation of loading and calling external functions from shared +-- libraries. +module Cryptol.Eval.FFI.ForeignSrc + ( ForeignSrc + , getForeignSrcPath + , loadForeignSrc + , unloadForeignSrc + , foreignLibPath +#ifdef FFI_ENABLED + , ForeignImpl + , loadForeignImpl + , FFIArg + , FFIRet + , SomeFFIArg (..) + , callForeignImpl +#endif + ) + where + +import Control.DeepSeq + +import Cryptol.Eval.FFI.Error + +#ifdef FFI_ENABLED + +import Control.Concurrent.MVar +import Control.Exception +import Control.Monad +import Data.Bifunctor +import Data.Maybe +import Data.Word +import Foreign hiding (newForeignPtr) +import Foreign.C.Types +import Foreign.Concurrent +import Foreign.LibFFI +import System.Directory (canonicalizePath, doesFileExist) +import System.FilePath ((-<.>)) +import System.Info (os) +import System.IO.Error + +#if defined(mingw32_HOST_OS) +import System.Win32.DLL +#else +import System.Posix.DynamicLinker +#endif + +import Cryptol.Utils.Panic + +#else + +import GHC.Generics + +#endif + +#ifdef FFI_ENABLED + +-- | A source from which we can retrieve implementations of foreign functions. +data ForeignSrc = ForeignSrc + { -- | The file path of the 'ForeignSrc'. + foreignSrcPath :: FilePath + -- | The 'ForeignPtr' wraps the pointer returned by 'dlopen', where the + -- finalizer calls 'dlclose' when the library is no longer needed. We keep + -- references to the 'ForeignPtr' in each foreign function that is in the + -- evaluation environment, so that the shared library will stay open as long + -- as there are references to it. + , foreignSrcFPtr :: ForeignPtr () + -- | We support explicit unloading of the shared library so we keep track of + -- if it has already been unloaded, and if so the finalizer does nothing. + -- This is updated atomically when the library is unloaded. + , foreignSrcLoaded :: MVar Bool } + +instance Show ForeignSrc where + show = show . foreignSrcFPtr + +instance NFData ForeignSrc where + rnf ForeignSrc {..} = foreignSrcFPtr `seq` foreignSrcLoaded `deepseq` () + +-- | Get the file path of the 'ForeignSrc'. +getForeignSrcPath :: ForeignSrc -> Maybe FilePath +getForeignSrcPath = Just . foreignSrcPath + +-- | Load a 'ForeignSrc' for the given __Cryptol__ file path. The file path of +-- the shared library that we try to load is the same as the Cryptol file path +-- except with a platform specific extension. +loadForeignSrc :: FilePath -> IO (Either FFILoadError ForeignSrc) +loadForeignSrc = loadForeignLib >=> traverse \(foreignSrcPath, ptr) -> do + foreignSrcLoaded <- newMVar True + foreignSrcFPtr <- newForeignPtr ptr (unloadForeignSrc' foreignSrcLoaded ptr) + pure ForeignSrc {..} + + +-- | Given the path to a Cryptol module, compute the location of the shared +-- library we'd like to load. If FFI is supported, returns the location and +-- whether or not it actually exists on disk. Otherwise, returns Nothing. +foreignLibPath :: FilePath -> IO (Maybe (FilePath, Bool)) +foreignLibPath path = do + path' <- canonicalizePath path + let libPaths = map (path' -<.>) exts + search ps = + case ps of + [] -> pure ((, False) <$> listToMaybe libPaths) + p : more -> do + yes <- doesFileExist p + if yes then pure (Just (p, True)) else search more + search libPaths + where + exts = + case os of + "mingw32" -> ["dll"] + "darwin" -> ["dylib","so"] + _ -> ["so"] + +loadForeignLib :: FilePath -> IO (Either FFILoadError (FilePath, Ptr ())) +loadForeignLib path = + do mb <- foreignLibPath path + case mb of + Just (libPath, True) -> + tryLoad (CantLoadFFISrc path) (open libPath) + _ -> + pure (Left (CantLoadFFISrc path "File not found")) + + where open libPath = do +#if defined(mingw32_HOST_OS) + ptr <- loadLibrary libPath +#else + -- RTLD_NOW so we can make sure that the symbols actually exist at + -- module loading time + ptr <- undl <$> dlopen libPath [RTLD_NOW] +#endif + pure (libPath, ptr) + +-- | Explicitly unload a 'ForeignSrc' immediately instead of waiting for the +-- garbage collector to do it. This can be useful if you want to immediately +-- load the same library again to pick up new changes. +-- +-- The 'ForeignSrc' __must not__ be used in any way after this is called, +-- including calling 'ForeignImpl's loaded from it. +unloadForeignSrc :: ForeignSrc -> IO () +unloadForeignSrc ForeignSrc {..} = withForeignPtr foreignSrcFPtr $ + unloadForeignSrc' foreignSrcLoaded + +unloadForeignSrc' :: MVar Bool -> Ptr () -> IO () +unloadForeignSrc' loaded lib = modifyMVar_ loaded \l -> do + when l $ unloadForeignLib lib + pure False + +unloadForeignLib :: Ptr () -> IO () +#if defined(mingw32_HOST_OS) +unloadForeignLib = freeLibrary +#else +unloadForeignLib = dlclose . DLHandle +#endif + +withForeignSrc :: ForeignSrc -> (Ptr () -> IO a) -> IO a +withForeignSrc ForeignSrc {..} f = withMVar foreignSrcLoaded + \case + True -> withForeignPtr foreignSrcFPtr f + False -> + panic "[FFI] withForeignSrc" ["Use of foreign library after unload"] + +-- | An implementation of a foreign function. +data ForeignImpl = ForeignImpl + { foreignImplFun :: FunPtr () + -- | We don't need this to call the function but we want to keep the library + -- around as long as we still have a function from it so that it isn't + -- unloaded too early. + , foreignImplSrc :: ForeignSrc + } + +-- | Load a 'ForeignImpl' with the given name from the given 'ForeignSrc'. +loadForeignImpl :: ForeignSrc -> String -> IO (Either FFILoadError ForeignImpl) +loadForeignImpl foreignImplSrc name = + withForeignSrc foreignImplSrc \lib -> + tryLoad (CantLoadFFIImpl name) do + foreignImplFun <- loadForeignFunPtr lib name + pure ForeignImpl {..} + +loadForeignFunPtr :: Ptr () -> String -> IO (FunPtr ()) +#if defined(mingw32_HOST_OS) +loadForeignFunPtr source symbol = do + addr <- getProcAddress source symbol + pure $ castPtrToFunPtr addr +#else +loadForeignFunPtr = dlsym . DLHandle +#endif + +tryLoad :: (String -> FFILoadError) -> IO a -> IO (Either FFILoadError a) +tryLoad err = fmap (first $ err . displayException) . tryIOError + +-- | Types which can be converted into libffi arguments. +-- +-- The Storable constraint is so that we can put them in arrays. +class Storable a => FFIArg a where + ffiArg :: a -> Arg + +instance FFIArg Word8 where + ffiArg = argWord8 + +instance FFIArg Word16 where + ffiArg = argWord16 + +instance FFIArg Word32 where + ffiArg = argWord32 + +instance FFIArg Word64 where + ffiArg = argWord64 + +instance FFIArg CFloat where + ffiArg = argCFloat + +instance FFIArg CDouble where + ffiArg = argCDouble + +instance FFIArg (Ptr a) where + ffiArg = argPtr + +instance FFIArg CSize where + ffiArg = argCSize + +-- | Types which can be returned from libffi. +-- +-- The Storable constraint is so that we can put them in arrays. +class Storable a => FFIRet a where + ffiRet :: RetType a + +instance FFIRet Word8 where + ffiRet = retWord8 + +instance FFIRet Word16 where + ffiRet = retWord16 + +instance FFIRet Word32 where + ffiRet = retWord32 + +instance FFIRet Word64 where + ffiRet = retWord64 + +instance FFIRet CFloat where + ffiRet = retCFloat + +instance FFIRet CDouble where + ffiRet = retCDouble + +instance FFIRet () where + ffiRet = retVoid + +-- | Existential wrapper around a 'FFIArg'. +data SomeFFIArg = forall a. FFIArg a => SomeFFIArg a + +-- | Call a 'ForeignImpl' with the given arguments. The type parameter decides +-- how the return value should be converted into a Haskell value. +callForeignImpl :: forall a. FFIRet a => ForeignImpl -> [SomeFFIArg] -> IO a +callForeignImpl ForeignImpl {..} xs = withForeignSrc foreignImplSrc \_ -> + callFFI foreignImplFun (ffiRet @a) $ map toArg xs + where toArg (SomeFFIArg x) = ffiArg x + +#else + +data ForeignSrc = ForeignSrc deriving (Show, Generic, NFData) + +getForeignSrcPath :: ForeignSrc -> Maybe FilePath +getForeignSrcPath _ = Nothing + +loadForeignSrc :: FilePath -> IO (Either FFILoadError ForeignSrc) +loadForeignSrc _ = pure $ Right ForeignSrc + +unloadForeignSrc :: ForeignSrc -> IO () +unloadForeignSrc _ = pure () + +foreignLibPath :: FilePath -> IO (Maybe (FilePath, Bool)) +foreignLibPath _ = pure Nothing + +#endif diff --git a/src/Cryptol/Eval/FFI/GenHeader.hs b/src/Cryptol/Eval/FFI/GenHeader.hs --- a/src/Cryptol/Eval/FFI/GenHeader.hs +++ b/src/Cryptol/Eval/FFI/GenHeader.hs @@ -21,6 +21,7 @@ import Cryptol.ModuleSystem.Name import Cryptol.TypeCheck.FFI.FFIType import Cryptol.TypeCheck.Type +import Cryptol.TypeCheck.AST(FFI(..)) import Cryptol.Utils.Ident import Cryptol.Utils.RecordMap @@ -32,7 +33,7 @@ type GenHeaderM = Writer (Set Include) -- | Generate a C header file from the given foreign declarations. -generateForeignHeader :: [(Name, FFIFunType)] -> String +generateForeignHeader :: [(Name, FFI)] -> String generateForeignHeader decls = unlines (map renderInclude $ Set.toAscList incs) ++ Pretty.render (C.pretty $ C.translate (C.TransUnit cdecls [])) @@ -53,30 +54,47 @@ -- for both Cryptol parameter and return type cases. -- | Convert a Cryptol foreign declaration into a C function declaration. -convertFun :: (Name, FFIFunType) -> GenHeaderM C.Decln -convertFun (fName, FFIFunType {..}) = do - let tpIdent = fmap nameIdent . tpName - typeParams <- traverse convertTypeParam (pickNames (map tpIdent ffiTParams)) - -- Name the input args in0, in1, etc - let inPrefixes = - case ffiArgTypes of - [_] -> ["in"] - _ -> ["in" ++ show @Integer i | i <- [0..]] - inParams <- convertMultiType In $ zip inPrefixes ffiArgTypes - (retType, outParams) <- convertType Out ffiRetType - <&> \case - Direct u -> (u, []) - -- Name the output arg out - Params ps -> (C.TypeSpec C.Void, map (prefixParam "out") ps) - -- Avoid possible name collisions - let params = snd $ mapAccumL renameParam Set.empty $ - typeParams ++ inParams ++ outParams - renameParam names (C.Param u name) = - (Set.insert name' names, C.Param u name') - where name' = until (`Set.notMember` names) (++ "_") name - pure $ C.FunDecln Nothing retType (unpackIdent $ nameIdent fName) params +convertFun :: (Name, FFI) -> GenHeaderM C.Decln +convertFun (fName, cc) = + case cc of + CallAbstract {} -> do + tell $ Set.singleton cryFfiH + let mkAbstractParam :: C.Ident -> C.Ident -> C.Param + mkAbstractParam structName paramName = + C.Param (C.Const (C.Ptr (C.TypeSpec (C.Struct structName)))) paramName + params :: [C.Param] + params = + [ mkAbstractParam "CryValExporter" "args" + , mkAbstractParam "CryValImporter" "res" + ] + pure $ C.FunDecln Nothing (C.TypeSpec C.Void) fIdent params + CallC FFIFunType {..} -> do + let tpIdent = fmap nameIdent . tpName + typeParams <- traverse convertTypeParam (pickNames (map tpIdent ffiTParams)) + -- Name the input args in0, in1, etc + let inPrefixes = + case ffiArgTypes of + [_] -> ["in"] + _ -> ["in" ++ show @Integer i | i <- [0..]] + inParams <- convertMultiType In $ zip inPrefixes ffiArgTypes + (retType, outParams) <- convertType Out ffiRetType + <&> \case + Direct u -> (u, []) + -- Name the output arg out + Params ps -> (C.TypeSpec C.Void, map (prefixParam "out") ps) + -- Avoid possible name collisions + let params = snd $ mapAccumL renameParam Set.empty $ + typeParams ++ inParams ++ outParams + renameParam names (C.Param u name) = + (Set.insert name' names, C.Param u name') + where name' = until (`Set.notMember` names) (++ "_") name + pure $ C.FunDecln Nothing retType fIdent params + where + fIdent :: C.Ident + fIdent = unpackIdent $ nameIdent fName + -- | Convert a Cryptol type parameter to a C value parameter. convertTypeParam :: String -> GenHeaderM C.Param convertTypeParam name = (`C.Param` name) <$> sizeT @@ -170,6 +188,8 @@ stdintH = Include "stdint.h" gmpH = Include "gmp.h" +cryFfiH :: Include +cryFfiH = Include "cry_ffi.h" -- | Return a type with the given name, included from some header file. typedefFromInclude :: Include -> C.Ident -> GenHeaderM C.Type diff --git a/src/Cryptol/Eval/Type.hs b/src/Cryptol/Eval/Type.hs --- a/src/Cryptol/Eval/Type.hs +++ b/src/Cryptol/Eval/Type.hs @@ -9,6 +9,7 @@ {-# LANGUAGE PatternGuards #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +{-# Language OverloadedStrings #-} {-# LANGUAGE DeriveTraversable #-} module Cryptol.Eval.Type where @@ -18,12 +19,12 @@ import Cryptol.Backend.Monad (evalPanic) import Cryptol.ModuleSystem.Name(nameIdent) import Cryptol.TypeCheck.AST -import Cryptol.TypeCheck.PP(pp) import Cryptol.TypeCheck.Solver.InfNat import Cryptol.Utils.Panic (panic) import Cryptol.Utils.Ident (Ident) import Cryptol.Utils.RecordMap import Cryptol.Utils.Types +import Cryptol.Utils.PP import Data.Maybe(fromMaybe) import qualified Data.IntMap.Strict as IntMap @@ -243,3 +244,41 @@ where mb = fromMaybe (evalPanic "evalTF" ["type cannot be demoted", show (pp ty)]) ty = TCon (TF f) (map tNat' vs) + +instance PP TValue where + ppPrec = ppPrecWithAnnot [] + + ppPrecWithAnnot ns n tv = + annot $ + case tv of + TVBit -> "Bit" + TVInteger -> "Integer" + TVFloat e p -> wrapAfter 1 ("Float" <+> integer e <+> integer p) + TVIntMod m -> wrapAfter 1 ("Z" <+> integer m) + TVRational -> "Rational" + TVArray a b -> wrapAfter 1 ("Array" <+> pp2 0 a <+> pp2 1 b) + TVSeq m v -> + case v of + TVBit -> brackets (integer m) + _ -> wrapAfter 2 (brackets (integer m) <.> pp2 0 v) + TVStream v -> wrapAfter 2 ("[inf]" <.> pp2 0 v) + TVTuple ts -> parens (commaSep (zipWith pp0 [0..] ts)) + TVRec mp -> braces (commaSep [ pp x <.> ":" <+> pp0 i y | (i,(x,y)) <- [0..] `zip` displayFields mp ]) + TVFun a b -> wrapAfter 0 (fsep [ pp1 0 a, "->", pp0 1 b ]) + TVNominal nt args _ -> + let nm = pp (ntName nt) in + case args of + [] -> nm + _ -> wrapAfter 1 (fsep (nm : zipWith (either ppNat . pp2) [0..] args)) + where + annot d = foldr annotate d [ a | ([], a) <- ns ] + goSub i = [ (as, ann) | (a : as, ann) <- ns, a == i ] + + wrapAfter m = if n > m then parens else id + pp0 i = ppPrecWithAnnot (goSub i) 0 + pp1 i = ppPrecWithAnnot (goSub i) 1 + pp2 i = ppPrecWithAnnot (goSub i) 2 + ppNat na = + case na of + Inf -> "inf" + Nat m -> integer m diff --git a/src/Cryptol/IR/Builder.hs b/src/Cryptol/IR/Builder.hs new file mode 100644 --- /dev/null +++ b/src/Cryptol/IR/Builder.hs @@ -0,0 +1,141 @@ +module Cryptol.IR.Builder + ( + -- * Using built-ins + makePrim, + prelPrim, + floatPrim, + + -- * Helpers + number, + char, + string, + + -- * Types + TParam, + AST.Schema(..), + Type, + Kind(..), + + -- ** Numeric types + AST.tNum, + AST.tInf, + + -- ** Value types + AST.tBit, + AST.tInteger, + AST.tRational, + AST.tFloat, + AST.tIntMod, + AST.tWord, + AST.tSeq, + AST.tChar, + AST.tString, + AST.tRec, + AST.tTuple, + AST.tFun, + AST.tNominal, + + -- * Name Generation + newSchemaParam, + newTopNameIn, + newTopName, + newLocalName, + + + ) where + + +import Data.Text(Text) + +import qualified Cryptol.Parser.Position as Position +import Cryptol.Utils.Ident(PrimIdent,Ident,ModPath(..)) +import qualified Cryptol.Utils.Ident as Ident +import Cryptol.TypeCheck.AST(Expr(..), Type, Kind(..), TParam(..)) +import qualified Cryptol.TypeCheck.AST as AST +import qualified Cryptol.TypeCheck.Monad as TCM +import Cryptol.ModuleSystem.Monad(ModuleM) +import qualified Cryptol.ModuleSystem.Monad as M +import Cryptol.ModuleSystem.Name(Name,Namespace(..)) +import qualified Cryptol.ModuleSystem.Name as Name +import qualified Cryptol.ModuleSystem.Base as Base + + + + +-------------------------------------------------------------------------------- +-- Working with Primitives +-------------------------------------------------------------------------------- + +-- | Helper for making primtiives +withPrimMap :: (Name.PrimMap -> a) -> ModuleM a +withPrimMap k = k <$> Base.getPrimMap + +-- | Lookup a value level primitive +makePrim :: PrimIdent -> ModuleM Expr +makePrim p = withPrimMap (\pm -> AST.ePrim pm p) + +-- | Lookup a value level primitive from module `Cryptol` +prelPrim :: Text -> ModuleM Expr +prelPrim = makePrim . Ident.prelPrim + +-- | Lookup a value level primtitive from module `Float` +floatPrim :: Text -> ModuleM Expr +floatPrim = makePrim . Ident.floatPrim + +-- | Create a numeric literal +number :: Integer -> Type -> ModuleM Expr +number n t = withPrimMap (\pm -> AST.eNumber pm n t) + +-- | Create a character literal +char :: Char -> ModuleM Expr +char c = withPrimMap (\pm -> AST.eChar pm c) + +-- | Create a string literal +string :: String -> ModuleM Expr +string s = withPrimMap (\pm -> AST.eString pm s) + + + +-------------------------------------------------------------------------------- +-- Name generation +-------------------------------------------------------------------------------- + +-- | Generate a fresh top-level name in the given namespace +newTopNameIn :: Namespace -> ModPath -> Ident -> ModuleM Name +newTopNameIn ns mpath i = + Name.liftSupply + (Name.mkDeclared ns mpath Name.SystemName i Nothing Position.emptyRange) + +-- | Generate a fresh top-level name in the value namespace +newTopName :: ModPath -> Ident -> ModuleM Name +newTopName = newTopNameIn NSValue + +-- | Generate a fresh local name in the value name space +newLocalName :: Ident -> ModuleM Name +newLocalName i = + Name.liftSupply (Name.mkLocal Name.SystemName NSValue i Position.emptyRange) + +-- | Generate a fresh type binder to be used in the type signature for the +-- given name. +newSchemaParam :: Name -> Kind -> ModuleM TParam +newSchemaParam nm k = + do + tcnames <- M.getNameSeeds + let u = TCM.seedTVar tcnames + let tp = + TParam { + tpUnique = u, + tpKind = k, + tpFlav = AST.TPSchemaParam nm, + tpInfo = + AST.TVarInfo { + AST.tvarDesc = AST.TVFromSignature nm, + AST.tvarSource = Position.emptyRange + } + } + M.setNameSeeds tcnames { TCM.seedTVar = u + 1 } + pure tp + + + +-------------------------------------------------------------------------------- diff --git a/src/Cryptol/IR/FreeVars.hs b/src/Cryptol/IR/FreeVars.hs --- a/src/Cryptol/IR/FreeVars.hs +++ b/src/Cryptol/IR/FreeVars.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE InstanceSigs #-} module Cryptol.IR.FreeVars ( FreeVars(..) , Deps(..) @@ -11,6 +12,7 @@ import qualified Data.Map as Map import Cryptol.TypeCheck.AST +import Cryptol.TypeCheck.FFI.FFIType import Cryptol.Utils.Panic ( panic ) import Cryptol.Utils.RecordMap @@ -102,11 +104,19 @@ instance FreeVars DeclDef where + freeVars :: DeclDef -> Deps freeVars d = case d of DPrim -> mempty - DForeign _ me -> foldMap freeVars me + DForeign t me -> freeVars t <> foldMap freeVars me DExpr e -> freeVars e +instance FreeVars FFI where + freeVars c = + case c of + CallC _ -> mempty + CallAbstract t -> + let vs = freeVars (ffiArgTypes t) <> freeVars (ffiRetType t) + in foldr rmTParam vs (ffiTParams t) instance FreeVars Expr where freeVars expr = diff --git a/src/Cryptol/IR/Prove.hs b/src/Cryptol/IR/Prove.hs new file mode 100644 --- /dev/null +++ b/src/Cryptol/IR/Prove.hs @@ -0,0 +1,59 @@ +module Cryptol.IR.Prove + ( satProve, + QueryType(..), + SatNum(..), + ProverResult(..), + SatResult, + CounterExampleType(..), + Concrete.Value, + TValue(..), + GenValue(..) + ) where + +import Data.IORef(newIORef) + +import Cryptol.Utils.Panic(panic) +import Cryptol.TypeCheck.AST(Type,DeclGroup,Expr,tMono) +import Cryptol.ModuleSystem.Monad(ModuleM) +import qualified Cryptol.ModuleSystem.Monad as M + +import Cryptol.Symbolic +import qualified Cryptol.Symbolic.What4 as W4 +import qualified Cryptol.Eval.Concrete as Concrete +import Cryptol.Eval.Type(TValue(..)) +import Cryptol.Eval.Value(GenValue(..)) + + +-- | Use an SMT solver to check if an expression is satisifiable +satProve :: + [DeclGroup] {-^ Additional definitions -} -> + Expr {-^ The expression we are examining -} -> + Type {-^ The type of the expression to examine -} -> + Int {-^ Timeout in seconds -} -> + ModuleM [SatResult] + {- ^ A list of possible models (lazy). Empty if no models were found. -} +satProve decls expr exprType timeoutSec = + do + timing <- M.io (newIORef 0) + let + cmd = + ProverCommand { + pcQueryType = SatQuery AllSat, + pcProverName = "z3", + pcVerbose = False, + pcValidate = True, + pcProverStats = timing, + pcExtraDecls = decls, + pcSmtFile = Nothing, + pcExpr = expr, + pcSchema = tMono exprType, + pcIgnoreSafety = False + } + res <- snd <$> M.doModuleCmd (W4.satProve W4.defaultProver False True timeoutSec cmd) + case res of + AllSatResult xs -> pure xs + ThmResult {} -> pure [] + CounterExample {} -> panic "satProve" ["Unexpected CounterExample"] + EmptyResult -> panic "satProve" ["Unexpecetd EmptyResult"] + ProverError d -> fail (show d) + diff --git a/src/Cryptol/IR/TraverseNames.hs b/src/Cryptol/IR/TraverseNames.hs --- a/src/Cryptol/IR/TraverseNames.hs +++ b/src/Cryptol/IR/TraverseNames.hs @@ -121,6 +121,12 @@ DForeign t me -> DForeign <$> traverseNamesIP t <*> traverseNamesIP me DExpr e -> DExpr <$> traverseNamesIP e +instance TraverseNames FFI where + traverseNamesIP f = + case f of + CallC t -> CallC <$> traverseNamesIP t + CallAbstract t -> CallAbstract <$> traverseNamesIP t + instance TraverseNames Schema where traverseNamesIP (Forall as ps t) = Forall <$> traverseNamesIP as @@ -244,7 +250,7 @@ where mk x t = nt { mvpName = x, mvpType = t } -instance TraverseNames FFIFunType where +instance TraverseNames t => TraverseNames (FFIFunType t) where traverseNamesIP fi = mk <$> traverseNamesIP (ffiArgTypes fi) <*> traverseNamesIP (ffiRetType fi) where diff --git a/src/Cryptol/ModuleSystem.hs b/src/Cryptol/ModuleSystem.hs --- a/src/Cryptol/ModuleSystem.hs +++ b/src/Cryptol/ModuleSystem.hs @@ -70,14 +70,13 @@ -- | Find the file associated with a module name in the module search path. findModule :: P.ModName -> ModuleCmd ModulePath -findModule n env = runModuleM env (Base.findModule n) +findModule n env = runModuleM env (Base.findModule (FromModule n) n) -- | Load the module contained in the given file. loadModuleByPath :: FilePath -> ModuleCmd (ModulePath,T.TCTopEntity) loadModuleByPath path minp = do moduleEnv' <- resetModuleEnv $ minpModuleEnv minp runModuleM minp{ minpModuleEnv = moduleEnv' } $ do - unloadModule ((InFile path ==) . lmFilePath) m <- Base.loadModuleByPath True path setFocusedModule (P.ImpTop (T.tcTopEntitytName m)) return (InFile path,m) @@ -87,7 +86,6 @@ loadModuleByName n minp = do moduleEnv' <- resetModuleEnv $ minpModuleEnv minp runModuleM minp{ minpModuleEnv = moduleEnv' } $ do - unloadModule ((n ==) . lmName) (path,m') <- Base.loadModuleFrom False (FromModule n) setFocusedModule (P.ImpTop (T.tcTopEntitytName m')) return (path,m') diff --git a/src/Cryptol/ModuleSystem/Base.hs b/src/Cryptol/ModuleSystem/Base.hs --- a/src/Cryptol/ModuleSystem/Base.hs +++ b/src/Cryptol/ModuleSystem/Base.hs @@ -60,7 +60,7 @@ , ModContext(..), ModContextParams(..) , ModulePath(..), modulePathLabel , EvalForeignPolicy (..)) -import Cryptol.Backend.FFI +import Cryptol.Eval.FFI.ForeignSrc import qualified Cryptol.Eval as E import qualified Cryptol.Eval.Concrete as Concrete import Cryptol.Eval.Concrete (Concrete(..)) @@ -79,7 +79,7 @@ import qualified Cryptol.TypeCheck.AST as T import qualified Cryptol.TypeCheck.PP as T import qualified Cryptol.TypeCheck.Sanity as TcSanity -import qualified Cryptol.Backend.FFI.Error as FFI +import qualified Cryptol.Eval.FFI.Error as FFI import Cryptol.Utils.Ident ( preludeName, floatName, arrayName, suiteBName, primeECName , preludeReferenceName, interactiveName, modNameChunks @@ -268,7 +268,7 @@ case mb of Just m -> return (lmFilePath m, lmData m) Nothing -> - do path <- findModule n + do path <- findModule isrc n errorInFile path $ do (fp, deps, pms) <- parseModule path ms <- mapM (loadModuleAndDeps True quiet isrc path fp deps) pms @@ -310,7 +310,7 @@ ("Loading " ++ what ++ " " ++ pretty (P.thing (P.mName pm))) - (nameEnv,tcm) <- checkModule isrc pm + (nameEnv,tcm,renMod) <- checkModule isrc pm -- extend the eval env, unless a functor. tbl <- Concrete.primTable <$> getEvalOptsAction @@ -330,7 +330,9 @@ Nothing -> pure Nothing let fi = fileInfo fp incDeps impDeps foreignSrc - loadedModule path fi nameEnv foreignSrc tcm + saveRen <- getSaveRenamed + loadedModule path fi nameEnv foreignSrc tcm $! + if saveRen then Just renMod else Nothing return (tcm, fi) @@ -386,15 +388,15 @@ -- -- > import foo as foo [ [hiding] (a,b,c) ] fullyQualified :: P.Import -> P.Import -fullyQualified i = i { iAs = Just (iModule i) } +fullyQualified i = i { iAs = Just (thing (iModule i)) } moduleFile :: ModName -> String -> FilePath moduleFile n = addExtension (joinPath (modNameChunks n)) -- | Discover a module. -findModule :: ModName -> ModuleM ModulePath -findModule n = do +findModule :: ImportSource -> ModName -> ModuleM ModulePath +findModule isrc n = do paths <- getSearchPath loop (possibleFiles paths) where @@ -414,7 +416,7 @@ | m == suiteBName -> pure (InMem "SuiteB" suiteBContents) | m == primeECName -> pure (InMem "PrimeEC" primeECContents) | m == preludeReferenceName -> pure (InMem "Cryptol::Reference" preludeReferenceContents) - _ -> moduleNotFound n =<< getSearchPath + _ -> moduleNotFound isrc n =<< getSearchPath -- generate all possible search paths possibleFiles paths = do @@ -455,11 +457,11 @@ InterfaceModule s -> InterfaceModule s { sigImports = prel : sigImports s } - importedMods = map (P.iModule . P.thing) (P.mImports m) + importedMods = map (P.thing . P.iModule . P.thing) (P.mImports m) prel = P.Located { P.srcRange = emptyRange , P.thing = P.Import - { iModule = P.ImpTop preludeName + { iModule = Located emptyRange (P.ImpTop preludeName) , iAs = Nothing , iSpec = Nothing , iInst = Nothing @@ -480,7 +482,7 @@ findDepsOfModule :: ModName -> ModuleM (ModulePath, FileInfo) findDepsOfModule m = - do mpath <- findModule m + do mpath <- findModule (FromModule m) m findDepsOf mpath findDepsOf :: ModulePath -> ModuleM (ModulePath, FileInfo) @@ -547,8 +549,8 @@ ImpTop f -> loadI (src l { thing = f }) _ -> mempty - loadImpD li = loadImpName (FromImport . new) (iModule <$> li) - where new i = i { thing = (thing li) { iModule = thing i } } + loadImpD li = loadImpName (FromImport . new) (thing . iModule <$> li) + where new i = i { thing = (thing li) { iModule = i } } loadNamedInstArg (ModuleInstanceNamedArg _ f) = loadInstArg f loadInstArg f = @@ -650,7 +652,7 @@ checkModule :: ImportSource {- ^ why are we loading this -} -> P.Module PName {- ^ module to check -} -> - ModuleM (R.NamingEnv,T.TCTopEntity) + ModuleM (R.NamingEnv,T.TCTopEntity, Module Name) checkModule isrc m = do -- check that the name of the module matches expectations @@ -697,7 +699,7 @@ T.TCTopModule mo -> T.mInScope mo -- Name env for signatures does not change after typechecking T.TCTopSignature {} -> mInScope (R.rmModule renMod) - pure (nameEnv,rewMod) + pure (nameEnv,rewMod, R.rmModule renMod) data TCLinter o = TCLinter { lintCheck :: diff --git a/src/Cryptol/ModuleSystem/Binds.hs b/src/Cryptol/ModuleSystem/Binds.hs --- a/src/Cryptol/ModuleSystem/Binds.hs +++ b/src/Cryptol/ModuleSystem/Binds.hs @@ -437,7 +437,7 @@ where src = if isGeneratedName thing then SystemName else UserName newLocal :: FreshM m => Namespace -> PName -> Range -> m Name -newLocal ns thing rng = liftSupply (mkLocal ns (getIdent thing) rng) +newLocal ns thing rng = liftSupply (mkLocalPName ns thing rng) -- | Given a name in a signature, make a name for the parameter corresponding -- to the signature. diff --git a/src/Cryptol/ModuleSystem/Env.hs b/src/Cryptol/ModuleSystem/Env.hs --- a/src/Cryptol/ModuleSystem/Env.hs +++ b/src/Cryptol/ModuleSystem/Env.hs @@ -14,13 +14,14 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} + module Cryptol.ModuleSystem.Env where #ifndef RELOCATABLE import Paths_cryptol (getDataDir) #endif -import Cryptol.Backend.FFI (ForeignSrc, unloadForeignSrc, getForeignSrcPath) +import Cryptol.Eval.FFI.ForeignSrc(ForeignSrc, unloadForeignSrc, getForeignSrcPath) import Cryptol.Eval (EvalEnv) import qualified Cryptol.IR.FreeVars as T import Cryptol.ModuleSystem.Fingerprint @@ -32,7 +33,7 @@ import qualified Cryptol.TypeCheck.Interface as T import qualified Cryptol.TypeCheck.AST as T import qualified Cryptol.Utils.Ident as I -import Cryptol.Utils.PP (PP(..),text,parens,NameDisp) +import Cryptol.Utils.PP (pp, PP(..),text,parens,NameDisp) import Data.ByteString(ByteString) import Control.Monad (guard,mplus) @@ -57,7 +58,6 @@ import Prelude.Compat import Cryptol.Utils.Panic(panic) -import Cryptol.Utils.PP(pp) -- Module Environment ---------------------------------------------------------- @@ -182,8 +182,8 @@ , meNameSeeds = T.nameSeeds , meEvalEnv = mempty , meFocusedModule = Nothing - -- we search these in order, taking the first match , meSearchPath = searchPath + -- ^ we search these in order, taking the first match , meDynEnv = mempty , meMonoBinds = True , meCoreLint = NoCoreLint @@ -192,6 +192,8 @@ } -- | Try to focus a loaded module in the module environment. +-- FIXME: This function is dead code. +-- (And confusingly, there is another function of same name.) focusModule :: ImpName Name -> ModuleEnv -> Maybe ModuleEnv focusModule n me = do guard (isLoaded n (meLoadedModules me)) @@ -208,9 +210,12 @@ loadedNonParamModules :: ModuleEnv -> [T.Module] loadedNonParamModules = map lmModule . lmLoadedModules . meLoadedModules +-- | Get a 'Map' of all the loaded nominal types, where the keys of the 'Map' +-- are the 'Name's of each nominal type. +-- Note that this includes parameterized modules. loadedNominalTypes :: ModuleEnv -> Map Name T.NominalType loadedNominalTypes menv = Map.unions - [ ifNominalTypes (ifDefines i) <> ifNominalTypes (ifDefines i) + [ ifNominalTypes (ifDefines i) | i <- map lmInterface (getLoadedModules (meLoadedModules menv)) ] @@ -246,7 +251,7 @@ } -- This instance is a bit bogus. It is mostly used to add the dynamic --- environemnt to an existing module, and it makes sense for that use case. +-- environment to an existing module, and it makes sense for that use case. instance Semigroup ModContext where x <> y = ModContext { mctxParams = jnPs (mctxParams x) (mctxParams y) , mctxExported = mctxExported x <> mctxExported y @@ -274,7 +279,8 @@ findEnv :: Name -> Iface -> T.ModuleG a -> Maybe (R.NamingEnv, Set Name) findEnv n iface m - | Just sm <- Map.lookup n (T.mSubmodules m) = Just (T.smInScope sm, ifsPublic (T.smIface sm)) + | Just sm <- Map.lookup n (T.mSubmodules m) = + Just (T.smInScope sm, ifsPublic (T.smIface sm)) | Just fn <- Map.lookup n (T.mFunctors m) = case Map.lookup n (ifFunctors (ifDefines iface)) of Nothing -> panic "findEnv" ["Submodule functor not present in interface"] @@ -283,8 +289,10 @@ modContextOf :: ImpName Name -> ModuleEnv -> Maybe ModContext modContextOf (ImpNested name) me = - do mname <- nameTopModuleMaybe name + do -- find the top module: + mname <- nameTopModuleMaybe name lm <- lookupModule mname me + (localNames, exported) <- findEnv name (lmInterface lm) (lmModule lm) let -- XXX: do we want only public ones here? loadedDecls = map (ifDefines . lmInterface) @@ -297,41 +305,54 @@ , mctxNameDisp = R.toNameDisp localNames } -- TODO: support focusing inside a submodule signature to support browsing? - modContextOf (ImpTop mname) me = do lm <- lookupModule mname me - let localIface = lmInterface lm - localNames = lmNamingEnv lm - - -- XXX: do we want only public ones here? - loadedDecls = map (ifDefines . lmInterface) - $ getLoadedModules (meLoadedModules me) - - params = ifParams localIface - pure ModContext - { mctxParams = if Map.null params then NoParams - else FunctorParams params - , mctxExported = ifsPublic (ifNames localIface) - , mctxDecls = mconcat (ifDefines localIface : loadedDecls) - , mctxNames = localNames - , mctxNameDisp = R.toNameDisp localNames - } + pure (lmModContext me lm) `mplus` do lm <- lookupSignature mname me - let localNames = lmNamingEnv lm - -- XXX: do we want only public ones here? - loadedDecls = map (ifDefines . lmInterface) - $ getLoadedModules (meLoadedModules me) - pure ModContext - { mctxParams = InterfaceParams (lmData lm) - , mctxExported = Set.empty - , mctxDecls = mconcat loadedDecls - , mctxNames = localNames - , mctxNameDisp = R.toNameDisp localNames - } + pure (lmSignatureContext me lm) +-- | Find all normal modules named `Main` +mainContexts :: ModuleEnv -> [ModContext] +mainContexts me = lmModContext me <$> lookupMainModules me +lmModContext :: ModuleEnv -> LoadedModule -> ModContext +lmModContext me lm = + let localIface = lmInterface lm + localNames = lmNamingEnv lm + + -- XXX: do we want only public ones here? + loadedDecls = map (ifDefines . lmInterface) + $ getLoadedModules (meLoadedModules me) + + params = ifParams localIface + in + ModContext + { mctxParams = if Map.null params then NoParams + else FunctorParams params + , mctxExported = ifsPublic (ifNames localIface) + , mctxDecls = mconcat (ifDefines localIface : loadedDecls) + , mctxNames = localNames + , mctxNameDisp = R.toNameDisp localNames + } + +lmSignatureContext :: ModuleEnv -> LoadedSignature -> ModContext +lmSignatureContext me lm = + let localNames = lmNamingEnv lm + -- XXX: do we want only public ones here? + loadedDecls = map (ifDefines . lmInterface) + $ getLoadedModules (meLoadedModules me) + in + ModContext + { mctxParams = InterfaceParams (lmData lm) + , mctxExported = Set.empty + , mctxDecls = mconcat loadedDecls + , mctxNames = localNames + , mctxNameDisp = R.toNameDisp localNames + } + + dynModContext :: ModuleEnv -> ModContext dynModContext me = mempty { mctxNames = dynNames , mctxNameDisp = R.toNameDisp dynNames @@ -340,19 +361,31 @@ where dynNames = deNames (meDynEnv me) - - --- | Given the state of the environment, compute information about what's --- in scope on the REPL. This includes what's in the focused module, plus any --- additional definitions from the REPL (e.g., let bound names, and @it@). +-- | focusedEnv me - Given 'me', the state of the environment, compute +-- information about what's in scope on the REPL. This includes +-- what's in the focused module (`meFocusedModule me`), plus any +-- additional definitions from the REPL (e.g., let bound names, and +-- @it@). focusedEnv :: ModuleEnv -> ModContext -focusedEnv me = - case meFocusedModule me of +focusedEnv me = focusedEnv' (meFocusedModule me) me + +-- | focusedEnv' mfm me - Given 'me' (the state of the environment), +-- compute information about what's in scope on the REPL. It also +-- includes additional definitions from the REPL (e.g., let bound +-- names, and @it@). +-- +-- In contrast to `focusedEnv`, +-- - it does not include (`meFocusedModule me`) +-- - it optionally includes 'mfm' +-- +focusedEnv' :: Maybe (ImpName Name) -> ModuleEnv -> ModContext +focusedEnv' mFocusedModule me = + case mFocusedModule of Nothing -> dynModContext me Just fm -> case modContextOf fm me of Just c -> dynModContext me <> c - Nothing -> panic "focusedEnv" - [ "Focused modules not loaded: " ++ show (pp fm) ] + Nothing -> panic "focusedEnv'" + ["Focused module not loaded: " ++ show (pp fm)] -- Loaded Modules -------------------------------------------------------------- @@ -423,6 +456,13 @@ [ (lmName x, ALoadedFunctor x) | x <- lmLoadedParamModules lm ] ++ [ (lmName x, ALoadedInterface x) | x <- lmLoadedSignatures lm ] +withLoadedEntity :: LoadedEntity -> (forall a. LoadedModuleG a -> b) -> b +withLoadedEntity ent k = + case ent of + ALoadedModule lm -> k lm + ALoadedFunctor lm -> k lm + ALoadedInterface lm -> k lm + getLoadedModules :: LoadedModules -> [LoadedModule] getLoadedModules x = lmLoadedParamModules x ++ lmLoadedModules x @@ -433,12 +473,24 @@ ++ map f (lmLoadedParamModules lm) ++ map f (lmLoadedSignatures lm) +getLoadedFieldMap :: Ord k => + (forall b. LoadedModuleG b -> (k,v)) -> LoadedModules -> Map k v +getLoadedFieldMap f lm = + Map.fromList + $ map f (lmLoadedModules lm) + ++ map f (lmLoadedParamModules lm) + ++ map f (lmLoadedSignatures lm) + + getLoadedNames :: LoadedModules -> Set ModName getLoadedNames = getLoadedField lmName getLoadedIds :: LoadedModules -> Set String getLoadedIds = getLoadedField lmModuleId +getLoadedFiles :: LoadedModules -> Map ModulePath FileInfo +getLoadedFiles = getLoadedFieldMap \lm -> (lmFilePath lm, lmFileInfo lm) + instance Semigroup LoadedModules where l <> r = LoadedModules { lmLoadedModules = List.unionBy ((==) `on` lmName) @@ -465,7 +517,7 @@ , lmModuleId :: String -- ^ An identifier used to identify the source of the bytes for the module. - -- For files we just use the cononical path, for in memory things we + -- For files we just use the canonical path, for in-memory things we -- use their label. , lmNamingEnv :: !R.NamingEnv @@ -473,6 +525,9 @@ , lmFileInfo :: !FileInfo + , lmRenamedModule :: Maybe (Module Name) + -- ^ The renamed AST, if we chose to save it + , lmData :: a } deriving (Show, Generic, NFData) @@ -507,7 +562,6 @@ check m = Map.member nn (T.mSubmodules m) || Map.member nn (T.mSignatures m) || - Map.member nn (T.mSubmodules m) || any check (T.mFunctors m) isLoadedStrict :: ImpName Name -> String -> LoadedModules -> Bool @@ -581,6 +635,12 @@ lookupModule :: ModName -> ModuleEnv -> Maybe LoadedModule lookupModule mn = lookupModuleWith ((mn ==) . lmName) +-- | Find all loaded `Main` modules +lookupMainModules :: ModuleEnv -> [LoadedModule] +lookupMainModules me = + [ lm | lm <- lmLoadedModules (meLoadedModules me), + "Main" == I.modNameToText (lmName lm) ] + lookupModuleWith :: (LoadedModule -> Bool) -> ModuleEnv -> Maybe LoadedModule lookupModuleWith p me = search lmLoadedModules `mplus` search lmLoadedParamModules @@ -594,13 +654,15 @@ (LoadedSignature -> Bool) -> ModuleEnv -> Maybe LoadedSignature lookupSignatureWith p me = List.find p (lmLoadedSignatures (meLoadedModules me)) + + addLoadedSignature :: ModulePath -> String -> FileInfo -> R.NamingEnv -> - ModName -> T.ModParamNames -> + ModName -> Maybe (Module T.Name) -> T.ModParamNames -> LoadedModules -> LoadedModules -addLoadedSignature path ident fi nameEnv nm si lm +addLoadedSignature path ident fi nameEnv nm rm si lm | isLoadedStrict (ImpTop nm) ident lm = lm | otherwise = lm { lmLoadedSignatures = loaded : lmLoadedSignatures lm } where @@ -611,6 +673,7 @@ , lmNamingEnv = nameEnv , lmData = si , lmFileInfo = fi + , lmRenamedModule = rm } -- | Add a freshly loaded module. If it was previously loaded, then @@ -621,8 +684,9 @@ FileInfo -> R.NamingEnv -> Maybe ForeignSrc -> + Maybe (Module T.Name) -> T.Module -> LoadedModules -> LoadedModules -addLoadedModule path ident fi nameEnv fsrc tm lm +addLoadedModule path ident fi nameEnv fsrc rm tm lm | isLoadedStrict (ImpTop (T.mName tm)) ident lm = lm | T.isParametrizedModule tm = lm { lmLoadedParamModules = loaded : lmLoadedParamModules lm } @@ -634,6 +698,7 @@ , lmFilePath = path , lmModuleId = ident , lmNamingEnv = nameEnv + , lmRenamedModule = rm , lmData = LoadedModuleData { lmdInterface = T.genIface tm , lmdModule = tm @@ -644,7 +709,7 @@ -- | Remove a previously loaded module. -- Note that this removes exactly the modules specified by the predicate. --- One should be carfule to preserve the invariant on 'LoadedModules'. +-- One should be careful to preserve the invariant on 'LoadedModules'. removeLoadedModule :: (forall a. LoadedModuleG a -> Bool) -> LoadedModules -> LoadedModules removeLoadedModule rm lm = @@ -683,6 +748,8 @@ } + + -- Dynamic Environments -------------------------------------------------------- -- | Extra information we need to carry around to dynamically extend @@ -733,3 +800,4 @@ | decl <- concatMap T.groupDecls dgs , let ifd = T.mkIfaceDecl decl ] + diff --git a/src/Cryptol/ModuleSystem/Interface.hs b/src/Cryptol/ModuleSystem/Interface.hs --- a/src/Cryptol/ModuleSystem/Interface.hs +++ b/src/Cryptol/ModuleSystem/Interface.hs @@ -53,11 +53,11 @@ type Iface = IfaceG ModName --- | The interface repersenting a typecheck top-level module. +-- | The interface representing a typechecked top-level module. data IfaceG name = Iface { ifNames :: IfaceNames name -- ^ Info about names in this module , ifParams :: FunctorParams -- ^ Module parameters, if any - , ifDefines :: IfaceDecls -- ^ All things defines in the module + , ifDefines :: IfaceDecls -- ^ All things defined in the module -- (includes nested definitions) } deriving (Show, Generic, NFData, Functor) @@ -106,7 +106,7 @@ , ifSignatures :: !(Map.Map Name ModParamNames) , ifFunctors :: !(Map.Map Name (IfaceG Name)) {- ^ XXX: Maybe arg info? - Also, with the current implementation we aim to complete remove functors + Also, with the current implementation we aim to completely remove functors by essentially inlining them. To achieve this with just interfaces we'd have to store here the entire module, not just its interface. At the moment we work around this by passing all loaded modules to the @@ -211,7 +211,7 @@ types = map entry (Map.keys ifTySyns) --- | Given an interface computing a map from original names to actual names, +-- | Given an interface, compute a map from original names to actual names, -- grouped by namespace. ifaceOrigNameMap :: IfaceG name -> Map Namespace (Map OrigName Name) ifaceOrigNameMap ifa = Map.unionsWith Map.union (here : nested) diff --git a/src/Cryptol/ModuleSystem/Monad.hs b/src/Cryptol/ModuleSystem/Monad.hs --- a/src/Cryptol/ModuleSystem/Monad.hs +++ b/src/Cryptol/ModuleSystem/Monad.hs @@ -16,8 +16,8 @@ import Cryptol.Eval (EvalEnv,EvalOpts(..)) -import Cryptol.Backend.FFI (ForeignSrc) -import Cryptol.Backend.FFI.Error +import Cryptol.Eval.FFI.ForeignSrc (ForeignSrc) +import Cryptol.Eval.FFI.Error import qualified Cryptol.Backend.Monad as E import Cryptol.ModuleSystem.Env @@ -86,13 +86,13 @@ importedModule is = case is of FromModule n -> n - FromImport li -> P.iModule (P.thing li) + FromImport li -> P.thing (P.iModule (P.thing li)) FromModuleInstance l -> P.thing l FromSigImport l -> P.thing l data ModuleError - = ModuleNotFound P.ModName [FilePath] + = ModuleNotFound ImportSource P.ModName [FilePath] -- ^ Unable to find the module given, tried looking in these paths | CantFindFile FilePath -- ^ Unable to open a file @@ -132,7 +132,7 @@ instance NFData ModuleError where rnf e = case e of - ModuleNotFound src path -> src `deepseq` path `deepseq` () + ModuleNotFound is src path -> is `deepseq` src `deepseq` path `deepseq` () CantFindFile path -> path `deepseq` () BadUtf8 path fp ue -> rnf (path, fp, ue) OtherIOError path exn -> path `deepseq` exn `seq` () @@ -155,10 +155,14 @@ instance PP ModuleError where ppPrec prec e = case e of - ModuleNotFound src path -> + ModuleNotFound isrc src path -> text "[error]" <+> text "Could not find module" <+> pp src $$ + case isrc of + FromModule {} -> mempty + _ -> "arising from" <+> pp isrc + $$ hang (text "Searched paths:") 4 (vcat (map text path)) $$ @@ -216,8 +220,8 @@ ErrorInFile _ x -> ppPrec prec x -moduleNotFound :: P.ModName -> [FilePath] -> ModuleM a -moduleNotFound name paths = ModuleT (raise (ModuleNotFound name paths)) +moduleNotFound :: ImportSource -> P.ModName -> [FilePath] -> ModuleM a +moduleNotFound isrc name paths = ModuleT (raise (ModuleNotFound isrc name paths)) cantFindFile :: FilePath -> ModuleM a cantFindFile path = ModuleT (raise (CantFindFile path)) @@ -314,6 +318,7 @@ RO { roLoading :: [ImportSource] , roEvalOpts :: m EvalOpts , roCallStacks :: Bool + , roSaveRenamed :: Bool , roFileReader :: FilePath -> m ByteString , roTCSolver :: SMT.Solver } @@ -323,6 +328,7 @@ RO { roLoading = [] , roEvalOpts = minpEvalOpts minp , roCallStacks = minpCallStacks minp + , roSaveRenamed = minpSaveRenamed minp , roFileReader = minpByteReader minp , roTCSolver = minpTCSolver minp } @@ -374,6 +380,7 @@ data ModuleInput m = ModuleInput { minpCallStacks :: Bool + , minpSaveRenamed :: Bool , minpEvalOpts :: m EvalOpts , minpByteReader :: FilePath -> m ByteString , minpModuleEnv :: ModuleEnv @@ -426,6 +433,40 @@ setModuleEnv :: Monad m => ModuleEnv -> ModuleT m () setModuleEnv = ModuleT . set +getModuleInput :: ModuleM (ModuleInput IO) +getModuleInput = + do + cs <- getCallStacks + evo <- getEvalOptsAction + reader <- getByteReader + env <- getModuleEnv + solver <- getTCSolver + ren <- getSaveRenamed + pure + ModuleInput { + minpCallStacks = cs, + minpEvalOpts = evo, + minpByteReader = reader, + minpModuleEnv = env, + minpTCSolver = solver, + minpSaveRenamed = ren + } + +doModuleCmd :: (ModuleInput IO -> IO (Either ModuleError (a, ModuleEnv), [ModuleWarning])) -> ModuleM a +doModuleCmd cmd = + do + inp <- getModuleInput + (res,ws) <- io (cmd inp) + warn ws + case res of + Left err -> ModuleT (raise err) + Right (a,env) -> + do + setModuleEnv env + pure a + + + modifyModuleEnv :: Monad m => (ModuleEnv -> ModuleEnv) -> ModuleT m () modifyModuleEnv f = ModuleT $ do env <- get @@ -550,8 +591,9 @@ NamingEnv -> Maybe ForeignSrc -> T.TCTopEntity -> + Maybe (P.Module T.Name) -> ModuleM () -loadedModule path fi nameEnv fsrc m = ModuleT $ do +loadedModule path fi nameEnv fsrc m renMod = ModuleT $ do env <- get ident <- case path of InFile p -> unModuleT $ io (canonicalizePath p) @@ -559,8 +601,8 @@ let newLM = case m of - T.TCTopModule mo -> addLoadedModule path ident fi nameEnv fsrc mo - T.TCTopSignature x s -> addLoadedSignature path ident fi nameEnv x s + T.TCTopModule mo -> addLoadedModule path ident fi nameEnv fsrc renMod mo + T.TCTopSignature x s -> addLoadedSignature path ident fi nameEnv x renMod s set $! env { meLoadedModules = newLM (meLoadedModules env) } @@ -586,6 +628,9 @@ getEvalOpts = do act <- getEvalOptsAction liftIO act + +getSaveRenamed :: ModuleM Bool +getSaveRenamed = ModuleT (roSaveRenamed <$> ask) getNominalTypes :: ModuleM (Map T.Name T.NominalType) getNominalTypes = ModuleT (loadedNominalTypes <$> get) diff --git a/src/Cryptol/ModuleSystem/Name.hs b/src/Cryptol/ModuleSystem/Name.hs --- a/src/Cryptol/ModuleSystem/Name.hs +++ b/src/Cryptol/ModuleSystem/Name.hs @@ -26,10 +26,12 @@ , nameIdent , mapNameIdent , nameInfo + , nameSrc , nameLoc , nameFixity , nameNamespace , nameToDefPName + , nameToPNameWithQualifiers , asPrim , asOrigName , nameModPath @@ -44,6 +46,7 @@ -- ** Creation , mkDeclared , mkLocal + , mkLocalPName , asLocal , mkModParam @@ -80,7 +83,7 @@ import Cryptol.Utils.PP data NameInfo = GlobalName NameSource OrigName - | LocalName Namespace Ident + | LocalName NameSource Namespace Ident deriving (Generic, NFData, Show) -- Names ----------------------------------------------------------------------- @@ -175,7 +178,7 @@ ppName nm = case nInfo nm of GlobalName _ og -> pp og - LocalName _ i -> pp i + LocalName _ _ i -> pp i <.> withPPCfg \cfg -> if ppcfgShowNameUniques cfg then "_" <.> int (nameUnique nm) @@ -208,21 +211,27 @@ nameIdent :: Name -> Ident nameIdent n = case nInfo n of GlobalName _ og -> ogName og - LocalName _ i -> i + LocalName _ _ i -> i mapNameIdent :: (Ident -> Ident) -> Name -> Name mapNameIdent f n = n { nInfo = case nInfo n of GlobalName x og -> GlobalName x og { ogName = f (ogName og) } - LocalName x i -> LocalName x (f i) + LocalName s x i -> LocalName s x (f i) } nameNamespace :: Name -> Namespace nameNamespace n = case nInfo n of GlobalName _ og -> ogNamespace og - LocalName ns _ -> ns + LocalName _ ns _ -> ns +nameSrc :: Name -> NameSource +nameSrc nm = + case nameInfo nm of + GlobalName x _ -> x + LocalName x _ _ -> x + nameLoc :: Name -> Range nameLoc = nLoc @@ -236,9 +245,28 @@ nameToDefPName n = case nInfo n of GlobalName _ og -> PName.origNameToDefPName og - LocalName _ txt -> PName.mkUnqual txt + LocalName _ _ txt -> PName.mkUnqual txt --- | Primtiives must be in a top level module, at least for now. +-- | Compute a `PName` from `Name`, this preserves all qualifiers in the name, +-- whereas `nameToDefPName` does not. +nameToPNameWithQualifiers :: Name -> PName +nameToPNameWithQualifiers n = + case nameInfo n of + GlobalName _ og -> origNameToPName og + LocalName _ _ txt -> PName.mkUnqual txt + + where + origNameToPName :: OrigName -> PName + origNameToPName og = + case modPathSplit (ogModule og) of + (_top,[] ) -> PName.UnQual ident + (_top,ids) -> PName.Qual (packModName (map identText ids)) ident + + where + ident = ogName og + + +-- | Primtives must be in a top level module, at least for now. asPrim :: Name -> Maybe PrimIdent asPrim n = case nInfo n of @@ -386,14 +414,23 @@ } -- | Make a new parameter name. -mkLocal :: Namespace -> Ident -> Range -> Supply -> (Name,Supply) -mkLocal ns ident loc s = (name, s') +mkLocalPName :: Namespace -> PName -> Range -> Supply -> (Name,Supply) +mkLocalPName ns nm = mkLocal src ns ident where + ident = PName.getIdent nm + src = case nm of + PName.NewName {} -> SystemName + _ -> UserName + +-- | Make a new parameter name. +mkLocal :: NameSource -> Namespace -> Ident -> Range -> Supply -> (Name,Supply) +mkLocal src ns ident loc s = (name, s') + where (u,s') = nextUnique s name = Name { nUnique = u , nLoc = loc , nFixity = Nothing - , nInfo = LocalName ns ident + , nInfo = LocalName src ns ident } {- | Make a local name derived from the given name. @@ -402,7 +439,7 @@ asLocal :: Namespace -> Name -> Name asLocal ns x = case nameInfo x of - GlobalName _ og -> x { nInfo = LocalName ns (ogName og) } + GlobalName src og -> x { nInfo = LocalName src ns (ogName og) } LocalName {} -> x mkModParam :: diff --git a/src/Cryptol/ModuleSystem/NamingEnv.hs b/src/Cryptol/ModuleSystem/NamingEnv.hs --- a/src/Cryptol/ModuleSystem/NamingEnv.hs +++ b/src/Cryptol/ModuleSystem/NamingEnv.hs @@ -21,10 +21,11 @@ import Data.Set (Set) import qualified Data.Set as Set import Data.Foldable(foldl') - +import Data.Text (Text) + import Cryptol.Utils.PP import Cryptol.Utils.Panic (panic) -import Cryptol.Utils.Ident(allNamespaces) +import Cryptol.Utils.Ident(allNamespaces,packModName,modNameChunksText) import Cryptol.Parser.AST import qualified Cryptol.TypeCheck.AST as T import Cryptol.ModuleSystem.Name @@ -73,17 +74,22 @@ -- | Get a naming environment for the given names. The `PName`s correspond -- to the definition sites of the corresponding `Name`s, so typically they --- will be unqualified. The exception is for names that comre from parameters, +-- will be unqualified. The exception is for names that come from parameters, -- which are qualified with the relevant parameter. namingEnvFromNames :: Set Name -> NamingEnv -namingEnvFromNames xs = NamingEnv (foldl' add mempty xs) +namingEnvFromNames = namingEnvFromNames' nameToDefPName + +-- | Create a naming environment from a @Set Name@, given a mapping from +-- @Name -> PName@. +namingEnvFromNames' :: (Name -> PName) -> Set Name -> NamingEnv +namingEnvFromNames' nameToPName xs = + NamingEnv (foldl' add mempty xs) where add mp x = let ns = nameNamespace x in Map.insertWith (Map.unionWith (<>)) - ns (Map.singleton (nameToDefPName x) (One x)) + ns (Map.singleton (nameToPName x) (One x)) mp - -- | Get the names in a given namespace namespaceMap :: Namespace -> NamingEnv -> Map PName Names namespaceMap ns (NamingEnv env) = Map.findWithDefault Map.empty ns env @@ -131,11 +137,10 @@ [ (og, qn) | ns <- allNamespaces , (pn,xs) <- Map.toList (namespaceMap ns env) + , let qn = maybe UnQualified Qualified (getModName pn) , x <- namesToList xs , og <- maybeToList (asOrigName x) - , let qn = case getModName pn of - Just q -> Qualified q - Nothing -> UnQualified + ] @@ -147,16 +152,43 @@ visibleNames (NamingEnv env) = check <$> env where check mp = Set.fromList [ a | One a <- Map.elems mp ] --- | Qualify all symbols in a 'NamingEnv' with the given prefix. + +-- | qualify pfx env - Qualify all symbols in `env :: NamingEnv` with +-- the 'pfx' prefix. +-- +-- NOTE +-- - pfx can have multiple chunks (as Cryptol allows in qualified imports). +-- - Names in 'env' can be qualified names referencing submodule elements. +-- +-- We don't qualify fresh names, because they should not be directly +-- visible to the end users (i.e., they shouldn't really be exported) +-- +-- NOTE re the calls to `qualify`: +-- - used in modParamNamingEnv for module parameters, in this use all names are +-- `Unqual` +-- - used by interpImportEnv used by tryImport: +-- - here also, all names are `Unqual`. +-- - used by interpImportEnv and called from saw-script code: +-- - here, some names are inside submodules and thus qualified, thus +-- the need for the `appendChunk` machinery. +-- qualify :: ModName -> NamingEnv -> NamingEnv qualify pfx (NamingEnv env) = NamingEnv (Map.mapKeys toQual <$> env) where - -- We don't qualify fresh names, because they should not be directly - -- visible to the end users (i.e., they shouldn't really be exported) - toQual (Qual _ n) = Qual pfx n + toQual (Qual mn n) = Qual (prependChunks pfx' mn) n toQual (UnQual n) = Qual pfx n toQual n@NewName{} = n + -- | prependChunks - add ChunksText to start of ModName + prependChunks :: [Text] -> ModName -> ModName + prependChunks ts modNm = packModName (ts ++ modNameChunksText modNm) + + -- | pfx' = pfx as ChunksText + pfx' :: [Text] + pfx' = case modNameChunksText pfx of + [] -> panic "qualify" ["pfx must have at least one chunk: " ++ show pfx] + xs -> xs + filterPNames :: (PName -> Bool) -> NamingEnv -> NamingEnv filterPNames p (NamingEnv env) = NamingEnv (Map.mapMaybe checkNS env) where @@ -271,26 +303,31 @@ | n <- Map.keys ifSignatures ] --- | Adapt the things exported by something to the specific import/open. -interpImportEnv :: ImportG name {- ^ The import declarations -} -> - NamingEnv {- ^ All public things coming in -} -> - NamingEnv -interpImportEnv imp public = qualified +-- | Adapt the things exported by a module to the specific import/open. +interpImportEnv :: ImportG name {- ^ The import declaration -} -> + NamingEnv {- ^ All public things coming in -} -> + NamingEnv +interpImportEnv imp = interpImportEnv' (iAs imp) (iSpec imp) + +-- | A more general version of `interpImportEnv` +interpImportEnv' :: Maybe ModName {- ^ prefix with this qualifier -} -> + Maybe ImportSpec {- ^ restrict per ImportSpec -} -> + NamingEnv {- ^ All public things coming in -} -> + NamingEnv +interpImportEnv' iAs' iSpec' public = qualified where - -- optionally qualify names based on the import - qualified | Just pfx <- iAs imp = qualify pfx restricted - | otherwise = restricted + -- optionally qualify names in NamingEnv if the import is "qualified", + -- i.e., if `isJust iAs'` + qualified | Just pfx <- iAs' = qualify pfx restricted + | otherwise = restricted -- restrict or hide imported symbols restricted - | Just (Hiding ns) <- iSpec imp = + | Just (Hiding ns) <- iSpec' = filterPNames (\qn -> not (getIdent qn `elem` ns)) public - | Just (Only ns) <- iSpec imp = + | Just (Only ns) <- iSpec' = filterPNames (\qn -> getIdent qn `elem` ns) public | otherwise = public - - - diff --git a/src/Cryptol/ModuleSystem/Renamer.hs b/src/Cryptol/ModuleSystem/Renamer.hs --- a/src/Cryptol/ModuleSystem/Renamer.hs +++ b/src/Cryptol/ModuleSystem/Renamer.hs @@ -729,9 +729,10 @@ RenameM (Located (ImportG (ImpName Name))) renI li = withLoc (srcRange li) - do m <- rename (iModule i) + do let mo = iModule i + m <- withLoc (srcRange mo) (rename (thing mo)) unless (isFakeName m) (recordImport (srcRange li) m) - pure li { thing = i { iModule = m } } + pure li { thing = i { iModule = mo { thing = m } } } where i = thing li @@ -957,16 +958,6 @@ mkFakeName expected qn -isFakeName :: ImpName Name -> Bool -isFakeName m = - case m of - ImpTop x -> x == undefinedModName - ImpNested x -> - case nameTopModuleMaybe x of - Just y -> y == undefinedModName - Nothing -> False - - -- | Resolve a name, and report error on failure. resolveName :: NameType -> Namespace -> PName -> RenameM Name resolveName nt expected qn = @@ -1036,7 +1027,8 @@ TBit -> return TBit TNum c -> return (TNum c) TChar c -> return (TChar c) - TUser qn ps -> TUser <$> renameType NameUse qn <*> traverse rename ps + TUser qn ps -> TUser <$> withLoc (srcRange qn) (traverse (renameType NameUse) qn) + <*> traverse rename ps TTyApp fs -> TTyApp <$> traverse (traverse rename) fs TRecord fs -> TRecord <$> traverse (traverse rename) fs TTuple fs -> TTuple <$> traverse rename fs @@ -1071,8 +1063,8 @@ rename b = do n' <- rnLocated (renameVar NameBind) (bName b) depsOf (NamedThing (thing n')) - do mbSig <- traverse renameSchema (bSignature b) - shadowNames (fst `fmap` mbSig) $ + do mbSig <- traverse (traverse renameSchema) (bSignature b) + shadowNames ((fst . thing) `fmap` mbSig) $ do (patEnv,bParams') <- renameBindParams (bParams b) -- NOTE: renamePats will generate warnings, -- so we don't need to trigger them again here. @@ -1080,14 +1072,14 @@ return b { bName = n' , bParams = bParams' , bDef = e' - , bSignature = snd `fmap` mbSig + , bSignature = fmap snd `fmap` mbSig , bPragmas = bPragmas b } instance Rename BindDef where - rename DPrim = return DPrim - rename (DForeign i) = DForeign <$> traverse rename i - rename (DImpl i) = DImpl <$> rename i + rename DPrim = return DPrim + rename (DForeign cc i) = DForeign cc <$> traverse rename i + rename (DImpl i) = DImpl <$> rename i instance Rename BindImpl where rename (DExpr e) = DExpr <$> rename e @@ -1197,7 +1189,8 @@ EInfix x y _ z -> do op <- renameOp y x' <- rename x z' <- rename z - mkEInfix x' op z' + x'' <- located x' + mkEInfix (Just (srcRange x'')) x' op z' EPrefix op e -> EPrefix op <$> rename e @@ -1233,43 +1226,50 @@ x':_ -> x' [] -> panic "checkLabels" ["UpdFields with no labels"] -mkEInfix :: Expr Name -- ^ May contain infix expressions +mkEInfix :: Maybe Range -- ^ Location of left expression + -> Expr Name -- ^ May contain infix expressions -> (Located Name,Fixity) -- ^ The operator to use -> Expr Name -- ^ Will not contain infix expressions -> RenameM (Expr Name) -mkEInfix e@(EInfix x o1 f1 y) op@(o2,f2) z = +mkEInfix mbR e@(EInfix x o1 f1 y) op@(o2,f2) z = case compareFixity f1 f2 of FCLeft -> return (EInfix e o2 f2 z) - FCRight -> do r <- mkEInfix y op z + FCRight -> do r <- mkEInfix Nothing y op z return (EInfix x o1 f1 r) FCError -> do recordError (FixityError o1 f1 o2 f2) - return (EInfix e o2 f2 z) + return (EInfix (maybeLoc mbR e) o2 f2 z) -mkEInfix e@(EPrefix o1 x) op@(o2, f2) y = +mkEInfix mbR e@(EPrefix o1 x) op@(o2, f2) y = case compareFixity (prefixFixity o1) f2 of FCRight -> do let warning = PrefixAssocChanged o1 x o2 f2 y RenameM $ sets_ (\rw -> rw {rwWarnings = warning : rwWarnings rw}) - r <- mkEInfix x op y + r <- mkEInfix Nothing x op y return (EPrefix o1 r) -- Even if the fixities conflict, we make the prefix operator take -- precedence. - _ -> return (EInfix e o2 f2 y) - + _ -> return (EInfix (maybeLoc mbR e) o2 f2 y) + -- Note that for prefix operator on RHS of infix operator we make the prefix -- operator always have precedence, so we allow a * -b instead of requiring -- a * (-b). -mkEInfix (ELocated e' _) op z = - mkEInfix e' op z +mkEInfix _ (ELocated e' r) op z = + mkEInfix (Just r) e' op z -mkEInfix e (o,f) z = - return (EInfix e o f z) +mkEInfix mbR e (o,f) z = + return (EInfix (maybeLoc mbR e) o f z) + +maybeLoc :: Maybe Range -> Expr name -> Expr name +maybeLoc mb e = + case mb of + Nothing -> e + Just r -> ELocated e r renameOp :: Located PName -> RenameM (Located Name, Fixity) renameOp ln = @@ -1361,7 +1361,10 @@ patternEnv = go where go (PVar Located { .. }) = - do n <- liftSupply (mkLocal NSValue (getIdent thing) srcRange) + do let src = case thing of + NewName {} -> SystemName + _ -> UserName + n <- liftSupply (mkLocal src NSValue (getIdent thing) srcRange) -- XXX: for deps, we should record a use return (singletonNS NSValue thing n) go (PCon _ ps) = bindVars ps @@ -1388,8 +1391,9 @@ typeEnv TNum{} = return mempty typeEnv TChar{} = return mempty - typeEnv (TUser pn ps) = - do mb <- resolveNameMaybe NameUse NSType pn + typeEnv (TUser pn' ps) = + do let pn = thing pn' + mb <- withLoc (srcRange pn') (resolveNameMaybe NameUse NSType pn) case mb of -- The type is already bound, don't introduce anything. @@ -1401,7 +1405,7 @@ -- of the type of the pattern. | null ps -> do loc <- curLoc - n <- liftSupply (mkLocal NSType (getIdent pn) loc) + n <- liftSupply (mkLocalPName NSType pn loc) return (singletonNS NSType pn n) -- This references a type synonym that's not in scope. Record an @@ -1409,7 +1413,7 @@ | otherwise -> do loc <- curLoc recordError (UnboundName NSType (Located loc pn)) - n <- liftSupply (mkLocal NSType (getIdent pn) loc) + n <- liftSupply (mkLocalPName NSType pn loc) return (singletonNS NSType pn n) typeEnv (TRecord fs) = bindTypes (map snd (recordElements fs)) diff --git a/src/Cryptol/ModuleSystem/Renamer/ImplicitImports.hs b/src/Cryptol/ModuleSystem/Renamer/ImplicitImports.hs --- a/src/Cryptol/ModuleSystem/Renamer/ImplicitImports.hs +++ b/src/Cryptol/ModuleSystem/Renamer/ImplicitImports.hs @@ -113,7 +113,7 @@ Located { srcRange = loc , thing = Import - { iModule = ImpNested (isToName xs) + { iModule = Located loc (ImpNested (isToName xs)) , iAs = Just (isToQual xs) , iSpec = Nothing , iInst = Nothing diff --git a/src/Cryptol/ModuleSystem/Renamer/Imports.hs b/src/Cryptol/ModuleSystem/Renamer/Imports.hs --- a/src/Cryptol/ModuleSystem/Renamer/Imports.hs +++ b/src/Cryptol/ModuleSystem/Renamer/Imports.hs @@ -61,10 +61,12 @@ import Control.Monad(when) import qualified MonadLib as M + import Cryptol.Utils.PP(pp) import Cryptol.Utils.Panic(panic) import Cryptol.Utils.Ident(ModName,ModPath(..),Namespace(..),OrigName(..)) +import Cryptol.Parser.Position(Located(..)) import Cryptol.Parser.AST ( ImportG(..),PName, ModuleInstanceArgs(..), ImpName(..) ) import Cryptol.ModuleSystem.Binds @@ -377,7 +379,7 @@ tryImport s imp = fromMaybe (updCur s (pushImport imp)) -- not ready, put it back on the q do let srcName = iModule imp - mname <- knownImpName s srcName + mname <- knownImpName s (thing srcName) ext <- knownModule s mname let isPub x = x `Set.member` rmodPublic ext diff --git a/src/Cryptol/ModuleSystem/Renamer/Monad.hs b/src/Cryptol/ModuleSystem/Renamer/Monad.hs --- a/src/Cryptol/ModuleSystem/Renamer/Monad.hs +++ b/src/Cryptol/ModuleSystem/Renamer/Monad.hs @@ -10,6 +10,7 @@ {-# Language FlexibleContexts #-} {-# Language BlockArguments #-} {-# Language OverloadedStrings #-} +{-# Language MultiParamTypeClasses #-} module Cryptol.ModuleSystem.Renamer.Monad where import Data.List(sort,foldl') @@ -25,7 +26,8 @@ import Cryptol.Utils.PP(pp) import Cryptol.Utils.Panic(panic) -import Cryptol.Utils.Ident(modPathCommon,OrigName(..),OrigSource(..)) +import Cryptol.Utils.Ident(modPathCommon,OrigName(..),OrigSource(..), + undefinedModName) import Cryptol.ModuleSystem.Name import Cryptol.ModuleSystem.NamingEnv import Cryptol.ModuleSystem.Binds @@ -50,7 +52,10 @@ -- ^ External modules } -newtype RenameM a = RenameM { unRenameM :: ReaderT RO (StateT RW Lift) a } +-- The ExceptionT here is for bailing when a fake value like mkFakeName is +-- encountered. These values have already had an error recorded and are being +-- processed for best-effort error reporting so we do not need a value. +newtype RenameM a = RenameM { unRenameM :: ReaderT RO (ExceptionT () (StateT RW Lift)) a } data RO = RO { roLoc :: Range @@ -151,6 +156,9 @@ rw' = RW { rwSupply = s', .. } in a `seq` rw' `seq` (a, rw') +instance ExceptionM RenameM () where + {-# INLINE raise #-} + raise = RenameM . raise runRenamer :: RenamerInfo -> RenameM a -> ( Either [RenamerError] (a,Supply) @@ -180,7 +188,9 @@ , roFromModParam = mempty } - res | Set.null (rwErrors rw) = Right (a,rwSupply rw) + res | Set.null (rwErrors rw) = case a of + Left _ -> panic "runRenamer" ["No renaming errors, but no output"] + Right r -> Right (r,rwSupply rw) | otherwise = Left (Set.toList (rwErrors rw)) toModMap t ent = @@ -207,12 +217,13 @@ lookupResolved :: ImpName Name -> RenameM ResolvedLocal lookupResolved nm = do mp <- RenameM (roResolvedModules <$> ask) - pure case Map.lookup nm mp of - Just r -> r - - -- XXX: could this happen because we couldn't resolve a module? - Nothing -> panic "lookupResolved" - [ "Missing module: " ++ show nm ] + case Map.lookup nm mp of + Just r -> pure r + Nothing | isFakeName nm -> raise () + Nothing -> + panic + "lookupResolved" + ["Missing module: " ++ show nm] setModParams :: [RenModParam] -> RenameM a -> RenameM a setModParams ps (RenameM m) = @@ -507,3 +518,11 @@ ] ) +isFakeName :: ImpName Name -> Bool +isFakeName m = + case m of + ImpTop x -> x == undefinedModName + ImpNested x -> + case nameTopModuleMaybe x of + Just y -> y == undefinedModName + Nothing -> False diff --git a/src/Cryptol/Parser.y b/src/Cryptol/Parser.y --- a/src/Cryptol/Parser.y +++ b/src/Cryptol/Parser.y @@ -44,15 +44,6 @@ import Paths_cryptol } -{- state 202 contains 1 shift/reduce conflicts. - `_` identifier conflicts with `_` in record update. - We have `_` as an identifier for the cases where we parse types as - expressions, for example `[ 12 .. _ ]`. --} - -%expect 1 - - %token NUM { $$@(Located _ (Token (Num {}) _))} FRAC { $$@(Located _ (Token (Frac {}) _))} @@ -341,7 +332,9 @@ | mbDoc 'primitive' 'type' schema ':' kind {% mkPrimTypeDecl $1 $4 $6 } foreign_bind :: { [TopDecl PName] } - : mbDoc 'foreign' name ':' schema {% mkForeignDecl $1 $3 $5 } + : mbDoc 'foreign' name ':' schema {% mkForeignDecl $1 Nothing $3 $5 } + | mbDoc 'foreign' name name ':' schema {% mkForeignDecl $1 (Just $3) $4 $6 } + parameter_decls :: { TopDecl PName } : 'parameter' 'v{' par_decls 'v}' { mkParDecls (reverse $3) } @@ -546,9 +539,7 @@ | typedExpr { $1 } whereClause :: { Located [Decl PName] } - : '{' '}' { Located (rComb $1 $2) [] } - | '{' decls '}' { Located (rComb $1 $3) (reverse $2) } - | 'v{' 'v}' { Located (rComb $1 $2) [] } + : 'v{' 'v}' { Located (rComb $1 $2) [] } | 'v{' vdecls 'v}' { let l2 = fromMaybe $3 (getLoc $2) in Located (rComb $1 l2) (reverse $2) } @@ -566,7 +557,6 @@ : 'if' ifBranches 'else' exprNoWhere { at ($1,$4) $ mkIf (reverse $2) $4 } | '\\' iapats '->' exprNoWhere { at ($1,$4) $ EFun emptyFunDesc (reverse $2) $4 } | 'case' expr 'of' 'v{' vcaseBranches 'v}' {at ($1,$6) (ECase $2 (reverse $5))} - | 'case' expr 'of' '{' caseBranches '}' { at ($1,$6) (ECase $2 (reverse $5)) } ifBranches :: { [(Expr PName, Expr PName)] } @@ -579,10 +569,7 @@ vcaseBranches :: { [CaseAlt PName] } : caseBranch { [$1] } | vcaseBranches 'v;' caseBranch { $3 : $1 } - -caseBranches :: { [CaseAlt PName] } - : caseBranch { [$1] } - | caseBranches ';' caseBranch { $3 : $1 } + | vcaseBranches ';' caseBranch { $3 : $1 } caseBranch :: { CaseAlt PName } : cpat '->' expr { CaseAlt $1 $3 } @@ -665,8 +652,7 @@ rec_expr :: { Either (Expr PName) [Named (Expr PName)] } - : aexpr '|' field_exprs { Left (EUpd (Just $1) (reverse $3)) } - | '_' '|' field_exprs { Left (EUpd Nothing (reverse $3)) } + : aexpr '|' field_exprs { Left (EUpd (recExprWildcardCase $1) (reverse $3)) } | field_exprs {% Right `fmap` mapM ufToNamed $1 } field_exprs :: { [UpdField PName] } @@ -845,12 +831,12 @@ app_type :: { Type PName } : dimensions atype { at ($1,$2) $ foldr TSeq $2 (reverse (thing $1)) } | qname atypes { at ($1,head $2) - $ TUser (thing $1) (reverse $2) } + $ TUser $1 (reverse $2) } | atype { $1 } atype :: { Type PName } - : qname { at $1 $ TUser (thing $1) [] } - | '(' qop ')' { at $1 $ TUser (thing $2) [] } + : qname { at $1 $ TUser $1 [] } + | '(' qop ')' { at $1 $ TUser $2 [] } | NUM { at $1 $ TNum (getNum $1) } | CHARLIT { at $1 $ TChar (getChr $1) } | '[' type ']' { at ($1,$3) $ TSeq $2 TBit } @@ -920,7 +906,7 @@ {- The types that can come after a back-tick: either a type demotion, or an explicit type application. -} tick_ty :: { Type PName } - : qname { at $1 $ TUser (thing $1) [] } + : qname { at $1 $ TUser $1 [] } | NUM { at $1 $ TNum (getNum $1) } | '(' type ')' {% validDemotedType (rComb $1 $3) $2 } | '{' '}' { at ($1,$2) (TTyApp []) } @@ -1019,6 +1005,19 @@ parseSchema :: Text -> Either ParseError (Schema PName) parseSchema = parseSchemaWith defaultConfig + + +{- record expressions have a special treatment of the `_` expression. + These expressions generate record updating functions. + We have `_` as an identifier for the cases where we parse types as + expressions, for example `[ 12 .. _ ]`. +-} +recExprWildcardCase :: (Expr PName) -> Maybe (Expr PName) +recExprWildcardCase e = + case e of + EVar (UnQual "_") -> Nothing + _ -> Just e + -- vim: ft=haskell } diff --git a/src/Cryptol/Parser/AST.hs b/src/Cryptol/Parser/AST.hs --- a/src/Cryptol/Parser/AST.hs +++ b/src/Cryptol/Parser/AST.hs @@ -82,6 +82,7 @@ , ModParam(..) , ParamDecl(..) , PropGuardCase(..) + , ForeignMode(..) -- * Interactive , ReplInput(..) @@ -156,7 +157,7 @@ {- | A module for the pre-typechecker phasese. The two parameters are: * @mname@ the type of module names. This is because top-level and nested - modules use differnt types to identify a module. + modules use different types to identify a module. * @name@ the type of identifiers used by declarations. In the parser this starts off as `PName` and after resolving names @@ -189,7 +190,7 @@ {- | Maps names in the original functor with names in the instnace. Does *NOT* include the parameters, just names for the definitions. -This *DOES* include entrirs for all the name in the instantiated functor, +This *DOES* include entries for all the name in the instantiated functor, including names in modules nested inside the functor. -} type ModuleInstance name = Map name name @@ -214,10 +215,11 @@ FunctorInstance {} -> [] InterfaceModule sig -> mapMaybe topImp (sigImports sig) where - topImp li = case iModule i of - ImpTop n -> Just li { thing = i { iModule = n } } + topImp li = case thing mo of + ImpTop n -> Just li { thing = i { iModule = Located (srcRange mo) n } } _ -> Nothing where i = thing li + mo = iModule i -- | Get the module parameters of a module (new module system) @@ -436,7 +438,7 @@ -- | An import declaration. data ImportG mname = Import - { iModule :: !mname + { iModule :: !(Located mname) , iAs :: Maybe ModName , iSpec :: Maybe ImportSpec , iInst :: !(Maybe (ModuleInstanceArgs PName)) @@ -487,7 +489,9 @@ { bName :: Located name -- ^ Defined thing , bParams :: BindParams name -- ^ Parameters , bDef :: Located (BindDef name) -- ^ Definition - , bSignature :: Maybe (Schema name) -- ^ Optional type sig + , bSignature :: Maybe (Located (Schema name)) + -- ^ Optional type sig + -- The location is of the name in the type signature , bInfix :: Bool -- ^ Infix operator? , bFixity :: Maybe Fixity -- ^ Optional fixity info , bPragmas :: [Pragma] -- ^ Optional pragmas @@ -541,19 +545,25 @@ type LBindDef = Located (BindDef PName) +-- | How to call a foreign functions +data ForeignMode = + ForeignC -- ^ Call using C-style marshalling + | ForeignAbstract -- ^ Call using import/export objects + deriving (Eq, Show, Generic, NFData) + data BindDef name = DPrim -- | Foreign functions can have an optional cryptol -- implementation - | DForeign (Maybe (BindImpl name)) + | DForeign ForeignMode (Maybe (BindImpl name)) | DImpl (BindImpl name) deriving (Eq, Show, Generic, NFData, Functor) bindImpl :: Bind name -> Maybe (BindImpl name) bindImpl bind = case thing (bDef bind) of - DPrim -> Nothing - DForeign mi -> mi - DImpl i -> Just i + DPrim -> Nothing + DForeign _ mi -> mi + DImpl i -> Just i data BindImpl name = DExpr (Expr name) | DPropGuards [PropGuardCase name] @@ -750,7 +760,7 @@ | TBit -- ^ @Bit@ | TNum Integer -- ^ @10@ | TChar Char -- ^ @'a'@ - | TUser n [Type n] -- ^ A type variable or synonym + | TUser (Located n) [Type n] -- ^ A type variable or synonym | TTyApp [Named (Type n)] -- ^ @`{ x = [8], y = Integer }@ | TRecord (Rec (Type n)) -- ^ @{ x : [8], y : [32] }@ | TTuple [Type n] -- ^ @([8], [32])@ @@ -1100,7 +1110,7 @@ ppPrec n decl = case decl of DSignature xs s -> commaSep (map ppL xs) <+> text ":" <+> pp s - DPatBind p e -> pp p <+> text "=" <+> pp e + DPatBind p e -> nest 2 (pp p <+> text "=" pp e) DBind b -> ppPrec n b DRec bs -> nest 2 (vcat ("recursive" : map (ppPrec n) bs)) DFixity f ns -> ppFixity f ns @@ -1175,13 +1185,13 @@ instance (Show name, PPName name) => PP (Bind name) where ppPrec _ b = vcat (sig ++ [ ppPragma [f] p | p <- bPragmas b ] ++ - [hang (def <+> eq) 4 (pp (thing (bDef b)))]) + [nest 2 (def <+> eq pp (thing (bDef b)))]) where def | bInfix b = lhsOp | otherwise = lhs f = bName b sig = case bSignature b of Nothing -> [] - Just s -> [pp (DSignature [f] s)] + Just s -> [pp (DSignature [f] (thing s))] eq = if bMono b then text ":=" else text "=" lhs = fsep (ppL f : (map (ppPrec 3) (bindParams b))) @@ -1191,11 +1201,20 @@ -- _ -> panic "AST" [ "Malformed infix operator", show b ] +instance PP ForeignMode where + ppPrec _ fmode = + case fmode of + ForeignC -> "c" + ForeignAbstract -> "abstract" + + instance (Show name, PPName name) => PP (BindDef name) where ppPrec _ DPrim = text "" - ppPrec p (DForeign mi) = case mi of - Just i -> "(foreign)" <+> ppPrec p i - Nothing -> "" + ppPrec p (DForeign mo mi) = + let lab = "foreign" <+> pp mo in + case mi of + Just i -> parens lab <+> ppPrec p i + Nothing -> hcat [ "<",lab,">"] ppPrec p (DImpl i) = ppPrec p i instance (Show name, PPName name) => PP (BindImpl name) where @@ -1335,7 +1354,7 @@ -- low prec EFun _ xs e -> wrap n 0 ((text "\\" <.> hsep (map (ppPrec 3) xs)) <+> - text "->" <+> pp e) + text "->" pp e) EIf e1 e2 e3 -> wrap n 0 $ sep [ text "if" <+> pp e1 , text "then" <+> pp e2 @@ -1358,7 +1377,7 @@ $ ppInfix 2 isInfix ifix EApp _ _ -> let (e, es) = asEApps expr in - wrap n 3 (ppPrec 3 e <+> fsep (map (ppPrec 4) es)) + nest 2 (wrap n 3 (foldl () (ppPrec 3 e) (map (ppPrec 4) es))) ELocated e _ -> ppPrec n e @@ -1462,7 +1481,7 @@ $ ppPrefixName f <+> fsep (map (ppPrec 4) ts) TFun t1 t2 -> optParens (n > 1) - $ sep [ppPrec 2 t1 <+> text "->", ppPrec 1 t2] + $ ppPrec 2 t1 <+> text "->" ppPrec 1 t2 TLocated t _ -> ppPrec n t @@ -1490,13 +1509,13 @@ -- WARNING: This does not call `noPos` on the `thing` inside instance NoPos (Located t) where noPos x = x { srcRange = rng } - where rng = Range { from = Position 0 0, to = Position 0 0, source = "" } + where rng = emptyRange instance NoPos t => NoPos (Named t) where noPos t = Named { name = noPos (name t), value = noPos (value t) } instance NoPos Range where - noPos _ = Range { from = Position 0 0, to = Position 0 0, source = "" } + noPos _ = emptyRange instance NoPos t => NoPos [t] where noPos = fmap noPos instance NoPos t => NoPos (Maybe t) where noPos = fmap noPos @@ -1546,7 +1565,7 @@ DImport x -> DImport (noPos x) DModParam d -> DModParam (noPos d) DParamDecl _ ds -> DParamDecl rng (noPos ds) - where rng = Range { from = Position 0 0, to = Position 0 0, source = "" } + where rng = emptyRange DInterfaceConstraint d ds -> DInterfaceConstraint d (noPos (noPos <$> ds)) instance NoPos (ParamDecl name) where diff --git a/src/Cryptol/Parser/AST/Builder.hs b/src/Cryptol/Parser/AST/Builder.hs new file mode 100644 --- /dev/null +++ b/src/Cryptol/Parser/AST/Builder.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Some utility functions for conveniently building up Cryptol Parser AST data +-- structures in Haskell. This isn't currently used by Cryptol itself but can be +-- used by other tools that need to manipulate Cryptol ASTs like SAW. +-- +-- This module is intended to be imported qualified. +module Cryptol.Parser.AST.Builder where + +import qualified Data.Text as Text +import Numeric.Natural + +import Cryptol.Parser.AST + +-- * Built-in syntax + +-- | Polymorphic integer literal. For negative inputs, a prefix negation +-- operator will be added. +-- +-- @intLit n@ is equivalent to the literal @n@ in Cryptol. +intLit :: Integral a => a -> Expr n +intLit n = + let n' = toInteger n + absLit = ELit $ ECNum (abs n') $ DecLit $ Text.pack $ show (abs n') + in if n' < 0 then EPrefix PrefixNeg absLit else absLit + +-- | Integer literal as a bitvector of a specific width. +-- +-- @bvLit n m@ is equivalent to the type-annotated literal @n : [m]@ in Cryptol. +bvLit :: Natural -> Natural -> Expr PName +bvLit val bits = + number (TNum (toInteger val)) (TSeq (TNum (toInteger bits)) TBit) + +-- * Cryptol prelude functions lifted to Haskell + +-- | Cryptol @number@ lifted to Haskell. +number :: Type PName -> Type PName -> Expr PName +number = funT2 "number" + +-- | Cryptol @(<=)@ lifted to Haskell. +(<=) :: Expr PName -> Expr PName -> Expr PName +(<=) = funV2 (mkInfix "<=") +infix 4 <= + +-- | Cryptol @(>=)@ lifted to Haskell. +(>=) :: Expr PName -> Expr PName -> Expr PName +(>=) = funV2 (mkInfix ">=") +infix 4 >= + +-- * Lower level utilities + +-- | Lift a Cryptol named function with 2 value parameters to Haskell. +funV2 :: Ident -> Expr PName -> Expr PName -> Expr PName +funV2 f x y = var f $$ x $$ y + +-- | Lift a Cryptol named polymorphic value with 2 type parameters to Haskell. +funT2 :: Ident -> Type PName -> Type PName -> Expr PName +funT2 f a b = var f $^ [PosInst a, PosInst b] + +-- | Create an unqualified variable expression from an identifier. +var :: Ident -> Expr PName +var = EVar . mkUnqual + +-- | Infix operator for Cryptol value application. +($$) :: Expr n -> Expr n -> Expr n +($$) = EApp +infixl 1 $$ + +-- | Infix operator for Cryptol type application. +($^) :: Expr n -> [TypeInst n] -> Expr n +($^) = EAppT +infixl 2 $^ diff --git a/src/Cryptol/Parser/ExpandPropGuards.hs b/src/Cryptol/Parser/ExpandPropGuards.hs --- a/src/Cryptol/Parser/ExpandPropGuards.hs +++ b/src/Cryptol/Parser/ExpandPropGuards.hs @@ -9,7 +9,7 @@ -- Module : Cryptol.Parser.PropGuards -- Copyright : (c) 2022 Galois, Inc. -- License : BSD3 --- Maintainer : cryptol@galois.com +-- Mintiner : cryptol@galois.com -- Stability : provisional -- Portability : portable -- @@ -18,7 +18,9 @@ -- function. module Cryptol.Parser.ExpandPropGuards where +import Data.Maybe(fromMaybe) import Control.DeepSeq +import Cryptol.Parser.Position(emptyRange) import Cryptol.Parser.AST import Cryptol.Utils.PP import Cryptol.Utils.Panic (panic) @@ -103,7 +105,7 @@ expandBind bind = case thing (bDef bind) of DImpl (DPropGuards guards) -> expand (DImpl . DPropGuards) guards - DForeign (Just (DPropGuards guards)) -> expand (DForeign . Just . DPropGuards) guards + DForeign cc (Just (DPropGuards guards)) -> expand (DForeign cc . Just . DPropGuards) guards _ -> do checkNestedGuardsInBind bind pure [bind] @@ -112,7 +114,7 @@ expand def guards = do Forall params props t rng <- case bSignature bind of - Just schema -> pure schema + Just schema -> pure (thing schema) Nothing -> Left . NoSignature $ bName bind let goGuard :: PropGuardCase PName -> @@ -121,11 +123,13 @@ checkNestedGuardsInExpr e bName' <- newName (bName bind) (thing <$> props') -- call to generated function - tParams <- case bSignature bind of + tParams <- case thing <$> bSignature bind of Just (Forall tps _ _ _) -> pure tps Nothing -> Left $ NoSignature (bName bind) typeInsts <- - (\(TParam n _ _) -> Right . PosInst $ TUser n []) + (\tp -> + let loc = fromMaybe emptyRange (tpRange tp) in + Right (PosInst (TUser (Located loc (tpName tp)) []))) `traverse` tParams let e' = foldl EApp (EAppT (EVar $ thing bName') typeInsts) (patternToExpr <$> bindParams bind) pure @@ -133,9 +137,11 @@ bind { bName = bName', -- include guarded props in signature - bSignature = Just (Forall params + bSignature = Just Located + { srcRange = maybe (srcRange (bName bind)) srcRange (bSignature bind), + thing = Forall params (props <> map thing props') - t rng), + t rng }, -- keeps same location at original bind -- i.e. "on top of" original bind bDef = (bDef bind) {thing = exprDef e} @@ -250,7 +256,7 @@ case thing (bDef bind) of DPrim -> pure () DImpl bi -> checkNestedGuardsInBindImpl bi - DForeign mbBi -> traverse_ checkNestedGuardsInBindImpl mbBi + DForeign _ mbBi -> traverse_ checkNestedGuardsInBindImpl mbBi where nestedConstraintGuards :: ExpandPropGuardsM () nestedConstraintGuards = Left . NestedConstraintGuard $ bName bind diff --git a/src/Cryptol/Parser/Layout.hs b/src/Cryptol/Parser/Layout.hs --- a/src/Cryptol/Parser/Layout.hs +++ b/src/Cryptol/Parser/Layout.hs @@ -93,7 +93,7 @@ noVirtSep: Do not emit a virtual separator even if token matches block alignment. This is enabled at the beginning of a block, or after a doc string, - or if we just emitted a separtor, but have not yet consumed the + or if we just emitted a separator, but have not yet consumed the next token. tokens: diff --git a/src/Cryptol/Parser/Lexer.x b/src/Cryptol/Parser/Lexer.x --- a/src/Cryptol/Parser/Lexer.x +++ b/src/Cryptol/Parser/Lexer.x @@ -227,7 +227,7 @@ eofR p = Range p' p' (cfgSource cfg) where - p' = Position { line = line p + 1, col = 0 } + p' = beforeStartOfLine (line p + 1) run i s = case alexScan i (stateToInt s) of diff --git a/src/Cryptol/Parser/Names.hs b/src/Cryptol/Parser/Names.hs --- a/src/Cryptol/Parser/Names.hs +++ b/src/Cryptol/Parser/Names.hs @@ -78,7 +78,7 @@ namesDef :: Ord name => BindDef name -> Set name namesDef DPrim = Set.empty -namesDef (DForeign mi) = foldMap namesImpl mi +namesDef (DForeign _ mi) = foldMap namesImpl mi namesDef (DImpl i) = namesImpl i namesImpl :: Ord name => BindImpl name -> Set name @@ -215,14 +215,14 @@ tnamesB :: Ord name => Bind name -> Set name tnamesB b = Set.unions [setS, setP, setE] where - setS = maybe Set.empty tnamesS (bSignature b) + setS = maybe Set.empty (tnamesS . thing) (bSignature b) setP = Set.unions (map tnamesP (bindParams b)) setE = tnamesDef (thing (bDef b)) tnamesDef :: Ord name => BindDef name -> Set name -tnamesDef DPrim = Set.empty -tnamesDef (DForeign mi) = foldMap tnamesImpl mi -tnamesDef (DImpl i) = tnamesImpl i +tnamesDef DPrim = Set.empty +tnamesDef (DForeign _ mi) = foldMap tnamesImpl mi +tnamesDef (DImpl i) = tnamesImpl i tnamesImpl :: Ord name => BindImpl name -> Set name tnamesImpl (DExpr e) = tnamesE e @@ -326,7 +326,7 @@ TRecord fs -> Set.unions (map (tnamesT . snd) (recordElements fs)) TTyApp fs -> Set.unions (map (tnamesT . value) fs) TLocated t _ -> tnamesT t - TUser x ts -> Set.insert x (Set.unions (map tnamesT ts)) + TUser x ts -> Set.insert (thing x) (Set.unions (map tnamesT ts)) TParens t _ -> tnamesT t TInfix a x _ c-> Set.insert (thing x) (Set.union (tnamesT a) (tnamesT c)) diff --git a/src/Cryptol/Parser/NoPat.hs b/src/Cryptol/Parser/NoPat.hs --- a/src/Cryptol/Parser/NoPat.hs +++ b/src/Cryptol/Parser/NoPat.hs @@ -242,12 +242,12 @@ | otherwise -> panic "NoPat" [ "noMatchB: primitive with params" , show b ] - DForeign Nothing + DForeign _ Nothing | null (bindParams b) -> return b | otherwise -> panic "NoPat" [ "noMatchB: foreign with params" , show b ] - DForeign (Just i) -> noMatchI (DForeign . Just) i + DForeign cc (Just i) -> noMatchI (DForeign cc . Just) i DImpl i -> noMatchI DImpl i @@ -394,15 +394,15 @@ -- | For each binding name, does there exist an empty foreign bind, a normal -- cryptol bind, or both. -data AnnForeign = OnlyForeign | OnlyImpl | BothForeignImpl +data AnnForeign = OnlyForeign ForeignMode | OnlyImpl | BothForeignImpl ForeignMode instance Semigroup AnnForeign where - OnlyForeign <> OnlyImpl = BothForeignImpl - OnlyImpl <> OnlyForeign = BothForeignImpl - _ <> BothForeignImpl = BothForeignImpl - BothForeignImpl <> _ = BothForeignImpl - OnlyForeign <> OnlyForeign = OnlyForeign - OnlyImpl <> OnlyImpl = OnlyImpl + OnlyForeign cc <> OnlyImpl = BothForeignImpl cc + OnlyImpl <> OnlyForeign cc = BothForeignImpl cc + _ <> BothForeignImpl cc = BothForeignImpl cc + BothForeignImpl cc <> _ = BothForeignImpl cc + OnlyForeign cc <> OnlyForeign _ = OnlyForeign cc + OnlyImpl <> OnlyImpl = OnlyImpl data AnnotMap = AnnotMap { annPragmas :: Map.Map PName [Located Pragma ] @@ -499,9 +499,9 @@ -- Compute the new def before updating the state, since we don't want to -- consume the annotations if we are throwing away an empty foreign def. def' <- case thisForeign of - Just BothForeignImpl - | DForeign _ <- thing bDef -> raise () - | DImpl i <- thing bDef -> pure (DForeign (Just i) <$ bDef) + Just (BothForeignImpl cc) + | DForeign _ _ <- thing bDef -> raise () + | DImpl i <- thing bDef -> pure (DForeign cc (Just i) <$ bDef) _ -> pure bDef s <- lift $ lift $ checkSigs name $ jn thisSigs f <- lift $ lift $ checkFixs name $ jn thisFixes @@ -550,11 +550,11 @@ pure pt { primTFixity = f } -- | Check for multiple signatures. -checkSigs :: PName -> [Located (Schema PName)] -> NoPatM (Maybe (Schema PName)) +checkSigs :: PName -> [Located (Schema PName)] -> NoPatM (Maybe (Located (Schema PName))) checkSigs _ [] = return Nothing -checkSigs _ [s] = return (Just (thing s)) +checkSigs _ [s] = return (Just s) checkSigs f xs@(s : _ : _) = do recordError $ MultipleSignatures f xs - return (Just (thing s)) + return (Just s) checkFixs :: PName -> [Located Fixity] -> NoPatM (Maybe Fixity) checkFixs _ [] = return Nothing @@ -611,7 +611,7 @@ toForeigns :: Decl PName -> [(PName, AnnForeign)] toForeigns (DLocated d _) = toForeigns d toForeigns (DBind Bind {..}) - | DForeign Nothing <- thing bDef = [ (thing bName, OnlyForeign) ] + | DForeign cc Nothing <- thing bDef = [ (thing bName, OnlyForeign cc) ] | DImpl _ <- thing bDef = [ (thing bName, OnlyImpl) ] toForeigns _ = [] diff --git a/src/Cryptol/Parser/ParserUtils.hs b/src/Cryptol/Parser/ParserUtils.hs --- a/src/Cryptol/Parser/ParserUtils.hs +++ b/src/Cryptol/Parser/ParserUtils.hs @@ -486,7 +486,7 @@ exprToNumT :: Range -> Expr PName -> ParseM (Type PName) exprToNumT r expr = - case translateExprToNumT expr of + case translateExprToNumT r expr of Just t -> return t Nothing -> bad where @@ -661,10 +661,10 @@ case t of TLocated t1 r -> go (Just r) t1 TUser n ts -> - case n of + case thing n of UnQual i | isUpperIdent i -> - pure EnumCon { ecName = Located (getL mbLoc) (UnQual i) + pure EnumCon { ecName = Located (srcRange n) (UnQual i) , ecFields = ts } | otherwise -> @@ -706,8 +706,8 @@ TLocated ty1 loc1 -> goP loc1 ty1 TUser f [] -> - do goN loc f - pure TParam { tpName = f, tpKind = Nothing, tpRange = Just loc } + do goN (srcRange f) (thing f) + pure TParam { tpName = thing f, tpKind = Nothing, tpRange = Just loc } TParens t mb -> case mb of @@ -730,16 +730,16 @@ TTyApp {} -> badP loc TTuple {} -> badP loc - + goD loc ty = case ty of TLocated ty1 loc1 -> goD loc1 ty1 TUser f ts -> - do goN loc f + do goN (srcRange f) (thing f) ps <- mapM (goP loc) ts - pure (Located { thing = f, srcRange = loc },ps) + pure (f,ps) TInfix l f _ r -> do goN (srcRange f) (thing f) @@ -895,9 +895,21 @@ mkPrimDecl = mkNoImplDecl DPrim mkForeignDecl :: - Maybe (Located Text) -> LPName -> Schema PName -> ParseM [TopDecl PName] -mkForeignDecl mbDoc nm ty = + Maybe (Located Text) -> Maybe LPName -> LPName -> Schema PName -> ParseM [TopDecl PName] +mkForeignDecl mbDoc mbCC nm ty = do let txt = unpackIdent (getIdent (thing nm)) + fgn <- case mbCC of + Nothing -> pure ForeignC + Just cc -> + case thing cc of + UnQual i + | tx == "c" -> pure ForeignC + | tx == "abstract" -> pure ForeignAbstract + where tx = identText i + _ -> errorMessage (srcRange cc) + [ "Invalid calling convention." + , "We support `c` and `abstract` at present." + ] unless (all isOk txt) (errorMessage (srcRange nm) [ "`" ++ txt ++ "` is not a valid foreign name." @@ -907,7 +919,7 @@ -- will be merged with this binding in the NoPat pass. In the parser they -- are just treated as a completely separate (non-foreign) binding with the -- same name. - pure (mkNoImplDecl (DForeign Nothing) mbDoc nm ty) + pure (mkNoImplDecl (DForeign fgn Nothing) mbDoc nm ty) where isOk c = c == '_' || isAlphaNum c @@ -943,7 +955,7 @@ Located Kind -> ParseM [TopDecl PName] mkPrimTypeDecl mbDoc (Forall as qs st ~(Just schema_rng)) finK = - case splitT schema_rng st of + case splitT st of Just (n,xs) -> do vs <- mapM tpK as unless (distinct (map fst vs)) $ @@ -975,19 +987,19 @@ Nothing -> errorMessage schema_rng ["Invalid primitive signature"] where - splitT r ty = case ty of - TLocated t r1 -> splitT r1 t - TUser n ts -> mkT r Located { srcRange = r, thing = n } ts - TInfix t1 n _ t2 -> mkT r n [t1,t2] + splitT ty = case ty of + TLocated t _ -> splitT t + TUser n ts -> mkT n ts + TInfix t1 n _ t2 -> mkT n [t1,t2] _ -> Nothing - mkT r n ts = do ts1 <- mapM (isVar r) ts + mkT n ts = do ts1 <- mapM isVar ts guard (distinct (map thing ts1)) pure (n,ts1) - isVar r ty = case ty of - TLocated t r1 -> isVar r1 t - TUser n [] -> Just Located { srcRange = r, thing = n } + isVar ty = case ty of + TLocated t _ -> isVar t + TUser n [] -> Just n _ -> Nothing -- inefficient, but the lists should be small @@ -1290,7 +1302,7 @@ , Just (_,bs) <- T.uncons bs' , Just b <- readMaybe (T.unpack bs) , let fromP = from loc - , let midP = fromP { col = col fromP + T.length as + 1 } -> + , let midP = advanceColBy (T.length as + 1) fromP -> -- these are backward because we reverse above pure [ Located { thing = TupleSel b Nothing , srcRange = loc { from = midP } @@ -1343,7 +1355,7 @@ pure Located { srcRange = rComb loc end , thing = Import - { iModule = thing impName + { iModule = impName , iAs = thing <$> mbAs , iSpec = thing <$> mbImportSpec , iInst = i @@ -1511,7 +1523,7 @@ case d of DImport i - | ImpTop _ <- iModule (thing i) + | ImpTop _ <- thing (iModule (thing i)) , Nothing <- iInst (thing i) -> cont [d] (addI i sig) @@ -1540,20 +1552,26 @@ ParseM [TopDecl PName] desugarInstImport i inst = do (m, ms) <- desugarMod - Module { mName = i { thing = iname } + Module { mName = iname , mDef = FunctorInstance - (iModule <$> i) inst emptyModuleInstance + origMod inst emptyModuleInstance , mInScope = mempty , mDocTop = Nothing } pure (DImport (newImp <$> i) : map modTop (ms ++ [m])) where - iname = mkUnqual + origMod = iModule (thing i) + + iname = Located { + thing =mkUnqual $ let pos = from (srcRange i) - in identAnonInstImport (line pos) (col pos) + in identAnonInstImport (line pos) (col pos), + srcRange = srcRange origMod + } + - newImp d = d { iModule = ImpNested iname + newImp d = d { iModule = ImpNested <$> iname , iInst = Nothing } diff --git a/src/Cryptol/Parser/Position.hs b/src/Cryptol/Parser/Position.hs --- a/src/Cryptol/Parser/Position.hs +++ b/src/Cryptol/Parser/Position.hs @@ -10,12 +10,31 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE RecordWildCards #-} -module Cryptol.Parser.Position where +module Cryptol.Parser.Position ( + -- * Position + Position, + line, col, colOffset, + start, + startOfLine, beforeStartOfLine, + move, moves, advanceColBy, + replPosition, + -- * Range + Range(..), + emptyRange, + rComb, rCombs, rCombMaybe, + rangeWithin, + + -- * Located + Located(..), + HasLoc(..), AddLoc(..), + at, + combLoc + +) where + import Data.Text(Text) import qualified Data.Text as T @@ -28,10 +47,39 @@ deriving (Eq, Ord, Show, Generic, NFData , Functor, Foldable, Traversable ) +data Position = Position { + pLine :: !Int, + -- ^ 1 based -data Position = Position { line :: !Int, col :: !Int } - deriving (Eq, Ord, Show, Generic, NFData) + pCol :: !Int, + -- ^ 1 based. Interpreting tabs. + -- This is used for layout processing and pretty printing. + pColOffset :: !Int + -- ^ 0 based. UTF-32 offset in the line. + -- Note that this does not interpret tabs. + -- It is used for comparisons. +} deriving (Show, Generic, NFData) + +line :: Position -> Int +line = pLine + +col :: Position -> Int +col = pCol + +colOffset :: Position -> Int +colOffset = pColOffset + +instance Eq Position where + x == y = line x == line y && colOffset x == colOffset y + +instance Ord Position where + compare x y = + case compare (line x) (line y) of + LT -> LT + EQ -> compare (colOffset x) (colOffset y) + GT -> GT + data Range = Range { from :: !Position , to :: !Position , source :: FilePath } @@ -49,17 +97,29 @@ emptyRange :: Range emptyRange = Range { from = start, to = start, source = "" } +replPosition :: (Int,Int) -> Position +replPosition (l,c) = Position { pLine = l, pCol = c, pColOffset = c } + start :: Position -start = Position { line = 1, col = 1 } +start = Position { pLine = 1, pCol = 1, pColOffset = 0 } +startOfLine :: Int -> Position +startOfLine n = start { pLine = n } + +beforeStartOfLine :: Int -> Position +beforeStartOfLine n = Position { pLine = n, pCol = 0, pColOffset = -1 } + +advanceColBy :: Int -> Position -> Position +advanceColBy n p = p { pCol = pCol p + n, pColOffset = pColOffset p + n } + move :: Position -> Char -> Position move p c = case c of - '\t' -> p { col = ((col p + 7) `div` 8) * 8 + 1 } - '\n' -> p { col = 1, line = 1 + line p } - _ -> p { col = 1 + col p } + '\t' -> p { pCol = ((col p + 7) `div` 8) * 8 + 1, pColOffset = colOffset p + 1 } + '\n' -> p { pCol = 1, pLine = 1 + line p, pColOffset = 0 } + _ -> p { pCol = 1 + col p, pColOffset = colOffset p + 1 } moves :: Position -> Text -> Position -moves p cs = T.foldl' move p cs +moves = T.foldl' move rComb :: Range -> Range -> Range rComb r1 r2 = Range { from = rFrom, to = rTo, source = source r1 } diff --git a/src/Cryptol/Parser/Utils.hs b/src/Cryptol/Parser/Utils.hs --- a/src/Cryptol/Parser/Utils.hs +++ b/src/Cryptol/Parser/Utils.hs @@ -17,6 +17,7 @@ , widthIdent ) where +import Cryptol.Parser.Position import Cryptol.Parser.AST widthIdent :: Ident @@ -25,23 +26,23 @@ underIdent :: Ident underIdent = mkIdent "_" -translateExprToNumT :: Expr PName -> Maybe (Type PName) -translateExprToNumT expr = +translateExprToNumT :: Range -> Expr PName -> Maybe (Type PName) +translateExprToNumT r0 expr = case expr of - ELocated e r -> (`TLocated` r) `fmap` translateExprToNumT e - EVar n | getIdent n == widthIdent -> pure (TUser n []) + ELocated e r -> (`TLocated` r) `fmap` translateExprToNumT r e + EVar n | getIdent n == widthIdent -> pure (TUser (Located r0 n) []) | getIdent n == underIdent -> pure TWild - EVar x -> return (TUser x []) + EVar x -> return (TUser (Located r0 x) []) ELit x -> cvtLit x - EApp e1 e2 -> do t1 <- translateExprToNumT e1 - t2 <- translateExprToNumT e2 + EApp e1 e2 -> do t1 <- translateExprToNumT r0 e1 + t2 <- translateExprToNumT r0 e2 tApp t1 t2 - EInfix a o f b -> do e1 <- translateExprToNumT a - e2 <- translateExprToNumT b + EInfix a o f b -> do e1 <- translateExprToNumT r0 a + e2 <- translateExprToNumT r0 b return (TInfix e1 o f e2) - EParens e -> do t <- translateExprToNumT e + EParens e -> do t <- translateExprToNumT r0 e return (TParens t Nothing) _ -> Nothing diff --git a/src/Cryptol/Prelude.hs b/src/Cryptol/Prelude.hs --- a/src/Cryptol/Prelude.hs +++ b/src/Cryptol/Prelude.hs @@ -45,4 +45,4 @@ primeECContents = $(embedFileRelative "lib/PrimeEC.cry") cryptolTcContents :: String -cryptolTcContents = B.unpack $(embedFileRelative "lib/CryptolTC.z3") +cryptolTcContents = B.unpack $(embedFileRelative "lib/CryptolTC.smt2") diff --git a/src/Cryptol/Project.hs b/src/Cryptol/Project.hs --- a/src/Cryptol/Project.hs +++ b/src/Cryptol/Project.hs @@ -116,7 +116,8 @@ -- Fails if we can't find the module at this path. scanFromPath :: FilePath -> LoadM Err ScanStatus scanFromPath fpath = - liftCallback (withPrependedSearchPath [takeDirectory fpath]) + getRootPath >>= \rootP -> + liftCallback (withPrependedSearchPath [rootP]) do foundFPath <- doModule (M.findFile fpath) mpath <- doIO (InFile <$> canonicalizePath foundFPath) scan mpath diff --git a/src/Cryptol/Project/Cache.hs b/src/Cryptol/Project/Cache.hs --- a/src/Cryptol/Project/Cache.hs +++ b/src/Cryptol/Project/Cache.hs @@ -1,19 +1,29 @@ -{-# Language OverloadedStrings, BlockArguments #-} +{-# Language OverloadedStrings, BlockArguments, BangPatterns #-} module Cryptol.Project.Cache where import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import qualified Data.Set as Set -import qualified Data.Text.IO as Text +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import qualified Data.ByteString as BS import Data.Set (Set) import System.Directory import System.FilePath as FP import System.IO.Error import qualified Toml import qualified Toml.Schema as Toml +import qualified Crypto.Hash.SHA256 as SHA256 import Cryptol.ModuleSystem.Fingerprint ( Fingerprint ) import Cryptol.ModuleSystem.Env +-- | This is something to identify a particular cache state. +-- We use a hash of the cache file at the moment. +type CacheId = BS.ByteString + +emptyCacheId :: CacheId +emptyCacheId = BS.empty + -- | The load cache. This is what persists across invocations. newtype LoadCache = LoadCache { cacheModules :: Map CacheModulePath CacheEntry @@ -116,15 +126,23 @@ emptyLoadCache :: LoadCache emptyLoadCache = LoadCache { cacheModules = mempty } -loadLoadCache :: IO LoadCache +-- | Load a cache. Also returns an id for the cahce. +-- If there is no cache (or it failed to load), then we return an empty id. +loadLoadCache :: IO (LoadCache, CacheId) loadLoadCache = - do txt <- Text.readFile loadCachePath + do bytes <- BS.readFile loadCachePath + let hash = SHA256.hash bytes + txt = Text.decodeUtf8 bytes case Toml.decode txt of - Toml.Success _ c -> pure c - Toml.Failure _ -> pure emptyLoadCache - `catchIOError` \_ -> pure emptyLoadCache + Toml.Success _ c -> pure (c,hash) + Toml.Failure _ -> pure (emptyLoadCache,emptyCacheId) + `catchIOError` \_ -> pure (emptyLoadCache,emptyCacheId) -saveLoadCache :: LoadCache -> IO () +-- | Save the cache. Returns an id for the cache. +saveLoadCache :: LoadCache -> IO BS.ByteString saveLoadCache cache = do createDirectoryIfMissing False metaDir - writeFile loadCachePath (show (Toml.encode cache)) + let txt = Text.pack (show (Toml.encode cache)) + !bytes = Text.encodeUtf8 txt + BS.writeFile loadCachePath bytes + pure (SHA256.hash bytes) diff --git a/src/Cryptol/Project/Config.hs b/src/Cryptol/Project/Config.hs --- a/src/Cryptol/Project/Config.hs +++ b/src/Cryptol/Project/Config.hs @@ -19,7 +19,7 @@ , modules :: [String] -- ^ Git-style patterns describing the files for the project. - } + } deriving Show data LoadProjectMode = RefreshMode -- load all files diff --git a/src/Cryptol/Project/Monad.hs b/src/Cryptol/Project/Monad.hs --- a/src/Cryptol/Project/Monad.hs +++ b/src/Cryptol/Project/Monad.hs @@ -20,6 +20,7 @@ , getFingerprint , lPutStrLn , getOldDocstringResults + , getRootPath ) where import Data.Map.Strict (Map) @@ -90,6 +91,9 @@ , loadCache :: LoadCache -- ^ The state of the cache before we started loading the project. + + , loadCacheId :: !CacheId + -- ^ An id for the cache when it was first loaded. } @@ -141,12 +145,14 @@ do loadCfg <- M.io do path <- canonicalizePath (root cfg) - cache <- case mode of - RefreshMode -> pure emptyLoadCache - UntestedMode -> loadLoadCache - ModifiedMode -> loadLoadCache + (cache,cacheId) <- + case mode of + RefreshMode -> pure (emptyLoadCache, emptyCacheId) + UntestedMode -> loadLoadCache + ModifiedMode -> loadLoadCache pure LoadConfig { canonRoot = path , loadCache = cache + , loadCacheId = cacheId } let loadState = LoadState { findModuleCache = mempty , fingerprints = mempty @@ -177,6 +183,9 @@ InFile p -> LoadM (asks ((`makeRelative` p) . canonRoot)) InMem l _ -> pure l +-- | Get the root of the project +getRootPath :: LoadM any FilePath +getRootPath = LoadM (asks canonRoot) -- | Get the fingerprint for the given module path. getCachedFingerprint :: ModulePath -> LoadM any (Maybe FullFingerprint) @@ -193,7 +202,7 @@ case Map.lookup (mname, searchPath) (findModuleCache ls) of Just mpath -> pure mpath Nothing -> - do modLoc <- doModule (findModule mname) + do modLoc <- doModule (findModule isrc mname) mpath <- case modLoc of InFile path -> InFile <$> doIO (canonicalizePath path) InMem l c -> pure (InMem l c) diff --git a/src/Cryptol/REPL/Browse.hs b/src/Cryptol/REPL/Browse.hs --- a/src/Cryptol/REPL/Browse.hs +++ b/src/Cryptol/REPL/Browse.hs @@ -22,7 +22,7 @@ data BrowseHow = BrowseExported | BrowseInScope -browseModContext :: BrowseHow -> ModContext -> PP.Doc Void +browseModContext :: BrowseHow -> ModContext -> PPDoc browseModContext how mc = runDoc (env disp) (vcat sections) where diff --git a/src/Cryptol/REPL/Command.hs b/src/Cryptol/REPL/Command.hs --- a/src/Cryptol/REPL/Command.hs +++ b/src/Cryptol/REPL/Command.hs @@ -48,6 +48,7 @@ -- Check docstrings , checkDocStrings + , updateDocstringCache , SubcommandResult(..) , DocstringResult(..) @@ -98,13 +99,14 @@ import Cryptol.Parser (parseExprWith,parseReplWith,ParseError(),Config(..),defaultConfig ,parseModName,parseHelpName,parseImpName) -import Cryptol.Parser.Position (Position(..),Range(..),HasLoc(..)) +import Cryptol.Parser.Position (replPosition,startOfLine,Range(..),HasLoc(..)) import qualified Cryptol.TypeCheck.AST as T +import qualified Cryptol.TypeCheck.Docstrings as T import qualified Cryptol.TypeCheck.Error as T import qualified Cryptol.TypeCheck.Parseable as T import qualified Cryptol.TypeCheck.Subst as T import Cryptol.TypeCheck.Solve(defaultReplExpr) -import Cryptol.TypeCheck.PP (dump) +import Cryptol.TypeCheck.PP (dump, emptyNameMap, ppWithNames) import qualified Cryptol.Utils.Benchmark as Bench import Cryptol.Utils.PP hiding (()) import Cryptol.Utils.Panic(panic) @@ -136,14 +138,15 @@ import Data.Function (on) import Data.List (intercalate, nub, isPrefixOf) import Data.Maybe (fromMaybe,mapMaybe,isNothing) +import Data.Foldable (traverse_) import System.Environment (lookupEnv) import System.Exit (ExitCode(ExitSuccess)) -import System.Process (shell,createProcess,waitForProcess) +import System.Process (shell,createProcess,waitForProcess,spawnProcess) import qualified System.Process as Process(runCommand) import System.FilePath((), (-<.>), isPathSeparator) import System.Directory(getHomeDirectory,setCurrentDirectory,doesDirectoryExist ,getTemporaryDirectory,setPermissions,removeFile - ,emptyPermissions,setOwnerReadable) + ,emptyPermissions,setOwnerReadable,doesFileExist) import System.IO (Handle,hFlush,stdout,openTempFile,hClose,openFile ,IOMode(..),hGetContents,hSeek,SeekMode(..)) @@ -318,6 +321,16 @@ , CommandDescr [ ":check-docstrings" ] [] (ModNameArg checkDocStringsCmd) "Run the REPL code blocks in the module's docstring comments" "" + , CommandDescr [ ":print-docstrings" ] [] (ModNameArg printDocStringsCmd) + "Print the REPL code blocks in the module's docstring comments" + "" + , CommandDescr [ ":saw" ] [] (FilenameArg sawCmd) + "Load a given SAW file." + (unlines + [ "The path to SAW is determined from the environment variable" + , "CRYPTOL_SAW. The user option sawFlags contains flags that will be" + , "added to all calls to SAW." + ]) ] commandList :: [CommandDescr] @@ -507,7 +520,7 @@ let nameStr x = show (fixNameDisp disp (pp x)) if null xs then do - rPutStrLn "There are no properties in scope." + rPutStrLn "There are no properties in this module." pure emptyCommandResult { crSuccess = False } else do let evalProp result (x,d) = @@ -766,6 +779,11 @@ -- | Attempts to prove the given term is safe for all inputs safeCmd :: String -> (Int,Int) -> Maybe FilePath -> REPL CommandResult +--- Throw error when no argument is passed to a command expecting one +safeCmd "" _pos _fnm = + do rPutStrLn $ invalidCommandArgument ":safe" + return emptyCommandResult {crSuccess = False} + safeCmd str pos fnm = do proverName <- getKnownUser "prover" fileName <- getKnownUser "smtFile" @@ -787,7 +805,7 @@ panic "REPL.Command" [ "got EmptyResult for online prover query" ] ProverError msg -> - do rPutStrLn msg + do rPrintDoc msg pure emptyCommandResult { crSuccess = False } ThmResult _ts -> @@ -827,7 +845,7 @@ let nameStr x = show (fixNameDisp disp (pp x)) if null xs then do - rPutStrLn "There are no properties in scope." + rPutStrLn "There are no properties in this module." pure emptyCommandResult { crSuccess = False } else do let check acc (x,d) = do @@ -877,7 +895,7 @@ EmptyResult -> panic "REPL.Command" [ "got EmptyResult for online prover query" ] - ProverError msg -> False <$ rPutStrLn msg + ProverError msg -> False <$ rPrintDoc msg ThmResult ts -> do rPutStrLn (if isSat then "Unsatisfiable" else "Q.E.D.") @@ -1028,7 +1046,7 @@ Left sbvCfg -> do result <- liftModuleCmd $ SBV.satProveOffline sbvCfg cmd case result of - Left msg -> False <$ rPutStrLn msg + Left msg -> False <$ rPrintDoc msg Right smtlib -> do io $ displayMsg case mfile of @@ -1051,7 +1069,7 @@ hGetContents h >>= put case result of - Just msg -> rPutStrLn msg + Just msg -> rPrintDoc msg Nothing -> return () pure True @@ -1090,7 +1108,13 @@ let argName = M.packIdent ("arg" ++ show n) in ((argName,t),(argName,e)) + specializeCmd :: String -> (Int,Int) -> Maybe FilePath -> REPL CommandResult +--- Throw error when no argument is passed to a command expecting one +specializeCmd "" _pos _fnm = + do rPutStrLn $ invalidCommandArgument ":debug_specialize" + return emptyCommandResult {crSuccess = False} + specializeCmd str pos fnm = do parseExpr <- replParseExpr str pos fnm (_, expr, schema) <- replCheckExpr parseExpr @@ -1105,6 +1129,11 @@ pure emptyCommandResult { crValue = Just value } refEvalCmd :: String -> (Int,Int) -> Maybe FilePath -> REPL CommandResult +--- Throw error when no argument is passed to a command expecting one +refEvalCmd "" _pos _fnm = + do rPutStrLn $ invalidCommandArgument ":eval" + return emptyCommandResult {crSuccess = False} + refEvalCmd str pos fnm = do parseExpr <- replParseExpr str pos fnm (_, expr, schema) <- replCheckExpr parseExpr @@ -1117,6 +1146,11 @@ pure emptyCommandResult { crValue = Just value } astOfCmd :: String -> (Int,Int) -> Maybe FilePath -> REPL CommandResult +--- Throw error when no argument is passed to a command expecting one +astOfCmd "" _pos _fnm = + do rPutStrLn $ invalidCommandArgument ":ast" + return emptyCommandResult {crSuccess = False} + astOfCmd str pos fnm = do expr <- replParseExpr str pos fnm (re,_,_) <- replCheckExpr (P.noPos expr) @@ -1129,7 +1163,13 @@ rPrint $ T.showParseable $ concatMap T.mDecls $ M.loadedModules me pure emptyCommandResult + typeOfCmd :: String -> (Int,Int) -> Maybe FilePath -> REPL CommandResult +--- Throw error when no argument is passed to a command expecting one +typeOfCmd "" _pos _fnm = + do rPutStrLn $ invalidCommandArgument ":type" + return emptyCommandResult {crSuccess = False} + typeOfCmd str pos fnm = do expr <- replParseExpr str pos fnm @@ -1137,21 +1177,40 @@ -- XXX need more warnings from the module system whenDebug (rPutStrLn (dump def)) + + --- Get module context parameters + modCtxtParams <- M.mctxParams <$> getFocusedEnv + --- Get the map that maps variable names to module type parameters + let modParamMap = T.mpnTypes (M.modContextParamNames modCtxtParams) + --- Get a list of type parameters from all module type parameterss in the Map + modTParams = map T.mtpParam (Map.elems modParamMap) + + cfg = defaultPPCfg + --- Load module type param into a new empty NameMap + ns = T.addTNames cfg modTParams emptyNameMap + --- Create a pretty printed string + ppAll = ppWithNames ns sig + fDisp <- M.mctxNameDisp <$> getFocusedEnv -- type annotation ':' has precedence 2 let output = show $ runDoc fDisp $ group $ hang - (ppPrec 2 expr <+> text ":") 2 (pp sig) + (ppPrec 2 expr <+> text ":") 2 ppAll rPutStrLn output pure emptyCommandResult { crType = Just output } timeCmd :: String -> (Int, Int) -> Maybe FilePath -> REPL CommandResult +--- Throw error when no argument is passed to a command expecting one +timeCmd "" _pos _fnm = + do rPutStrLn $ invalidCommandArgument ":time" + return emptyCommandResult {crSuccess = False} + timeCmd str pos fnm = do period <- getKnownUser "timeMeasurementPeriod" :: REPL Int quiet <- getKnownUser "timeQuiet" + pExpr <- replParseExpr str pos fnm unless quiet $ rPutStrLn $ "Measuring for " ++ show period ++ " seconds" - pExpr <- replParseExpr str pos fnm (_, def, sig) <- replCheckExpr pExpr replPrepareCheckedExpr def sig >>= \case Nothing -> raise (EvalPolyError sig) @@ -1439,6 +1498,10 @@ Nothing -> do rPutStrLn "Invalid module name" pure emptyCommandResult { crSuccess = False } + Just (P.ImpTop mn) | M.modNameToText mn == "Main" -> do + mainContexts <- M.mainContexts <$> getModuleEnv + mapM_ (rPrint . browseModContext BrowseExported) mainContexts + pure emptyCommandResult Just pimpName -> do impName <- liftModuleCmd (`M.runModuleM` M.renameImpNameInCurrentEnv pimpName) mb <- M.modContextOf impName <$> getModuleEnv @@ -1531,8 +1594,8 @@ runShellCmd :: String -> REPL CommandResult runShellCmd cmd = io $ do h <- Process.runCommand cmd - _ <- waitForProcess h - return emptyCommandResult -- This could check for exit code 0 + e <- waitForProcess h + pure emptyCommandResult { crSuccess = e == ExitSuccess } cdCmd :: FilePath -> REPL CommandResult cdCmd f | null f = do rPutStrLn $ "[error] :cd requires a path argument" @@ -1563,26 +1626,27 @@ replParseInput str lineNum fnm = replParse (parseReplWith cfg . T.pack) str where cfg = case fnm of - Nothing -> interactiveConfig{ cfgStart = Position lineNum 1 } + Nothing -> interactiveConfig{ cfgStart = startOfLine lineNum } Just f -> defaultConfig { cfgSource = f - , cfgStart = Position lineNum 1 + , cfgStart = startOfLine lineNum } replParseExpr :: String -> (Int,Int) -> Maybe FilePath -> REPL (P.Expr P.PName) -replParseExpr str (l,c) fnm = replParse (parseExprWith cfg. T.pack) str +replParseExpr str p fnm = replParse (parseExprWith cfg. T.pack) str where + pos = replPosition p cfg = case fnm of - Nothing -> interactiveConfig{ cfgStart = Position l c } + Nothing -> interactiveConfig{ cfgStart = pos } Just f -> defaultConfig { cfgSource = f - , cfgStart = Position l c + , cfgStart = pos } mkInteractiveRange :: (Int,Int) -> Maybe FilePath -> Range -mkInteractiveRange (l,c) mb = Range p p src +mkInteractiveRange p mb = Range pos pos src where - p = Position l c + pos = replPosition p src = case mb of Nothing -> "" Just b -> b @@ -1911,6 +1975,13 @@ findNbCommand True str = lookupTrieExact str nbCommands findNbCommand False str = lookupTrie str nbCommands +-- | Construct a helpful error message for commad parse errors where +-- a cryptol command is not given expression arg when its expecting one. +invalidCommandArgument :: String -> String +invalidCommandArgument cmd = concat ["ERROR: Command `", cmd + , "` needs an EXPR argument. See `:help " + , cmd, "` for more details."] + -- | Parse a line as a command. parseCommand :: (String -> [CommandDescr]) -> String -> Maybe Command parseCommand findCmd line = do @@ -1993,67 +2064,26 @@ rPutStrLn "}" pure emptyCommandResult --- | Extract the code blocks from the body of a docstring. --- --- A single code block starts with at least 3 backticks followed by an --- optional language specifier of "cryptol". This allowed other kinds --- of code blocks to be included (and ignored) in docstrings. Longer --- backtick sequences can be used when a code block needs to be able to --- contain backtick sequences. --- --- @ --- /** --- * A docstring example --- * --- * ```cryptol --- * :check example --- * ``` --- */ --- @ -extractCodeBlocks :: T.Text -> [[T.Text]] -extractCodeBlocks raw = go [] (T.lines raw) - where - go finished [] = reverse finished - go finished (x:xs) - | (spaces, x1) <- T.span (' ' ==) x - , (ticks, x2) <- T.span ('`' ==) x1 - , 3 <= T.length ticks - , not (T.elem '`' x2) - , let info = T.strip x2 - = if info `elem` ["", "repl"] -- supported languages "unlabeled" and repl - then keep finished (T.length spaces) (T.length ticks) [] xs - else skip finished ticks xs - | otherwise = go finished xs - - -- process a code block that we're keeping - keep finished _ _ acc [] = go (reverse acc : finished) [] -- unterminated code fences are defined to be terminated by github - keep finished indentLen ticksLen acc (x:xs) - | x1 <- T.dropWhile (' ' ==) x - , (ticks, x2) <- T.span ('`' ==) x1 - , ticksLen <= T.length ticks - , T.all (' ' ==) x2 - = go (reverse acc : finished) xs - - | otherwise = - let x' = - case T.span (' ' ==) x of - (spaces, x1) - | T.length spaces <= indentLen -> x1 - | otherwise -> T.drop indentLen x - in keep finished indentLen ticksLen (x' : acc) xs - - -- process a code block that we're skipping - skip finished _ [] = go finished [] - skip finished close (x:xs) - | close == x = go finished xs - | otherwise = skip finished close xs - data SubcommandResult = SubcommandResult { srInput :: T.Text , srResult :: CommandResult , srLog :: String } +printBlock :: [T.Text] -> REPL () +printBlock block = + mapM_ printLine (continuedLines block) + +printLine :: T.Text -> REPL () +printLine line + | T.all isSpace line = pure () + | otherwise = + case parseCommand (findNbCommand True) (T.unpack line) of + Nothing -> rPutStrLn "Failed to parse command" + Just Ambiguous{} -> rPutStrLn "Ambiguous command" + Just Unknown{} -> rPutStrLn "Unknown command" + Just (Command _) -> rPutStrLn (T.unpack line) + -- | Check a single code block from inside a docstring. -- -- The result will contain the results of processing the commands up to @@ -2147,10 +2177,12 @@ -- | Apply control character semantics to the result of the logger interpretControls :: String -> String -interpretControls ('\b' : xs) = interpretControls xs -interpretControls (_ : '\b' : xs) = interpretControls xs -interpretControls (x : xs) = x : interpretControls xs -interpretControls [] = [] +interpretControls = f [] + where + f [] ('\b':ys) = f [] ys -- skips unmatched \b + f (_:xs) ('\b':ys) = f xs ys + f xs (y :ys) = f (y:xs) ys + f xs [] = reverse xs -- | The result of running a docstring as attached to a definition data DocstringResult = DocstringResult @@ -2162,7 +2194,7 @@ checkDocItem :: T.DocItem -> REPL DocstringResult checkDocItem item = do rPrint (" Docstrings on" <+> pp (T.docFor item)) - xs <- case traverse extractCodeBlocks (T.docText item) of + xs <- case traverse T.extractCodeBlocks (T.docText item) of [] -> pure [] -- optimization bs -> Ex.bracket @@ -2174,63 +2206,88 @@ , drFences = xs } +printDocItem :: T.DocItem -> REPL () +printDocItem item = do + let bs = traverse T.extractCodeBlocks (T.docText item) + traverse_ printBlock (concat bs) + +printDocStrings :: M.LoadedModule -> REPL () +printDocStrings m = do + let dat = M.lmdModule (M.lmData m) + let ds = T.gatherModuleDocstrings (M.ifaceNameToModuleMap (M.lmInterface m)) dat + traverse_ printDocItem ds + + + -- | Check all of the docstrings in the given module. -- -- The outer list elements correspond to the code blocks from the -- docstrings in file order. Each inner list corresponds to the -- REPL commands inside each of the docstrings. -checkDocStrings :: M.LoadedModule -> REPL [DocstringResult] -checkDocStrings m = do +checkDocStrings :: M.LoadedModule -> Maybe Proj.CacheId -> REPL ([DocstringResult], Proj.CacheId) +checkDocStrings m expectCache = do let dat = M.lmdModule (M.lmData m) rPrint ("Checking module" <+> pp (T.mName dat)) let ds = T.gatherModuleDocstrings (M.ifaceNameToModuleMap (M.lmInterface m)) dat results <- traverse checkDocItem ds - updateDocstringCache m (all checkDocstringResult results) - pure results + cid <- updateDocstringCache m results expectCache + pure (results,cid) checkDocstringResult :: DocstringResult -> Bool checkDocstringResult r = all (all (crSuccess . srResult)) (drFences r) -updateDocstringCache :: M.LoadedModule -> Bool -> REPL () -updateDocstringCache m result = - do cache <- io Proj.loadLoadCache - case M.lmFilePath m of - M.InMem{} -> pure () - M.InFile fp -> - case Map.lookup (Proj.CacheInFile fp) (Proj.cacheModules cache) of - Nothing -> pure () - Just entry -> - if Proj.moduleFingerprint (Proj.cacheFingerprint entry) /= M.fiFingerprint (M.lmFileInfo m) - then pure () - else - do let entry' = entry { Proj.cacheDocstringResult = Just result } - let cache' = cache { Proj.cacheModules = Map.insert (Proj.CacheInFile fp) entry' (Proj.cacheModules cache) } - io (Proj.saveLoadCache cache') +updateDocstringCache :: M.LoadedModule -> [DocstringResult] -> Maybe Proj.CacheId -> REPL Proj.CacheId +updateDocstringCache m result expectCache = + do (cache,cacheId) <- io Proj.loadLoadCache + case expectCache of + Just c | c /= cacheId -> pure cacheId + _ -> + case M.lmFilePath m of + M.InMem{} -> pure cacheId + M.InFile fp -> + case Map.lookup (Proj.CacheInFile fp) (Proj.cacheModules cache) of + Nothing -> pure cacheId + Just entry -> + if Proj.moduleFingerprint (Proj.cacheFingerprint entry) /= M.fiFingerprint (M.lmFileInfo m) + then pure cacheId + else + do let entry' = entry { Proj.cacheDocstringResult = Just (all checkDocstringResult result) } + let cache' = cache { Proj.cacheModules = Map.insert (Proj.CacheInFile fp) entry' (Proj.cacheModules cache) } + io (Proj.saveLoadCache cache') --- | Evaluate all the docstrings in the specified module. --- --- This command succeeds when: --- * the module can be found --- * the docstrings can be parsed for code blocks --- * all of the commands in the docstrings succeed -checkDocStringsCmd :: - String {- ^ module name -} -> - REPL CommandResult -checkDocStringsCmd input +withModule :: String -> (P.ModName -> REPL CommandResult) -> REPL CommandResult +withModule input f | null input = do mb <- getLoadedMod case lName =<< mb of Nothing -> do rPutStrLn "No current module" pure emptyCommandResult { crSuccess = False } - Just mn -> checkModName 0 mn + Just mn -> f mn | otherwise = case parseModName input of Nothing -> do rPutStrLn "Invalid module name" pure emptyCommandResult { crSuccess = False } - Just mn -> checkModName 0 mn + Just mn -> f mn +printDocStringsCmd :: + String {- ^ module name -} -> + REPL CommandResult +printDocStringsCmd input = withModule input checkModNameForPrint + +-- | Evaluate all the docstrings in the specified module. +-- +-- This command succeeds when: +-- * the module can be found +-- * the docstrings can be parsed for code blocks +-- * all of the commands in the docstrings succeed +checkDocStringsCmd :: + String {- ^ module name -} -> + REPL CommandResult +checkDocStringsCmd input = withModule input (checkModName 0) + + countOutcomes :: [[SubcommandResult]] -> (Int, Int, Int) countOutcomes = foldl' countOutcomes1 (0, 0, 0) where @@ -2242,9 +2299,8 @@ | crSuccess (srResult result) = (successes + 1, nofences, failures) | otherwise = (successes, nofences, failures + 1) - -checkModName :: Int -> P.ModName -> REPL CommandResult -checkModName ind mn = +withValidModule :: P.ModName -> String -> (M.LoadedModule -> REPL CommandResult) -> REPL CommandResult +withValidModule mn tab f = do env <- getModuleEnv case M.lookupModule mn env of Nothing -> @@ -2259,16 +2315,26 @@ | T.isParametrizedModule (M.lmdModule (M.lmData fe)) -> do rPutStrLn (tab ++ "Skipping docstrings on parameterized module") pure emptyCommandResult - | otherwise -> do - results <- checkDocStrings fe - let (successes, nofences, failures) = countOutcomes [concat (drFences r) | r <- results] - rPutStrLn (tab ++ "Successes: " ++ show successes ++ + | otherwise -> f fe + + +checkModName :: Int -> P.ModName -> REPL CommandResult +checkModName ind mn = + withValidModule mn tab (\m -> do + (results,_) <- checkDocStrings m Nothing + let (successes, nofences, failures) = countOutcomes [concat (drFences r) | r <- results] + rPutStrLn ("Successes: " ++ show successes ++ ", No fences: " ++ show nofences ++ ", Failures: " ++ show failures) - pure emptyCommandResult { crSuccess = failures == 0 } - where - tab = replicate ind ' ' + pure emptyCommandResult { crSuccess = failures == 0 }) + where tab = replicate ind ' ' +checkModNameForPrint :: P.ModName -> REPL CommandResult +checkModNameForPrint mn = + withValidModule mn "" (\m -> do + printDocStrings m + pure emptyCommandResult { crSuccess = True }) + -- | Load a project. -- Note that this does not update the Cryptol environment, it only updates -- the project cache. @@ -2340,10 +2406,59 @@ rPutStrLn ("Passing: " ++ show passing ++ ", Failing: " ++ show failing ++ ", Missing: " ++ show missing) - io (Proj.saveLoadCache (Proj.LoadCache cache)) + _cacheId <- io (Proj.saveLoadCache (Proj.LoadCache cache)) pure emptyCommandResult { crSuccess = success } +-- | Get the path to the SAW command. +-- Search options, in order: +-- environment variable CRYPTOL_SAW=/path/to/saw +-- whatever's in $PATH +getSAW :: REPL (String, [String]) +getSAW = do + io (lookupEnv "CRYPTOL_SAW") >>= \case + Just s -> do + let saw = lexFlags s + case saw of + cmd : args -> pure (cmd, args) + [] -> pure ("", []) + Nothing -> pure ("saw", []) + +-- | Run SAW on a file. +-- +-- This command succeeds when: +-- * SAW can be found +-- * the file can be found +-- * SAW processes the file successfully +sawCmd :: + FilePath {- ^ SAW filename -} -> + REPL CommandResult +sawCmd input = do + present <- io $ doesFileExist input + if present then do + (cmd, args) <- getSAW + flags <- getKnownUser "sawFlags" + if cmd == "" then do + rPutStrLn $ "SAW `" ++ cmd ++ "' was empty." + pure emptyCommandResult { crSuccess = False } + else do + hdl <- io $ spawnProcess cmd (args ++ lexFlags flags ++ [input]) + exitCode <- io $ waitForProcess hdl + pure emptyCommandResult { crSuccess = exitCode == ExitSuccess } + else do + rPutStrLn $ "File `" ++ input ++ "' does not exist." + pure emptyCommandResult { crSuccess = False } + ppInvalidStatus :: Proj.InvalidStatus -> Doc ppInvalidStatus = \case Proj.InvalidModule modErr -> pp modErr Proj.InvalidDep d _ -> "Error in dependency: " <> pp d + +lexFlags :: String -> [String] +lexFlags cs = + case dropWhile isSpace cs of + [] -> [] + ds@(c : _) + | c == '"', [(str,rest)] <- lex ds -> read str : lexFlags rest + | otherwise -> + let (as,rest) = break isSpace ds + in as : lexFlags rest diff --git a/src/Cryptol/REPL/Help.hs b/src/Cryptol/REPL/Help.hs --- a/src/Cryptol/REPL/Help.hs +++ b/src/Cryptol/REPL/Help.hs @@ -268,7 +268,8 @@ let cs = T.ntConstraints nt unless (null cs) $ do let example = T.TNominal nt (map (T.TVar . T.tpVar) vs) - ns = T.addTNames vs emptyNameMap + ppcfg = defaultPPCfg { ppcfgNameDisp = nameEnv } + ns = T.addTNames ppcfg vs emptyNameMap rs = [ "•" <+> ppWithNames ns c | c <- cs ] rPutStrLn "" rPrint $ runDoc nameEnv $ indent 4 $ diff --git a/src/Cryptol/REPL/Monad.hs b/src/Cryptol/REPL/Monad.hs --- a/src/Cryptol/REPL/Monad.hs +++ b/src/Cryptol/REPL/Monad.hs @@ -29,6 +29,7 @@ , rPutStrLn , rPutStr , rPrint + , rPrintDoc -- ** Errors , REPLException(..) @@ -84,6 +85,8 @@ , getLogger , setLogger , setPutStr + , getDocAnnotStyle + , setDocAnnotStyle -- ** Smoke Test , smokeTest @@ -149,6 +152,7 @@ import Prelude () import Prelude.Compat +import Cryptol.ModuleSystem.Monad (ModuleInput(minpSaveRenamed)) -- REPL Environment ------------------------------------------------------------ @@ -176,6 +180,9 @@ , eIsBatch :: Bool -- ^ Are we in batch mode. + , eDocAnnotStyle :: AnnotStyle + -- ^ How to pretty print `Doc`s (e.g., use ANSI or not) + , eModuleEnv :: M.ModuleEnv -- ^ The current environment of all things loaded. @@ -232,6 +239,7 @@ , eTCSolver = Nothing , eTCSolverRestarts = 0 , eRandomGen = rng + , eDocAnnotStyle = AnsiAnnot } -- | Build up the prompt for the REPL. @@ -630,6 +638,23 @@ rPrint :: Show a => a -> REPL () rPrint x = rPutStrLn (show x) +-- | How should we render `Doc`s +getDocAnnotStyle :: REPL AnnotStyle +getDocAnnotStyle = eDocAnnotStyle <$> getRW + +-- | Specify how to render `Doc`s +setDocAnnotStyle :: AnnotStyle -> REPL () +setDocAnnotStyle a = modifyRW_ (\rw -> rw { eDocAnnotStyle = a }) + +-- | Print a `Doc` to the logger. This differs to just using `rPrint` +-- in that it will consult the annotation style setting to determine how +-- to render the `Doc`. +rPrintDoc :: Doc -> REPL () +rPrintDoc doc = + do + s <- getDocAnnotStyle + rPrint (setAnnotStyle s doc) + getFocusedEnv :: REPL M.ModContext getFocusedEnv = M.focusedEnv <$> getModuleEnv @@ -648,29 +673,45 @@ return (map (show . pp) (Map.keys (M.namespaceMap M.NSType fNames))) -- | Return a list of property names, sorted by position in the file. --- Only properties defined in the current module are returned, including --- private properties in the current module. Imported properties are not --- returned. +-- Only properties defined in the currently focused module are returned, +-- (including private properties). Other properties that are in scope +-- are not returned. getPropertyNames :: REPL ([(M.Name, T.Decl)], NameDisp) getPropertyNames = do fe <- getFocusedEnv let nd = M.mctxNameDisp fe - mblm <- fmap (lName =<<) getLoadedMod - case mblm of + mbFocused <- M.meFocusedModule <$> getModuleEnv + case mbFocused of Nothing -> pure ([], nd) - Just mn -> - do mb <- M.lookupModule mn <$> getModuleEnv + Just focusMod -> + do + mb <- M.lookupModule modName <$> getModuleEnv case mb of Nothing -> pure ([], nd) Just lm -> pure (ps, nd) where ps = sortBy (comparing (from . M.nameLoc . fst)) - [ (T.dName d,d) + [ (nm,d) | d <- T.groupDecls =<< T.mDecls (M.lmdModule (M.lmData lm)) + , let nm = T.dName d , T.PragmaProperty `elem` T.dPragmas d + , consider nm ] - + where + consider :: M.Name -> Bool + (modName,consider) = + case focusMod of + P.ImpTop mn -> (mn, const True) + P.ImpNested m -> + ( M.nameTopModule m, + \d -> + case I.modPathCommon mp (M.nameModPath d) of + Just (_, [], _ : _) -> True + _ -> False + ) + where mp = M.nameModPath m + getModNames :: REPL [I.ModName] getModNames = @@ -716,6 +757,7 @@ , minpByteReader = BS.readFile , minpModuleEnv = env , minpTCSolver = tcSolver + , minpSaveRenamed = False } -- | Given an existing qualified name, prefix it with a @@ -1099,6 +1141,9 @@ , simpleOpt "timeQuiet" ["time-quiet"] (EnvBool False) noCheck "Suppress output of :time command and only bind result to `it`." + + , simpleOpt "sawFlags" ["saw-flags"] (EnvString "-v 0") noCheck + "Flags for all calls to SAW." ] diff --git a/src/Cryptol/Symbolic.hs b/src/Cryptol/Symbolic.hs --- a/src/Cryptol/Symbolic.hs +++ b/src/Cryptol/Symbolic.hs @@ -16,12 +16,14 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE BangPatterns #-} module Cryptol.Symbolic ( ProverCommand(..) , QueryType(..) , SatNum(..) , ProverResult(..) + , SatResult , ProverStats , CounterExampleType(..) -- * FinType @@ -44,13 +46,14 @@ ) where -import Control.Monad (foldM) +import Control.Monad (foldM,zipWithM) import qualified Data.IntMap.Strict as IntMap import Data.IORef(IORef) import Data.List (genericReplicate) import Data.Ratio import Data.Vector(Vector) import qualified Data.Vector as Vector +import Data.Bifunctor import qualified LibBF as FP @@ -120,27 +123,34 @@ | ThmResult [TValue] | CounterExample CounterExampleType SatResult | EmptyResult - | ProverError String + | ProverError Doc -predArgTypes :: QueryType -> Schema -> Either String [FinType] +predArgTypes :: QueryType -> Schema -> Either Doc [FinType] predArgTypes qtype schema@(Forall ts ps ty) | null ts && null ps = - case go <$> (evalType mempty ty) of - Right (Just fts) -> Right fts - _ | SafetyQuery <- qtype -> Left $ "Expected finite result type:\n" ++ show (pp schema) - | otherwise -> Left $ "Not a valid predicate type:\n" ++ show (pp schema) - | otherwise = Left $ "Not a monomorphic type:\n" ++ show (pp schema) + case evalType mempty ty of + Left _ -> Left "Predicate needs to be of kind *" + Right tval -> + case go tval of + Right fts -> Right fts + Left (msg,path) + | SafetyQuery <- qtype -> Left ("Expected finite result type:" $$ indent 2 (pp schema)) + | otherwise -> Left ("Not a valid predicate type:" $$ indent 2 (ppPrecWithAnnot [(path,AnnError)] 0 tval) $$ text msg) + | otherwise = Left ("Not a monomorphic type:" $$ indent 2 (pp schema)) where - go :: TValue -> Maybe [FinType] - go TVBit = Just [] - go (TVFun ty1 ty2) = (:) <$> finType ty1 <*> go ty2 - go tv - | Just _ <- finType tv - , SafetyQuery <- qtype - = Just [] - - | otherwise - = Nothing + go :: TValue -> Either (String,[Int]) [FinType] + go TVBit = Right [] + go (TVFun ty1 ty2) = (:) <$> arg (finType ty1) <*> res (go ty2) + where + arg = first (\(msg,path) -> ("Unsupported " ++ msg ++ " argument", 0 : path)) + res = first (second (1 :)) + go tv = + case finType tv of + Left (msg,err) -> Left ("Unsupported result type: " ++ msg, err) + Right _ -> + case qtype of + SafetyQuery -> Right [] + _ -> Left ("Predicates need a boolean result", []) data FinType = FTBit @@ -157,26 +167,43 @@ FStruct (RecordMap Ident FinType) | FEnum (Vector (ConInfo FinType)) -finType :: TValue -> Maybe FinType + +-- | Convert a type value to a finite type. On error, we return a +-- description of what's wrong and a path +-- to the offending subterm on the `Left`. +finType :: TValue -> Either (String,[Int]) FinType finType ty = case ty of - TVBit -> Just FTBit - TVInteger -> Just FTInteger - TVIntMod n -> Just (FTIntMod n) - TVRational -> Just FTRational - TVFloat e p -> Just (FTFloat e p) - TVSeq n t -> FTSeq n <$> finType t - TVTuple ts -> FTTuple <$> traverse finType ts - TVRec fields -> FTRecord <$> traverse finType fields - TVNominal u ts nv -> FTNominal u ts <$> + TVBit -> Right FTBit + TVInteger -> Right FTInteger + TVIntMod n -> Right (FTIntMod n) + TVRational -> Right FTRational + TVFloat e p -> Right (FTFloat e p) + TVSeq n t -> FTSeq n <$> doSub 0 (finType t) + TVTuple ts -> FTTuple <$> zipWithM doSub [ 0 .. ] (map finType ts) + TVRec fields -> FTRecord <$> doFields fields + where + TVNominal u ts nv -> setHere $ FTNominal u ts <$> case nv of TVStruct body -> FStruct <$> traverse finType body TVEnum cs -> FEnum <$> traverse (traverse finType) cs - TVAbstract -> Nothing + TVAbstract -> Left ("abstract nominal type", []) - TVArray{} -> Nothing - TVStream{} -> Nothing - TVFun{} -> Nothing + TVArray{} -> Left ("array", []) + TVStream{} -> Left ("infinite stream", []) + TVFun{} -> Left ("function", []) + + where + setHere sub = + case sub of + Left (msg,_) -> Left (msg,[]) + Right a -> Right a + + doSub x = first (fmap (x:)) + + doFields = fmap recordFromFields . zipWithM doSub [0..] . map doField . displayFields + doField (l,t) = (\a -> (l,a)) <$> finType t + finTypeToType :: FinType -> Type finTypeToType fty = diff --git a/src/Cryptol/Symbolic/SBV.hs b/src/Cryptol/Symbolic/SBV.hs --- a/src/Cryptol/Symbolic/SBV.hs +++ b/src/Cryptol/Symbolic/SBV.hs @@ -70,6 +70,7 @@ import Cryptol.Utils.Panic(panic) import Cryptol.Utils.Logger(logPutStrLn) import Cryptol.Utils.RecordMap +import Cryptol.Utils.PP import Prelude () @@ -220,7 +221,7 @@ thmSMTResults :: SBV.ThmResult -> [SBV.SMTResult] thmSMTResults (SBV.ThmResult r) = [r] -proverError :: String -> M.ModuleCmd (Maybe String, ProverResult) +proverError :: Doc -> M.ModuleCmd (Maybe String, ProverResult) proverError msg minp = return (Right ((Nothing, ProverError msg), M.minpModuleEnv minp), []) @@ -379,7 +380,7 @@ prepareQuery :: Eval.EvalOpts -> ProverCommand -> - M.ModuleT IO (Either String ([FinType], SBV.Symbolic SBV.SVal)) + M.ModuleT IO (Either Doc ([FinType], SBV.Symbolic SBV.SVal)) prepareQuery evo ProverCommand{..} = do ds <- do (_mp, ent) <- M.loadModuleFrom True (M.FromModule preludeReferenceName) let m = tcTopEntityToModule ent @@ -493,7 +494,7 @@ [] -> return $ ThmResult (unFinType <$> ts) -- otherwise something is wrong - resultsHead:_ -> return $ ProverError res + resultsHead:_ -> return $ ProverError (text res) #if MIN_VERSION_sbv(10,0,0) where res | isSat = show $ SBV.AllSatResult False False False results -- sbv-10.0.0 removes the `allSatHasPrefixExistentials` field @@ -544,7 +545,7 @@ -- -- This method returns either an error message or the text of -- the SMT input file corresponding to the given prover command. -satProveOffline :: SBVProverConfig -> ProverCommand -> M.ModuleCmd (Either String String) +satProveOffline :: SBVProverConfig -> ProverCommand -> M.ModuleCmd (Either Doc String) satProveOffline _proverCfg pc@ProverCommand {..} = protectStack (\msg minp -> return (Right (Left msg, M.minpModuleEnv minp), [])) $ \minp -> M.runModuleM minp $ @@ -566,14 +567,14 @@ Left msg -> return (Left msg) Right (_ts, q) -> Right <$> M.io (generateSMTBenchmark q) -protectStack :: (String -> M.ModuleCmd a) +protectStack :: (Doc -> M.ModuleCmd a) -> M.ModuleCmd a -> M.ModuleCmd a protectStack mkErr cmd modEnv = X.catchJust isOverflow (cmd modEnv) handler where isOverflow X.StackOverflow = Just () isOverflow _ = Nothing - msg = "Symbolic evaluation failed to terminate." + msg = text "Symbolic evaluation failed to terminate." handler () = mkErr msg modEnv -- | Given concrete values from the solver and a collection of finite types, diff --git a/src/Cryptol/Symbolic/What4.hs b/src/Cryptol/Symbolic/What4.hs --- a/src/Cryptol/Symbolic/What4.hs +++ b/src/Cryptol/Symbolic/What4.hs @@ -67,11 +67,14 @@ import Cryptol.Eval.Type (TValue) import Cryptol.Eval.What4 +import Data.RME.What4 (rmeAdapter) + import Cryptol.Parser.Position (emptyRange) import Cryptol.Symbolic import Cryptol.TypeCheck.AST import Cryptol.Utils.Logger(logPutStrLn,logPutStr,Logger) import Cryptol.Utils.Ident (preludeReferenceName, prelPrim, identText) +import Cryptol.Utils.PP import qualified What4.Config as W4 import qualified What4.Interface as W4 @@ -102,16 +105,16 @@ data W4Exception = W4Ex X.SomeException - | W4PortfolioFailure [ (Either X.SomeException (Maybe String, String)) ] + | W4PortfolioFailure [ (Either X.SomeException (Maybe String, Doc)) ] instance Show W4Exception where show (W4Ex e) = X.displayException e show (W4PortfolioFailure exs) = - unlines ("All solveres in the portfolio failed!":map f exs) + show (vcat (text "All solvers in the portfolio failed!":map f exs)) where - f (Left e) = X.displayException e + f (Left e) = text (X.displayException e) f (Right (Nothing, msg)) = msg - f (Right (Just nm, msg)) = nm ++ ": " ++ msg + f (Right (Just nm, msg)) = text nm <.> text ":" <+> msg instance X.Exception W4Exception @@ -123,7 +126,7 @@ | Just ( _ :: Eval.Unsupported) <- X.fromException e = Nothing | otherwise = Just e -protectStack :: (String -> M.ModuleCmd a) +protectStack :: (Doc -> M.ModuleCmd a) -> M.ModuleCmd a -> M.ModuleCmd a protectStack mkErr cmd modEnv = @@ -131,7 +134,7 @@ X.catchJust isOverflow (cmd modEnv) handler where isOverflow X.StackOverflow = Just () isOverflow _ = Nothing - msg = "Symbolic evaluation failed to terminate." + msg = text "Symbolic evaluation failed to terminate." handler () = mkErr msg modEnv @@ -207,6 +210,7 @@ , ("w4-boolector" , W4ProverConfig boolectorOnlineAdapter) , ("w4-abc" , W4ProverConfig (AnAdapter W4.externalABCAdapter)) + , ("w4-rme" , W4ProverConfig (AnAdapter rmeAdapter)) , ("w4-offline" , W4OfflineConfig ) , ("w4-any" , allSolvers) @@ -315,7 +319,7 @@ void (W4.shutdownSolverProcess proc) return Nothing -proverError :: String -> M.ModuleCmd (Maybe String, ProverResult) +proverError :: Doc -> M.ModuleCmd (Maybe String, ProverResult) proverError msg minp = return (Right ((Nothing, ProverError msg), M.minpModuleEnv minp), []) @@ -351,7 +355,7 @@ W4.IsSymExprBuilder sym => What4 sym -> ProverCommand -> - M.ModuleT IO (Either String + M.ModuleT IO (Either Doc ([FinType],[VarShape (What4 sym)],W4.Pred sym, W4.Pred sym) ) prepareQuery sym ProverCommand { .. } = do @@ -494,7 +498,7 @@ Bool {- ^ warn on uninterpreted functions -} -> ProverCommand -> ((Handle -> IO ()) -> IO ()) -> - M.ModuleCmd (Maybe String) + M.ModuleCmd (Maybe Doc) satProveOffline hashConsing warnUninterp ProverCommand{ .. } outputContinuation = @@ -567,7 +571,7 @@ do W4.assume (W4.solverConn proc) query res <- W4.checkAndGetModel proc "query" case res of - W4.Unknown -> return (Just nm, ProverError "Solver returned UNKNOWN") + W4.Unknown -> return (Just nm, ProverError (text "Solver returned UNKNOWN")) W4.Unsat _ -> return (Just nm, ThmResult (map unFinType ts)) W4.Sat evalFn -> do xs <- mapM (varShapeToConcrete evalFn) args @@ -723,7 +727,7 @@ singleQuery sym (W4ProverConfig (AnAdapter adpt)) _pc primMap logData ts args msafe query = do pres <- W4.solver_adapter_check_sat adpt (w4 sym) logData [query] $ \res -> case res of - W4.Unknown -> return (ProverError "Solver returned UNKNOWN") + W4.Unknown -> return (ProverError (text "Solver returned UNKNOWN")) W4.Unsat _ -> return (ThmResult (map unFinType ts)) W4.Sat (evalFn,_) -> do xs <- mapM (varShapeToConcrete evalFn) args @@ -747,7 +751,7 @@ do W4.assume (W4.solverConn proc) query res <- W4.checkAndGetModel proc "query" case res of - W4.Unknown -> return (Just nm, ProverError "Solver returned UNKNOWN") + W4.Unknown -> return (Just nm, ProverError (text "Solver returned UNKNOWN")) W4.Unsat _ -> return (Just nm, ThmResult (map unFinType ts)) W4.Sat evalFn -> do xs <- mapM (varShapeToConcrete evalFn) args diff --git a/src/Cryptol/Transform/MonoValues.hs b/src/Cryptol/Transform/MonoValues.hs --- a/src/Cryptol/Transform/MonoValues.hs +++ b/src/Cryptol/Transform/MonoValues.hs @@ -226,7 +226,7 @@ rewDef rews (DExpr e) = DExpr <$> rewE rews e rewDef _ DPrim = return DPrim rewDef rews (DForeign t me) = DForeign t <$> traverse (rewE rews) me - + rewDeclGroup :: RewMap -> DeclGroup -> M DeclGroup rewDeclGroup rews dg = case dg of @@ -246,9 +246,10 @@ consider d = case dDefinition d of DPrim -> Left d - DForeign _ me -> case me of - Nothing -> Left d - Just e -> conExpr e + DForeign _ me -> + case me of + Nothing -> Left d + Just e -> conExpr e DExpr e -> conExpr e where conExpr e = diff --git a/src/Cryptol/Transform/Specialize.hs b/src/Cryptol/Transform/Specialize.hs --- a/src/Cryptol/Transform/Specialize.hs +++ b/src/Cryptol/Transform/Specialize.hs @@ -267,12 +267,13 @@ freshName n _ = case nameInfo n of GlobalName s og -> liftSupply (mkDeclared ns (ogModule og) s ident fx loc) - LocalName {} -> liftSupply (mkLocal ns ident loc) + LocalName {} -> liftSupply (mkLocal src ns ident loc) where ns = nameNamespace n fx = nameFixity n ident = nameIdent n loc = nameLoc n + src = nameSrc n -- matchingBoundNames :: (Maybe ModName) -> SpecM [String] -- matchingBoundNames m = do diff --git a/src/Cryptol/TypeCheck/AST.hs b/src/Cryptol/TypeCheck/AST.hs --- a/src/Cryptol/TypeCheck/AST.hs +++ b/src/Cryptol/TypeCheck/AST.hs @@ -27,10 +27,9 @@ , Fixity(..) , PrimMap(..) , module Cryptol.TypeCheck.Type - , DocFor(..) + , FFI(..) ) where -import Data.Maybe(catMaybes) import Cryptol.Utils.Panic(panic) import Cryptol.Utils.Ident (Ident,isInfixIdent,ModName,PrimIdent,prelPrim) import Cryptol.Parser.Position(Located, HasLoc(..), Range) @@ -57,7 +56,7 @@ import qualified Data.IntMap as IntMap import Data.Map (Map) import qualified Data.Map as Map -import Data.Maybe (mapMaybe, maybeToList, isJust) +import Data.Maybe (catMaybes, mapMaybe, isJust) import Data.Set (Set) import Data.Text (Text) @@ -147,12 +146,12 @@ } -- | Find all the foreign declarations in the module and return their names and FFIFunTypes. -findForeignDecls :: ModuleG mname -> [(Name, FFIFunType)] +findForeignDecls :: ModuleG mname -> [(Name, FFI)] findForeignDecls = mapMaybe getForeign . concatMap groupDecls . mDecls where getForeign d = case dDefinition d of - DForeign ffiType _ -> Just (dName d, ffiType) - _ -> Nothing + DForeign ffi _ -> Just (dName d, ffi) + _ -> Nothing -- | Find all the foreign declarations that are in functors, including in the -- top-level module itself if it is a functor. @@ -266,10 +265,13 @@ data DeclDef = DPrim -- | Foreign functions can have an optional cryptol -- implementation - | DForeign FFIFunType (Maybe Expr) + | DForeign FFI (Maybe Expr) | DExpr Expr deriving (Show, Generic, NFData) +data FFI = CallC (FFIFunType FFIType) + | CallAbstract (FFIFunType Type) + deriving (Show,Generic,NFData) -------------------------------------------------------------------------------- @@ -286,9 +288,12 @@ eString :: PrimMap -> String -> Expr eString prims str = EList (map (eChar prims) str) tChar +eNumber :: PrimMap -> Integer -> Type -> Expr +eNumber prims v t = EProofApp (ETApp (ETApp (ePrim prims (prelPrim "number")) (tNum v)) t) + eChar :: PrimMap -> Char -> Expr -eChar prims c = ETApp (ETApp (ePrim prims (prelPrim "number")) (tNum v)) (tWord (tNum w)) - where v = fromEnum c +eChar prims c = eNumber prims v (tWord (tNum w)) + where v = toInteger (fromEnum c) w = 8 :: Int -- | Construct a prop guard expression simplifying trivial cases. @@ -401,23 +406,26 @@ ppLam :: NameMap -> Int -> [TParam] -> [Prop] -> [(Name,Type)] -> Expr -> Doc ppLam nm prec [] [] [] e = nest 2 (ppWithNamesPrec nm prec e) ppLam nm prec ts ps xs e = + withPPCfg $ \cfg -> + let + ns1 = addTNames cfg ts nm + + tsD = if null ts then [] else [braces $ commaSep $ map ppT ts] + psD = if null ps then [] else [parens $ commaSep $ map ppP ps] + xsD = if null xs then [] else [sep $ map ppArg xs] + + ppT = ppWithNames ns1 + ppP = ppWithNames ns1 + ppArg (x,t) = parens (pp x <+> text ":" <+> ppWithNames ns1 t) + in optParens (prec > 0) $ nest 2 $ sep [ text "\\" <.> hsep (tsD ++ psD ++ xsD ++ [text "->"]) , ppWithNames ns1 e ] - where - ns1 = addTNames ts nm - tsD = if null ts then [] else [braces $ commaSep $ map ppT ts] - psD = if null ps then [] else [parens $ commaSep $ map ppP ps] - xsD = if null xs then [] else [sep $ map ppArg xs] - ppT = ppWithNames ns1 - ppP = ppWithNames ns1 - ppArg (x,t) = parens (pp x <+> text ":" <+> ppWithNames ns1 t) - splitWhile :: (a -> Maybe (b,a)) -> a -> ([b],a) splitWhile f e = case f e of Nothing -> ([], e) @@ -511,10 +519,14 @@ instance PP (WithNames DeclDef) where ppPrec _ (WithNames DPrim _) = text "" - ppPrec _ (WithNames (DForeign _ me) nm) = + ppPrec _ (WithNames (DForeign mo me) nm) = + let lab = "foreign" <+> case mo of + CallC {} -> "c" + CallAbstract {} -> "abstract" + in case me of - Just e -> text "(foreign)" <+> ppWithNames nm e - Nothing -> text "" + Just e -> parens lab <+> ppWithNames nm e + Nothing -> hsep ["<",lab,">"] ppPrec _ (WithNames (DExpr e) nm) = ppWithNames nm e instance PP Decl where @@ -525,6 +537,15 @@ instance PP n => PP (WithNames (ModuleG n)) where ppPrec _ (WithNames Module { .. } nm) = + withPPCfg $ \cfg -> + let + mps = map mtpParam (Map.elems mParamTypes) + pp' :: PP (WithNames a) => a -> Doc + pp' = ppWithNames (addTNames cfg mps nm) + ppSig (x,y) = "interface module" <+> pp x <+> "where" + $$ indent 2 (pp y) + vcat' xs = if null xs then Nothing else Just (vcat xs) + in vcat $ catMaybes [ Just (text "module" <+> pp mName) @@ -538,78 +559,11 @@ , vcat' (map ppSig (Map.toList mSignatures)) ] - where mps = map mtpParam (Map.elems mParamTypes) - pp' :: PP (WithNames a) => a -> Doc - pp' = ppWithNames (addTNames mps nm) - ppSig (x,y) = "interface module" <+> pp x <+> "where" - $$ indent 2 (pp y) - vcat' xs = if null xs then Nothing else Just (vcat xs) + instance PP (WithNames TCTopEntity) where ppPrec _ (WithNames ent nm) = case ent of TCTopModule m -> ppWithNames nm m TCTopSignature n ps -> hang ("interface module" <+> pp n <+> "where") 2 (pp ps) - -data DocItem = DocItem - { docModContext :: ImpName Name -- ^ The module scope to run repl commands in - , docFor :: DocFor -- ^ The name the documentation is attached to - , docText :: [Text] -- ^ The text of the attached docstring, if any - } - -data DocFor - = DocForMod (ImpName Name) - | DocForDef Name -- definitions that aren't modules - -instance PP DocFor where - ppPrec p x = - case x of - DocForMod m -> ppPrec p m - DocForDef n -> ppPrec p n - - -gatherModuleDocstrings :: - Map Name (ImpName Name) -> - Module -> - [DocItem] -gatherModuleDocstrings nameToModule m = - [DocItem - { docModContext = ImpTop (mName m) - , docFor = DocForMod (ImpTop (mName m)) - , docText = mDoc m - } - ] ++ - -- mParams m - -- mParamTypes m - -- mParamFuns m - [DocItem - { docModContext = lookupModuleName n - , docFor = DocForDef n - , docText = maybeToList (tsDoc t) - } | (n, t) <- Map.assocs (mTySyns m)] ++ - [DocItem - { docModContext = lookupModuleName n - , docFor = DocForDef n - , docText = maybeToList (ntDoc t) - } | (n, t) <- Map.assocs (mNominalTypes m)] ++ - [DocItem - { docModContext = lookupModuleName (dName d) - , docFor = DocForDef (dName d) - , docText = maybeToList (dDoc d) - } | g <- mDecls m, d <- groupDecls g] ++ - [DocItem - { docModContext = ImpNested n - , docFor = DocForMod (ImpNested n) - , docText = ifsDoc (smIface s) - } | (n, s) <- Map.assocs (mSubmodules m)] ++ - [DocItem - { docModContext = ImpTop (mName m) - , docFor = DocForMod (ImpNested n) - , docText = maybeToList (mpnDoc s) - } | (n, s) <- Map.assocs (mSignatures m)] - where - lookupModuleName n = - case Map.lookup n nameToModule of - Just x -> x - Nothing -> panic "gatherModuleDocstrings" ["No owning module for name:", show (pp n)] diff --git a/src/Cryptol/TypeCheck/Docstrings.hs b/src/Cryptol/TypeCheck/Docstrings.hs new file mode 100644 --- /dev/null +++ b/src/Cryptol/TypeCheck/Docstrings.hs @@ -0,0 +1,153 @@ +-- | +-- Module : Cryptol.TypeCheck.Docstrings +-- Copyright : (c) 2013-2025 Galois, Inc. +-- License : BSD3 +-- Maintainer : cryptol@galois.com +-- Stability : provisional +-- Portability : portable + +{-# LANGUAGE Safe #-} + +{-# LANGUAGE OverloadedStrings #-} +module Cryptol.TypeCheck.Docstrings where + +import Cryptol.ModuleSystem.Interface +import Cryptol.ModuleSystem.Name +import Cryptol.Parser.AST (ImpName (..)) +import Cryptol.TypeCheck.AST (Decl(..), Module, ModuleG(..), Pragma(..), + Submodule(..), groupDecls) +import Cryptol.TypeCheck.PP +import Cryptol.TypeCheck.Type +import Cryptol.Utils.Ident (identText) +import Cryptol.Utils.Panic (panic) + +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (fromMaybe, maybeToList) +import Data.Text (Text) +import qualified Data.Text as T + +data DocItem = DocItem + { docModContext :: ImpName Name -- ^ The module scope to run repl commands in + , docFor :: DocFor -- ^ The name the documentation is attached to + , docText :: [Text] -- ^ The text of the attached docstring, if any + } + +data DocFor + = DocForMod (ImpName Name) + | DocForDef Name -- definitions that aren't modules + +instance PP DocFor where + ppPrec p x = + case x of + DocForMod m -> ppPrec p m + DocForDef n -> ppPrec p n + + +gatherModuleDocstrings :: + Map Name (ImpName Name) -> + Module -> + [DocItem] +gatherModuleDocstrings nameToModule m = + [DocItem + { docModContext = ImpTop (mName m) + , docFor = DocForMod (ImpTop (mName m)) + , docText = mDoc m + } + ] ++ + -- mParams m + -- mParamTypes m + -- mParamFuns m + [DocItem + { docModContext = lookupModuleName n + , docFor = DocForDef n + , docText = maybeToList (tsDoc t) + } | (n, t) <- Map.assocs (mTySyns m)] ++ + [DocItem + { docModContext = lookupModuleName n + , docFor = DocForDef n + , docText = maybeToList (ntDoc t) + } | (n, t) <- Map.assocs (mNominalTypes m)] ++ + [DocItem + { docModContext = lookupModuleName (dName d) + , docFor = DocForDef (dName d) + , docText = maybeToList (dDoc d <> exhaustBoolProp d) + } | g <- mDecls m, d <- groupDecls g] ++ + [DocItem + { docModContext = ImpNested n + , docFor = DocForMod (ImpNested n) + , docText = ifsDoc (smIface s) + } | (n, s) <- Map.assocs (mSubmodules m)] ++ + [DocItem + { docModContext = ImpTop (mName m) + , docFor = DocForMod (ImpNested n) + , docText = maybeToList (mpnDoc s) + } | (n, s) <- Map.assocs (mSignatures m)] + where + lookupModuleName n = + case Map.lookup n nameToModule of + Just x -> x + Nothing -> panic "gatherModuleDocstrings" ["No owning module for name:", show (pp n)] + + exhaustBoolProp d = + if (null . extractCodeBlocks . fromMaybe "" . dDoc) d && + (tIsBit . sType . dSignature) d && + PragmaProperty `elem` dPragmas d + then Just $ "```\n" <> ":exhaust " <> (identText . nameIdent) (dName d) <> " // implicit" <> "\n```" + else Nothing + +-- | Extract the code blocks from the body of a docstring. +-- +-- A single code block starts with at least 3 backticks followed by an +-- optional language specifier of \"cryptol\". This allows other kinds +-- of code blocks to be included (and ignored) in docstrings. Longer +-- backtick sequences can be used when a code block needs to be able to +-- contain backtick sequences. +-- +-- @ +-- /** +-- * A docstring example +-- * +-- * ```cryptol +-- * :check example +-- * ``` +-- */ +-- @ +extractCodeBlocks :: Text -> [[Text]] +extractCodeBlocks raw = go [] (T.lines raw) + where + go finished [] = reverse finished + go finished (x:xs) + | (spaces, x1) <- T.span (' ' ==) x + , (ticks, x2) <- T.span ('`' ==) x1 + , 3 <= T.length ticks + , not (T.elem '`' x2) + , let info = T.strip x2 + = if info `elem` ["", "repl"] -- supported languages "unlabeled" and repl + then keep finished (T.length spaces) (T.length ticks) [] xs + else skip finished ticks xs + | otherwise = go finished xs + + -- process a code block that we're keeping + keep finished _ _ acc [] = go (reverse acc : finished) [] -- unterminated code fences are defined to be terminated by github + keep finished indentLen ticksLen acc (x:xs) + | x1 <- T.dropWhile (' ' ==) x + , (ticks, x2) <- T.span ('`' ==) x1 + , ticksLen <= T.length ticks + , T.all (' ' ==) x2 + = go (reverse acc : finished) xs + + | otherwise = + let x' = + case T.span (' ' ==) x of + (spaces, x1) + | T.length spaces <= indentLen -> x1 + | otherwise -> T.drop indentLen x + in keep finished indentLen ticksLen (x' : acc) xs + + -- process a code block that we're skipping + skip finished _ [] = go finished [] + skip finished close (x:xs) + | close == x = go finished xs + | otherwise = skip finished close xs + diff --git a/src/Cryptol/TypeCheck/Error.hs b/src/Cryptol/TypeCheck/Error.hs --- a/src/Cryptol/TypeCheck/Error.hs +++ b/src/Cryptol/TypeCheck/Error.hs @@ -851,8 +851,8 @@ -- | This picks the names to use when showing errors and warnings. -computeFreeVarNames :: [(Range,Warning)] -> [(Range,Error)] -> NameMap -computeFreeVarNames warns errs = +computeFreeVarNames :: PPCfg -> [(Range,Warning)] -> [(Range,Error)] -> NameMap +computeFreeVarNames cfg warns errs = mkMap numRoots numVaras `IntMap.union` mkMap otherRoots otherVars `IntMap.union` mpNames @@ -864,14 +864,14 @@ so for now we just go with the simple approximation. -} where - mkName x v = (tvUnique x, v) + mkName x v = (tvUnique x, text v) mkMap roots vs = IntMap.fromList (zipWith mkName vs (variants roots)) (uvars,non_uvars) = partition isFreeTV $ Set.toList $ fvs (map snd warns, map snd errs) - mpNames = computeModParamNames [ tp | TVBound tp <- non_uvars ] mempty + mpNames = computeModParamNames cfg [ tp | TVBound tp <- non_uvars ] mempty (numVaras,otherVars) = partition ((== KNum) . kindOf) uvars diff --git a/src/Cryptol/TypeCheck/FFI.hs b/src/Cryptol/TypeCheck/FFI.hs --- a/src/Cryptol/TypeCheck/FFI.hs +++ b/src/Cryptol/TypeCheck/FFI.hs @@ -8,28 +8,37 @@ ( toFFIFunType ) where -import Data.Bifunctor -import Data.Containers.ListUtils -import Data.Either +import Data.Bifunctor +import Data.Containers.ListUtils +import Data.Either -import Cryptol.TypeCheck.FFI.Error -import Cryptol.TypeCheck.FFI.FFIType -import Cryptol.TypeCheck.SimpType -import Cryptol.TypeCheck.Type -import Cryptol.Utils.RecordMap -import Cryptol.Utils.Types +import Cryptol.Utils.Panic(panic) +import Cryptol.Parser.AST(ForeignMode(..)) +import Cryptol.TypeCheck.FFI.Error +import Cryptol.TypeCheck.FFI.FFIType +import Cryptol.TypeCheck.SimpType +import Cryptol.TypeCheck.Type +import Cryptol.TypeCheck.AST(FFI(..)) +import Cryptol.TypeCheck.Subst +import Cryptol.Utils.RecordMap +import Cryptol.Utils.Types + -- | Convert a 'Schema' to a 'FFIFunType', along with any 'Prop's that must be -- satisfied for the 'FFIFunType' to be valid. -toFFIFunType :: Schema -> Either FFITypeError ([Prop], FFIFunType) -toFFIFunType (Forall params _ t) = - -- Remove all type synonyms and simplify the type before processing it - case go $ tRebuild' False t of - Just (Right (props, fft)) -> Right - -- Remove duplicate constraints - (nubOrd $ map (fin . TVar . TVBound) params ++ props, fft) - Just (Left errs) -> Left $ FFITypeError t $ FFIBadComponentTypes errs - Nothing -> Left $ FFITypeError t FFINotFunction +toFFIFunType :: ForeignMode -> Schema -> Either FFITypeError ([Prop], FFI) +toFFIFunType how (Forall params _ t) = + + case how of + ForeignAbstract -> checkForeignAbstract params t + ForeignC -> + -- Remove all type synonyms and simplify the type before processing it + case go $ tRebuild' False t of + Just (Right (props, fft)) -> Right + -- Remove duplicate constraints + (nubOrd $ map (fin . TVar . TVBound) params ++ props, CallC fft) + Just (Left errs) -> Left $ FFITypeError t $ FFIBadComponentTypes errs + Nothing -> Left $ FFITypeError t FFINotFunction where go (TCon (TC TCFun) [argType, retType]) = Just case toFFIType argType of Right (ps, ffiArgType) -> @@ -110,3 +119,90 @@ fin :: Type -> Prop fin t = TCon (PC PFin) [t] + + +-- XXX: eliminate stuff we know will not work at runtime +checkForeignAbstract :: [TParam] -> Type -> Either FFITypeError ([Prop], FFI) +checkForeignAbstract params t = + do fromArgs <- validForeignAbstractTypes args + fromRes <- validForeignAbstractType res + pure ( fromRes ++ fromArgs + , CallAbstract + FFIFunType { ffiTParams = params + , ffiArgTypes = args + , ffiRetType = res } + ) + where + (args,res) = go t + go ty = + case tIsFun ty of + Just (a,r) -> + let (bs,r1) = go r + in (a:bs,r1) + Nothing -> ([],ty) + + + +validForeignAbstractTypes :: + Traversable t => t Type -> Either FFITypeError [Prop] +validForeignAbstractTypes ts = concat <$> traverse validForeignAbstractType ts + +validForeignAbstractType :: Type -> Either FFITypeError [Prop] +validForeignAbstractType t = + let nope = Left . FFITypeError t + in + case t of + TCon c ts -> + case c of + PC {} -> bad "PC" + TF {} -> bad "TF" + TError {} -> bad "TError" + TC tc -> + case tc of + TCNum {} -> bad "TCNum" + TCInf {} -> bad "TCInf" + TCBit -> pure [] + TCInteger -> pure [] + TCFloat -> + case ts of + [e',p'] -> + case (tIsNum e', tIsNum p') of + (Just e, Just p) + | (e, p) == float32ExpPrec -> pure [] + | (e, p) == float64ExpPrec -> pure [] + _ -> nope FFIBadFloatSize + _ -> bad "TCFloat" + TCIntMod -> pure [] + TCRational -> pure [] + TCArray -> nope FFIBadType + TCSeq -> + case ts of + [len,el] -> + do ps <- validForeignAbstractType el + let prop = pFin len + case tIsError prop of + Just err -> pure (err : ps) + Nothing -> pure (prop : ps) + _ -> bad "TCSeq" + TCFun -> nope FFIBadType + TCTuple {} -> validForeignAbstractTypes ts + + TVar {} -> nope FFIBadType + TUser _ _ t1 -> validForeignAbstractType t1 + TRec rs -> validForeignAbstractTypes rs + TNominal nm ts -> + let su = listParamSubst (ntParams nm `zip` ts) in + validForeignAbstractNominalType t su (ntDef nm) + where + bad msg = panic "validOfreignAbstactType" [msg] + +validForeignAbstractNominalType :: + Type -> Subst -> NominalTypeDef -> Either FFITypeError[Prop] +validForeignAbstractNominalType ty su def = + case def of + Struct sc -> concat <$> traverse validT (recordElements (ntFields sc)) + Enum cs -> concat <$> traverse validCon cs + Abstract -> Left (FFITypeError ty FFIBadType) + where + validT t = validForeignAbstractType (apSubst su t) + validCon c = concat <$> traverse validT (ecFields c) diff --git a/src/Cryptol/TypeCheck/FFI/FFIType.hs b/src/Cryptol/TypeCheck/FFI/FFIType.hs --- a/src/Cryptol/TypeCheck/FFI/FFIType.hs +++ b/src/Cryptol/TypeCheck/FFI/FFIType.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE Safe #-} -- | This module defines a nicer intermediate representation of Cryptol types @@ -16,12 +17,12 @@ import Cryptol.Utils.RecordMap -- | Type of a foreign function. -data FFIFunType = FFIFunType +data FFIFunType t = FFIFunType { -- | Note: any type variables within this function type must be bound here. ffiTParams :: [TParam] - , ffiArgTypes :: [FFIType] - , ffiRetType :: FFIType } - deriving (Show, Generic, NFData) + , ffiArgTypes :: [t] + , ffiRetType :: t } + deriving (Show, Generic, NFData, Functor) -- | Type of a value that can be passed to or returned from a foreign function. data FFIType diff --git a/src/Cryptol/TypeCheck/Infer.hs b/src/Cryptol/TypeCheck/Infer.hs --- a/src/Cryptol/TypeCheck/Infer.hs +++ b/src/Cryptol/TypeCheck/Infer.hs @@ -1020,7 +1020,7 @@ P.DImpl i -> case i of P.DExpr {} -> AllowWildCards P.DPropGuards {} -> NoWildCards - s1 <- checkSchema wildOk s + s1 <- checkSchema wildOk (thing s) return ((name, ExtVar (fst s1)), Left (checkSigB b s1)) Nothing @@ -1138,7 +1138,7 @@ P.DPrim -> panic "checkMonoB" ["Primitive with no signature?"] - P.DForeign _ -> panic "checkMonoB" ["Foreign with no signature?"] + P.DForeign _ _ -> panic "checkMonoB" ["Foreign with no signature?"] P.DImpl i -> case i of @@ -1183,7 +1183,7 @@ , dDoc = thing <$> P.bDoc b } - P.DForeign mi -> do + P.DForeign cc mi -> do (asmps, t, me) <- case mi of Just i -> fmap Just <$> checkImpl i @@ -1197,7 +1197,7 @@ recordErrorLoc loc $ UnsupportedFFIKind src a $ tpKind a withTParams as do ffiFunType <- - case toFFIFunType (Forall as asmps t) of + case toFFIFunType cc (Forall as asmps t) of Right (props, ffiFunType) -> ffiFunType <$ do ffiGoals <- traverse (newGoal (CtFFI name)) props proveImplication True (Just name) as asmps $ @@ -1205,7 +1205,7 @@ Left err -> do recordErrorLoc loc $ UnsupportedFFIType src err -- Just a placeholder type - pure FFIFunType + pure $ CallC FFIFunType { ffiTParams = as, ffiArgTypes = [] , ffiRetType = FFITuple [] } pure Decl { dName = thing (P.bName b) diff --git a/src/Cryptol/TypeCheck/InferTypes.hs b/src/Cryptol/TypeCheck/InferTypes.hs --- a/src/Cryptol/TypeCheck/InferTypes.hs +++ b/src/Cryptol/TypeCheck/InferTypes.hs @@ -397,6 +397,35 @@ instance PP (WithNames DelayedCt) where ppPrec _ (WithNames d names) = + withPPCfg $ \cfg -> + let + bullets xs = [ "•" <+> x | x <- xs ] + + sig = case name of + Just n -> "in the definition of" <+> quotes (pp n) <.> + comma <+> "at" <+> pp (nameLoc n) <.> comma + Nothing -> "when checking the module's parameters," + + name = dctSource d + vars = case otherTPs of + [] -> [] + xs -> ["for any type" <+> commaSep (map (ppWithNames ns1) xs)] + asmps = case dctAsmps d of + [] -> [] + xs -> [hang "assuming" + 2 (vcat (bullets (map (ppWithNames ns1) xs)))] + + tvars = fvs (dctAsmps d, dctGoals d) + used = filter ((`Set.member` tvars) . TVBound) (dctForall d) + isModP tp = + case tpFlav tp of + TPModParam {} -> True + _ -> False + (mpTPs,otherTPs) = partition isModP used + explain = addTVarsDescsAfterFVS ns1 (Set.fromList (map TVBound mpTPs)) + mps = computeModParamNames cfg mpTPs names + ns1 = addTNames cfg otherTPs mps + in sig $$ hang "we need to show that" @@ -406,36 +435,9 @@ $ bullets $ map (ppWithNames ns1) $ dctGoals d )]))) - where - - bullets xs = [ "•" <+> x | x <- xs ] - - sig = case name of - Just n -> "in the definition of" <+> quotes (pp n) <.> - comma <+> "at" <+> pp (nameLoc n) <.> comma - Nothing -> "when checking the module's parameters," - - name = dctSource d - vars = case otherTPs of - [] -> [] - xs -> ["for any type" <+> commaSep (map (ppWithNames ns1) xs)] - asmps = case dctAsmps d of - [] -> [] - xs -> [hang "assuming" - 2 (vcat (bullets (map (ppWithNames ns1) xs)))] - - tvars = fvs (dctAsmps d, dctGoals d) - used = filter ((`Set.member` tvars) . TVBound) (dctForall d) - isModP tp = - case tpFlav tp of - TPModParam {} -> True - _ -> False - (mpTPs,otherTPs) = partition isModP used - explain = addTVarsDescsAfterFVS ns1 (Set.fromList (map TVBound mpTPs)) - mps = computeModParamNames mpTPs names - ns1 = addTNames otherTPs mps + @@ -454,12 +456,12 @@ -- | Pick names for the type parameters that correspond to module parameters, -- avoiding strings that already appear in the given name map. -- Returns an extended name map. -computeModParamNames :: [TParam] -> NameMap -> NameMap -computeModParamNames tps names = IntMap.fromList newNames `IntMap.union` names +computeModParamNames :: PPCfg -> [TParam] -> NameMap -> NameMap +computeModParamNames cfg tps names = IntMap.fromList newNames `IntMap.union` names where newNames = snd (mapAccumL pickName used0 (mapMaybe isModP tps)) - used0 = Set.fromList (IntMap.elems names) + used0 = Set.fromList (map (show . fixPPCfg cfg) (IntMap.elems names)) pickName used (u,i) = let ns = filter (not . (`Set.member` used)) @@ -467,7 +469,7 @@ name = case ns of x : _ -> x [] -> panic "computeModParamNames" ["Out of names!"] - in (Set.insert name used, (u,name)) + in (Set.insert name used, (u,text name)) isModP tp = case tpFlav tp of diff --git a/src/Cryptol/TypeCheck/Kind.hs b/src/Cryptol/TypeCheck/Kind.hs --- a/src/Cryptol/TypeCheck/Kind.hs +++ b/src/Cryptol/TypeCheck/Kind.hs @@ -466,7 +466,7 @@ checkKind t1 k KType P.TLocated t r1 -> kInRange r1 $ doCheckType t k - P.TUser x ts -> checkTUser x ts k + P.TUser x ts -> checkTUser (thing x) ts k P.TParens t mb -> do newK <- case (k, cvtK <$> mb) of @@ -478,7 +478,7 @@ doCheckType t newK - P.TInfix t x _ u-> doCheckType (P.TUser (thing x) [t, u]) k + P.TInfix t x _ u-> doCheckType (P.TUser x [t, u]) k P.TTyApp _fs -> do kRecordError BareTypeApp kNewType TypeWildCard KNum diff --git a/src/Cryptol/TypeCheck/Monad.hs b/src/Cryptol/TypeCheck/Monad.hs --- a/src/Cryptol/TypeCheck/Monad.hs +++ b/src/Cryptol/TypeCheck/Monad.hs @@ -55,7 +55,7 @@ ) import qualified Cryptol.TypeCheck.SimpleSolver as Simple import qualified Cryptol.TypeCheck.Solver.SMT as SMT -import Cryptol.TypeCheck.PP(NameMap) +import Cryptol.TypeCheck.PP(NameMap, defaultPPCfg) import Cryptol.Utils.PP(pp, (<+>), text,commaSep,brackets,debugShowUniques) import Cryptol.Utils.Ident(Ident,Namespace(..),ModName) import Cryptol.Utils.Panic(panic) @@ -184,13 +184,20 @@ errs -> inferFailed warns [(r,apSubst theSu e) | (r,e) <- errs] where + ppcfg = defaultPPCfg + -- XXX: perhaps this should be a part of the input? + -- We use it when picking how to display names; we need to pick names + -- for things that don't have their own, and we need to pick names that + -- don't clash with existing ones. This is affected by how things are + -- pretty printed. + inferOk ws a b c = let ws1 = cleanupWarnings ws - in pure (InferOK (computeFreeVarNames ws1 []) ws1 a b c) + in pure (InferOK (computeFreeVarNames ppcfg ws1 []) ws1 a b c) inferFailed ws es = let es1 = cleanupErrors es ws1 = cleanupWarnings ws - in pure (InferFailed (computeFreeVarNames ws1 es1) ws1 es1) + in pure (InferFailed (computeFreeVarNames ppcfg ws1 es1) ws1 es1) rw = RW { iErrors = [] @@ -578,7 +585,7 @@ newLocalName :: Namespace -> Ident -> InferM Name newLocalName ns x = do r <- curRange - liftSupply (mkLocal ns x r) + liftSupply (mkLocal SystemName ns x r) newName :: (NameSeeds -> (a , NameSeeds)) -> InferM a newName upd = IM $ sets $ \s -> let (x,seeds) = upd (iNameSeeds s) diff --git a/src/Cryptol/TypeCheck/PP.hs b/src/Cryptol/TypeCheck/PP.hs --- a/src/Cryptol/TypeCheck/PP.hs +++ b/src/Cryptol/TypeCheck/PP.hs @@ -23,7 +23,7 @@ import Cryptol.Utils.PP -type NameMap = IntMap String +type NameMap = IntMap Doc emptyNameMap :: NameMap emptyNameMap = IntMap.empty diff --git a/src/Cryptol/TypeCheck/Parseable.hs b/src/Cryptol/TypeCheck/Parseable.hs --- a/src/Cryptol/TypeCheck/Parseable.hs +++ b/src/Cryptol/TypeCheck/Parseable.hs @@ -103,10 +103,16 @@ showParseable d = parens (text "Decl" <+> showParseable (dName d) $$ showParseable (dDefinition d)) +instance ShowParseable FFI where + showParseable mo = + case mo of + CallAbstract t -> parens (text "CallAbstract" <+> parens (text (show t))) + CallC t -> parens (text "CallC" <+> parens (text (show t))) + instance ShowParseable DeclDef where showParseable DPrim = text (show DPrim) showParseable (DForeign t me) = - parens (text "DForeign" $$ parens (text (show t)) $$ showParseable me) + parens (text "DForeign" $$ showParseable t $$ showParseable me) showParseable (DExpr e) = parens (text "DExpr" $$ showParseable e) instance ShowParseable DeclGroup where diff --git a/src/Cryptol/TypeCheck/Solver/Numeric.hs b/src/Cryptol/TypeCheck/Solver/Numeric.hs --- a/src/Cryptol/TypeCheck/Solver/Numeric.hs +++ b/src/Cryptol/TypeCheck/Solver/Numeric.hs @@ -46,8 +46,8 @@ <|> tryEqAddInf ctxt t1 t2 <|> tryAddConst (=#=) t1 t2 <|> tryCancelVar ctxt (=#=) t1 t2 - <|> tryLinearSolution t1 t2 - <|> tryLinearSolution t2 t1 + <|> tryLinearSolution ctxt t1 t2 + <|> tryLinearSolution ctxt t2 t1 <|> tryEqExp t1 t2 -- | Try to solve @t1 /= t2@ @@ -458,14 +458,15 @@ -- | Check for situations where a unification variable is involved in -- a sum of terms not containing additional unification variables, -- and replace it with a solution and an inequality. --- @s1 = ?a + s2 ~~> (?a = s1 - s2, s1 >= s2)@ -tryLinearSolution :: Type -> Type -> Match Solved -tryLinearSolution s1 t = +-- @s1 = ?a + s2 ~~> (?a = s1 - s2, s1 >= s2, fin s2)@ +tryLinearSolution :: Ctxt -> Type -> Type -> Match Solved +tryLinearSolution ctxt s1 t = do (a,xs) <- matchLinearUnifier t - guard (noFreeVariables s1) + guard (noFreeVariables s1) -- NB: matchLinearUnifier only matches if xs is nonempty let s2 = foldr1 Simp.tAdd xs + guard (iIsFin (typeInterval (intervals ctxt) s2)) return (SolvedIf [ TVar a =#= (Simp.tSub s1 s2), s1 >== s2 ]) diff --git a/src/Cryptol/TypeCheck/Solver/Numeric/Interval.hs b/src/Cryptol/TypeCheck/Solver/Numeric/Interval.hs --- a/src/Cryptol/TypeCheck/Solver/Numeric/Interval.hs +++ b/src/Cryptol/TypeCheck/Solver/Numeric/Interval.hs @@ -19,9 +19,12 @@ import Cryptol.TypeCheck.PP(NameMap,ppWithNames) import Cryptol.Utils.PP hiding (int) +import Data.Set (Set) +import qualified Data.Set as Set import Data.Map ( Map ) import qualified Data.Map as Map import Data.Maybe (catMaybes) +import Control.Monad(guard) -- | Only meaningful for numeric types @@ -77,6 +80,7 @@ Nothing -> NewIntervals (Map.insert x int varInts) +-- XXX: Do we really need the 3 iteraton limit here? computePropIntervals :: Map TVar Interval -> [Prop] -> IntervalUpdate computePropIntervals ints ps0 = go (3 :: Int) False ints ps0 where @@ -105,28 +109,34 @@ -- | What we learn about variables from a single prop. propInterval :: Map TVar Interval -> Prop -> [(TVar,Interval)] -propInterval varInts prop = catMaybes +propInterval varInts prop = concat $ catMaybes [ do ty <- pIsFin prop - x <- tIsVar ty - return (x,iAnyFin) + findFin ty , do (l,r) <- pIsEqual prop x <- tIsVar l - return (x,typeInterval varInts r) + return [(x,typeInterval varInts r)] , do (l,r) <- pIsEqual prop x <- tIsVar r - return (x,typeInterval varInts l) + return [(x,typeInterval varInts l)] , do (l,r) <- pIsGeq prop x <- tIsVar l let int = typeInterval varInts r - return (x,int { iUpper = Just Inf }) + return [(x,int { iUpper = Just Inf })] + -- l >= r , do (l,r) <- pIsGeq prop + let int = typeInterval varInts l x <- tIsVar r + return [(x,int { iLower = Nat 0 })] + + -- l >= r, and fin l + , do (l,r) <- pIsGeq prop let int = typeInterval varInts l - return (x,int { iLower = Nat 0 }) + guard (iIsFin int) + findFin r -- k >= width x , do (l,r) <- pIsGeq prop @@ -138,18 +148,52 @@ | otherwise -> Nothing upper -> upper - return (x, Interval { iLower = Nat 0, iUpper = ub }) + return [(x, Interval { iLower = Nat 0, iUpper = ub })] , do (e,_) <- pIsValidFloat prop - x <- tIsVar e - pure (x, iAnyFin) + findFin e , do (_,p) <- pIsValidFloat prop - x <- tIsVar p - pure (x, iAnyFin) + findFin p ] + where + findFin ty = pure [ (x,iAnyFin) | x <- Set.toList (knownFin varInts ty Set.empty) ] + +-- | If we know that a type is finite compute what variables must be finite +knownFin :: Map TVar Interval -> Type -> Set TVar -> Set TVar +knownFin ctxt ty k = + case tNoUser ty of + TVar x -> Set.insert x k + TCon (TF tf) xs -> + let allFin = foldr (knownFin ctxt) k xs in + case (tf,xs) of + (TCAdd,_) -> allFin + (TCSub,_) -> allFin + (TCMul,[x,y]) + | iIsFin yi || iLower xi > Nat 0 -> knownFin ctxt y xvs + | otherwise -> xvs + where + xi = typeInterval ctxt x + yi = typeInterval ctxt y + xvs = if iIsFin xi || iLower yi > Nat 0 then knownFin ctxt x k else k + (TCDiv,[x,_]) -> knownFin ctxt x k + (TCMod,[x,_]) -> knownFin ctxt x k + (TCExp,[x,y]) + | iIsFin yi || iLower xi > Nat 1 -> knownFin ctxt y xvs + where + xi = typeInterval ctxt x + yi = typeInterval ctxt y + xvs = if iIsFin xi || iLower yi > Nat 0 then knownFin ctxt x k else k + (TCWidth,_) -> allFin + (TCMin,_) -> k + (TCMax,_) -> allFin + (TCCeilDiv,_) -> allFin + (TCCeilMod,[_,y]) -> knownFin ctxt y k + (TCLenFromThenTo,_) -> allFin + _ -> k + _ -> k -------------------------------------------------------------------------------- diff --git a/src/Cryptol/TypeCheck/Solver/SMT.hs b/src/Cryptol/TypeCheck/Solver/SMT.hs --- a/src/Cryptol/TypeCheck/Solver/SMT.hs +++ b/src/Cryptol/TypeCheck/Solver/SMT.hs @@ -18,6 +18,7 @@ , withSolver , startSolver , stopSolver + , killSolver , isNumeric , resetSolver @@ -76,6 +77,7 @@ setupSolver :: Solver -> SolverConfig -> IO () setupSolver s cfg = do _ <- SMT.setOptionMaybe (solver s) ":global-decls" "false" + SMT.setLogic (solver s) "ALL" loadTcPrelude s (solverPreludePath cfg) -- | Start a fresh solver instance @@ -125,6 +127,10 @@ , SMT.logUntab = return () } +-- | Kill the process running the solver +killSolver :: Solver -> IO () +killSolver s = void $ SMT.forceStop (solver s) + -- | Shut down a solver instance stopSolver :: Solver -> IO () stopSolver s = void $ SMT.stop (solver s) @@ -142,7 +148,7 @@ loadTcPrelude :: Solver -> [FilePath] {- ^ Search in this paths -} -> IO () loadTcPrelude s [] = loadString s cryptolTcContents loadTcPrelude s (p : ps) = - do let file = p "CryptolTC.z3" + do let file = p "CryptolTC.smt2" yes <- doesFileExist file if yes then loadFile s file else loadTcPrelude s ps diff --git a/src/Cryptol/TypeCheck/Type.hs b/src/Cryptol/TypeCheck/Type.hs --- a/src/Cryptol/TypeCheck/Type.hs +++ b/src/Cryptol/TypeCheck/Type.hs @@ -1027,36 +1027,49 @@ instance PP (WithNames TParam) where ppPrec _ (WithNames p mp) = ppWithNames mp (tpVar p) -addTNames :: [TParam] -> NameMap -> NameMap -addTNames as ns = foldr (uncurry IntMap.insert) ns - $ named ++ zip unnamed_nums numNames - ++ zip unnamed_vals valNames +addTNames :: PPCfg -> [TParam] -> NameMap -> NameMap +addTNames cfg as ns = + foldr (uncurry IntMap.insert) ns + $ named ++ zip unnamed_nums numNames + ++ zip unnamed_vals valNames - where avail xs = filter (`notElem` used) (nameList xs) + where avail xs = map text (filter (`notElem` used) (nameList xs)) numNames = avail ["n","m","i","j","k"] valNames = avail ["a","b","c","d","e"] nm x = (tpUnique x, tpName x, tpKind x) - named = [ (u,show (pp n)) | (u,Just n,_) <- map nm as ] - unnamed_nums = [ u | (u,Nothing,KNum) <- map nm as ] - unnamed_vals = [ u | (u,Nothing,KType) <- map nm as ] + named = [ (u,pp n) | (u,Just n,_) <- map nm as ] + unnamed_nums = [ u | (u,Nothing,KNum) <- map nm as ] + unnamed_vals = [ u | (u,Nothing,KType) <- map nm as ] - used = map snd named ++ IntMap.elems ns + used = map (show . fixPPCfg cfg) (map snd named ++ IntMap.elems ns) ppNominalShort :: NominalType -> Doc ppNominalShort nt = - kw <+> pp (ntName nt) <+> hsep (map (ppWithNamesPrec nm 9) ps) - where - ps = ntParams nt - nm = addTNames ps emptyNameMap - kw = case ntDef nt of - Struct {} -> "newtype" - Enum {} -> "enum" - Abstract {} -> "primitive type" + withPPCfg $ \cfg -> + let + ps = ntParams nt + nm = addTNames cfg ps emptyNameMap + kw = case ntDef nt of + Struct {} -> "newtype" + Enum {} -> "enum" + Abstract {} -> "primitive type" + in + kw <+> pp (ntName nt) <+> hsep (map (ppWithNamesPrec nm 9) ps) + ppNominalFull :: NominalType -> Doc ppNominalFull nt = + withPPCfg $ \cfg -> + let + ps = ntParams nt + cs = vcat (map pp (ntConstraints nt)) + nm = addTNames cfg ps emptyNameMap + ppTyUse = pp (ntName nt) <+> hsep (map (ppWithNamesPrec nm 9) ps) + ppKWDef kw def = (kw <+> ppTyUse) $$ nest 2 (cs $$ def) + in + case ntDef nt of Struct con -> ppKWDef "newtype" ("=" <+> pp (ntConName con) $$ nest 2 fs) @@ -1081,55 +1094,56 @@ ctrs = case ntConstraints nt of [] -> mempty _ -> parens (commaSep (map ppC (ntConstraints nt))) <+> "=>" - where - ps = ntParams nt - cs = vcat (map pp (ntConstraints nt)) - nm = addTNames ps emptyNameMap - ppTyUse = pp (ntName nt) <+> hsep (map (ppWithNamesPrec nm 9) ps) - ppKWDef kw def = (kw <+> ppTyUse) $$ nest 2 (cs $$ def) - + instance PP Schema where ppPrec = ppWithNamesPrec IntMap.empty instance PP (WithNames Schema) where - ppPrec _ (WithNames s ns) - | null (sVars s) && null (sProps s) = body - | otherwise = nest 2 (sep (vars ++ props ++ [body])) - where - body = ppWithNames ns1 (sType s) + ppPrec _ (WithNames s ns) = + withPPCfg $ \cfg -> + let + body = ppWithNames ns1 (sType s) + + vars = case sVars s of + [] -> [] + vs -> [nest 1 (braces (commaSepFill (map (ppWithNames ns1) vs)))] + + props = case sProps s of + [] -> [] + ps -> [nest 1 (parens (commaSepFill (map (ppWithNames ns1) ps))) <+> text "=>"] + + ns1 = addTNames cfg (sVars s) ns + in if null (sVars s) && null (sProps s) + then body + else nest 2 (sep (vars ++ props ++ [body])) - vars = case sVars s of - [] -> [] - vs -> [nest 1 (braces (commaSepFill (map (ppWithNames ns1) vs)))] - props = case sProps s of - [] -> [] - ps -> [nest 1 (parens (commaSepFill (map (ppWithNames ns1) ps))) <+> text "=>"] - - ns1 = addTNames (sVars s) ns - instance PP TySyn where ppPrec = ppWithNamesPrec IntMap.empty instance PP (WithNames TySyn) where ppPrec _ (WithNames ts ns) = + withPPCfg $ \cfg -> + let + ns1 = addTNames cfg (tsParams ts) ns + ctr = case kindResult (kindOf ts) of + KProp -> [text "constraint"] + _ -> [] + n = tsName ts + lhs = case (nameFixity n, tsParams ts) of + (Just _, [x, y]) -> + [ppWithNames ns1 x, pp (nameIdent n), ppWithNames ns1 y] + (_, ps) -> + [pp n] ++ map (ppWithNames ns1) ps + in nest 2 $ sep [ fsep ([text "type"] ++ ctr ++ lhs ++ [char '=']) , ppWithNames ns1 (tsDef ts) ] - where ns1 = addTNames (tsParams ts) ns - ctr = case kindResult (kindOf ts) of - KProp -> [text "constraint"] - _ -> [] - n = tsName ts - lhs = case (nameFixity n, tsParams ts) of - (Just _, [x, y]) -> - [ppWithNames ns1 x, pp (nameIdent n), ppWithNames ns1 y] - (_, ps) -> - [pp n] ++ map (ppWithNames ns1) ps + instance PP NominalType where ppPrec = ppWithNamesPrec IntMap.empty @@ -1187,7 +1201,7 @@ $ brackets (go 0 t1) <.> go 4 t2 (TCFun, [t1,t2]) -> optParens (prec > 1) - $ go 2 t1 <+> text "->" <+> go 1 t2 + $ go 2 t1 <+> text "->" go 1 t2 (TCTuple _, fs) -> ppTuple $ map (go 0) fs @@ -1247,7 +1261,7 @@ TVFree {} -> "?" <.> nmTxt where nmTxt - | Just a <- IntMap.lookup (tvUnique tv) mp = text a + | Just a <- IntMap.lookup (tvUnique tv) mp = a | otherwise = case tv of TVBound x -> @@ -1266,6 +1280,12 @@ pickTVarName :: Kind -> TypeSource -> Int -> Doc pickTVarName k src uni = + withPPCfg $ \cfg -> + let + sh a = show (fixPPCfg cfg (pp a)) + using a = mk (sh a) + mk a = a ++ "`" ++ show uni + in text $ case src of TVFromModParam n -> using n @@ -1296,10 +1316,6 @@ TypeErrorPlaceHolder -> "err" CasedExpression -> "case" ConPat -> "conp" - where - sh a = show (pp a) - using a = mk (sh a) - mk a = a ++ "`" ++ show uni instance PP TVar where ppPrec = ppWithNamesPrec IntMap.empty diff --git a/src/Cryptol/Utils/Ident.hs b/src/Cryptol/Utils/Ident.hs --- a/src/Cryptol/Utils/Ident.hs +++ b/src/Cryptol/Utils/Ident.hs @@ -155,6 +155,7 @@ Nested b i -> (a, i:bs) where (a,bs) = go b +-- | Is this an normal module (i.e., not an anonymous one) modPathIsNormal :: ModPath -> Bool modPathIsNormal p = modNameIsNormal m && all identIsNormal is where (m,is) = modPathSplit p @@ -207,9 +208,10 @@ modNameToText (ModMain _) = "Main" -- | This is useful when we want to hide anonymous modules. +-- Note that implicti `Main` modules are *not* considered anonymous. modNameIsNormal :: ModName -> Bool modNameIsNormal (ModName _ fl) = isNormal fl -modNameIsNormal (ModMain _) = False +modNameIsNormal (ModMain _) = True -- | Make a normal module name out of text. This function should not -- be used to build a @Main@ module name. See 'mainModName'. @@ -282,7 +284,7 @@ -------------------------------------------------------------------------------- --- | Identifies an entitiy +-- | Identifies an entity data OrigName = OrigName { ogNamespace :: Namespace , ogModule :: ModPath diff --git a/src/Cryptol/Utils/PP.hs b/src/Cryptol/Utils/PP.hs --- a/src/Cryptol/Utils/PP.hs +++ b/src/Cryptol/Utils/PP.hs @@ -19,12 +19,12 @@ import Control.Monad (mplus) import Data.Maybe (fromMaybe) import Data.String (IsString(..)) +import Data.Monoid(Endo(..)) import qualified Data.Text as T -import Data.Void (Void) import GHC.Generics (Generic) import qualified Prettyprinter as PP import qualified Prettyprinter.Util as PP -import qualified Prettyprinter.Render.String as PP +import qualified Prettyprinter.Render.Util.StackMachine as PP -- | How to pretty print things when evaluating data PPOpts = PPOpts @@ -134,6 +134,8 @@ debugShowUniques :: Doc -> Doc debugShowUniques = updPPCfg \cfg -> cfg { ppcfgShowNameUniques = True } +setAnnotStyle :: AnnotStyle -> Doc -> Doc +setAnnotStyle s = updPPCfg \cfg -> cfg { ppcfgAnnotStyle = s } @@ -142,16 +144,28 @@ data PPCfg = PPCfg { ppcfgNameDisp :: NameDisp , ppcfgShowNameUniques :: Bool + , ppcfgAnnotStyle :: AnnotStyle } defaultPPCfg :: PPCfg defaultPPCfg = PPCfg { ppcfgNameDisp = mempty , ppcfgShowNameUniques = False + , ppcfgAnnotStyle = AnsiAnnot } -newtype Doc = Doc (PPCfg -> PP.Doc Void) deriving (Generic, NFData) +-- | A type for annotations we can use during pretty printing +data PPAnnot = AnnError +-- | How to render annotations +data AnnotStyle = NoAnnot | AnsiAnnot | MarkdownAnnot + +-- The underlyng `Doc` type we (i.e., without the additional configuration) +type PPDoc = PP.Doc (AnnotStyle, PPAnnot) + + +newtype Doc = Doc (PPCfg -> PPDoc) deriving (Generic, NFData) + instance Semigroup Doc where (<>) = liftPP2 (<>) @@ -159,14 +173,41 @@ mempty = liftPP mempty mappend = (<>) -runDocWith :: PPCfg -> Doc -> PP.Doc Void +runDocWith :: PPCfg -> Doc -> PPDoc runDocWith names (Doc f) = f names -runDoc :: NameDisp -> Doc -> PP.Doc Void +runDoc :: NameDisp -> Doc -> PPDoc runDoc disp = runDocWith defaultPPCfg { ppcfgNameDisp = disp } +renderString :: PP.SimpleDocStream (AnnotStyle, PPAnnot) -> String +renderString = (`appEndo` "") . PP.renderSimplyDecorated one start end + where + emit x = Endo (x ++) + nothing = Endo id + one = emit . T.unpack + start (style,ann) = + case style of + NoAnnot -> nothing + AnsiAnnot -> + case ann of + -- red, underlined + AnnError -> emit "\o33[4;31m" + MarkdownAnnot -> + case ann of + AnnError -> emit "**" + end (style,ann) = + case style of + NoAnnot -> nothing + AnsiAnnot -> + case ann of + -- reset attributes + AnnError -> emit "\o33[0m" + MarkdownAnnot -> + case ann of + AnnError -> emit "**" + instance Show Doc where - show d = PP.renderString (PP.layoutPretty opts (runDocWith defaultPPCfg d)) + show d = renderString (PP.layoutPretty opts (runDocWith defaultPPCfg d)) where opts = PP.defaultLayoutOptions { PP.layoutPageWidth = PP.AvailablePerLine 100 0.666 } @@ -174,7 +215,7 @@ fromString = text renderOneLine :: Doc -> String -renderOneLine d = PP.renderString (PP.layoutPretty opts (runDocWith defaultPPCfg d)) +renderOneLine d = renderString (PP.layoutPretty opts (runDocWith defaultPPCfg d)) where opts = PP.LayoutOptions { PP.layoutPageWidth = PP.Unbounded @@ -182,6 +223,12 @@ class PP a where ppPrec :: Int -> a -> Doc + -- | Pretty print something, annotating subterms as needed. + -- | Pretty print something, annotating subterms as needed. + -- The @[Int]@ is supposed to indicate a path through the term in some + -- type specific way. + ppPrecWithAnnot :: [([Int], PPAnnot)] -> Int -> a -> Doc + ppPrecWithAnnot _ = ppPrec class PP a => PPName a where -- | Fixity information for infix operators @@ -258,16 +305,17 @@ -- Wrapped Combinators --------------------------------------------------------- -liftPP :: PP.Doc Void -> Doc + +liftPP :: PPDoc -> Doc liftPP d = Doc (const d) -liftPP1 :: (PP.Doc Void -> PP.Doc Void) -> Doc -> Doc -liftPP1 f (Doc d) = Doc (\env -> f (d env)) +liftPP1 :: (PPDoc -> PPDoc) -> Doc -> Doc +liftPP1 f (Doc d) = Doc (f . d) -liftPP2 :: (PP.Doc Void -> PP.Doc Void -> PP.Doc Void) -> (Doc -> Doc -> Doc) +liftPP2 :: (PPDoc -> PPDoc -> PPDoc) -> (Doc -> Doc -> Doc) liftPP2 f (Doc a) (Doc b) = Doc (\e -> f (a e) (b e)) -liftSep :: ([PP.Doc Void] -> PP.Doc Void) -> ([Doc] -> Doc) +liftSep :: ([PPDoc] -> PPDoc) -> ([Doc] -> Doc) liftSep f ds = Doc (\e -> f [ d e | Doc d <- ds ]) reflow :: T.Text -> Doc @@ -275,6 +323,9 @@ infixl 6 <.>, <+>, +annotate :: PPAnnot -> Doc -> Doc +annotate a d = withPPCfg \cfg -> liftPP1 (PP.annotate (ppcfgAnnotStyle cfg, a)) d + (<.>) :: Doc -> Doc -> Doc (<.>) = liftPP2 (PP.<>) @@ -282,7 +333,7 @@ (<+>) = liftPP2 (PP.<+>) () :: Doc -> Doc -> Doc -Doc x Doc y = Doc (\e -> x e <> PP.softline <> y e) +Doc x Doc y = Doc (\e -> x e <> PP.group (PP.line <> y e)) infixl 5 $$ @@ -293,7 +344,10 @@ sep = liftSep PP.sep fsep :: [Doc] -> Doc -fsep = liftSep PP.fillSep +fsep = liftSep fillSep + where + fillSep [] = mempty + fillSep (d0 : ds) = foldl (\a d -> a <> PP.group (PP.line <> d)) d0 ds hsep :: [Doc] -> Doc hsep = liftSep PP.hsep diff --git a/src/Cryptol/Version.hs b/src/Cryptol/Version.hs --- a/src/Cryptol/Version.hs +++ b/src/Cryptol/Version.hs @@ -7,6 +7,8 @@ -- Portability : portable {-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} module Cryptol.Version ( commitHash @@ -16,25 +18,76 @@ , ffiEnabled , version , displayVersion + , displayVersionStr ) where -import Paths_cryptol -import qualified GitRev -import Data.Version (showVersion) import Control.Monad (when) +import Control.Monad.Writer (MonadWriter(..), Writer, execWriter) +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.KeyMap as KeyMap +import qualified Data.ByteString as BS +import Data.FileEmbed (embedFileRelative) +import Data.List (intercalate) +import qualified Data.Text as Text +import Data.Version (showVersion) +import qualified GitRev +import Paths_cryptol commitHash :: String -commitHash = GitRev.hash +commitHash + | hash /= unknown = + hash + -- See Note [cryptol.buildinfo.json] + | Just buildinfoVal <- Aeson.decodeStrict buildinfo + , Just (Aeson.String buildinfoHash) <- KeyMap.lookup "hash" buildinfoVal = + Text.unpack buildinfoHash + | otherwise = + unknown + where + hash = GitRev.hash commitShortHash :: String commitShortHash = take 7 GitRev.hash commitBranch :: String -commitBranch = GitRev.branch +commitBranch + | branch /= unknown = + branch + -- See Note [cryptol.buildinfo.json] + | Just buildinfoVal <- Aeson.decodeStrict buildinfo + , Just (Aeson.String buildinfoCommit) <- KeyMap.lookup "branch" buildinfoVal = + Text.unpack buildinfoCommit + | otherwise = + unknown + where + branch = GitRev.branch commitDirty :: Bool -commitDirty = GitRev.dirty +commitDirty + | dirty = + dirty + -- See Note [cryptol.buildinfo.json] + | Just buildinfoVal <- Aeson.decodeStrict buildinfo + , Just (Aeson.Bool buildinfoDirty) <- KeyMap.lookup "dirty" buildinfoVal = + buildinfoDirty + | otherwise = + False + where + dirty = GitRev.dirty +-- Helper, not exported +-- +-- What to report if we are unable to determine git-related information. This +-- intentionally matches what the @gitrev@ library prints in such a scenario. +unknown :: String +unknown = "UNKNOWN" + +-- Helper, not exported +-- +-- See Note [cryptol.buildinfo.json] +buildinfo :: BS.ByteString +buildinfo = $(embedFileRelative "cryptol.buildinfo.json") + ffiEnabled :: Bool #ifdef FFI_ENABLED ffiEnabled = True @@ -52,3 +105,39 @@ where dirtyLab | commitDirty = " (non-committed files present during build)" | otherwise = "" + +-- | A pure version of 'displayVersion' that renders the displayed version +-- directly to a 'String'. +displayVersionStr :: String +displayVersionStr = intercalate "\n" $ execWriter $ displayVersion putLn + where + putLn :: String -> Writer [String] () + putLn str = tell [str] + +{- +Note [cryptol.buildinfo.json] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +By default, we determine the git commit hash, branch, and dirty information +using the gitrev library, which invokes git at compile time to query the +relevant information in the .git subdirectory. This works well for local +developments where the git binary and the .git subdirectory are both readily +available. It does not work so well for building in a Docker image, as we +intentionally do not copy over the .git subdirectory into the image to prevent +spurious cache invalidations caused by the contents of .git changing (which +they do, quite often). + +As an alternative to gitrev, we also employ a convention where a build system +can create a cryptol.buildinfo.json file locally which contains the necessary +git-related information. The schema for this file is: + + { + "hash": , + "branch": , + "dirty": + } + +This way, a build system (which has access to git/.git) can write this +information to a file, proceed to build the Docker image (which does not have +access to git/.git), and then have all of the expected information embedded +into the output of --version. +-} diff --git a/src/GHC/Num/Compat.hs b/src/GHC/Num/Compat.hs --- a/src/GHC/Num/Compat.hs +++ b/src/GHC/Num/Compat.hs @@ -37,6 +37,7 @@ -- * Conversions , bigNatToInteger + , bigNatToNegInteger , integerToBigNat ) where @@ -52,6 +53,10 @@ bigNatToInteger :: BigNat# -> Integer bigNatToInteger = Integer.integerFromBigNat# +-- | Coerce a @BigNat#@ to a negative integer value. +bigNatToNegInteger :: BigNat# -> Integer +bigNatToNegInteger = Integer.integerFromBigNatNeg# + -- | @'integerRecipMod' x m@ computes the modular inverse of @x@ mod @m@. -- -- PRECONDITION: @m@ must be strictly positive. @@ -86,7 +91,7 @@ zeroBigNat :: (# #) -> BigNat# zeroBigNat _ = BN.bigNatFromWord# 0## #else -import GHC.Integer.GMP.Internals (bigNatToInteger, recipModBigNat, shiftLBigNat, shiftRBigNat, testBitBigNat) +import GHC.Integer.GMP.Internals (bigNatToInteger, bigNatToNegInteger, recipModBigNat, shiftLBigNat, shiftRBigNat, testBitBigNat) import qualified GHC.Integer.GMP.Internals as GMP import GHC.Exts