diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,81 @@ +# 2.12.0 + +## Language changes +* Updates to the layout rule. We simplified the specification and made + some minor changes, in particular: + - Paren blocks nested in a layout block need to respect the indentation + if the layout block + - We allow nested layout blocks to have the same indentation, which is + convenient when writing `private` declarations as they don't need to + be indented as long as they are at the end of the file. + +* New enumeration forms `[x .. y by n]`, `[x .. y down by n]` have been + implemented. These new forms let the user explicitly specify + the stride for an enumeration, as opposed to the previous + `[x, y .. z]` form (where the stride was computed from `x` and `y`). + +* Nested modules are now available (from pull request #1048). For example, the following is now valid Cryptol: + + module SubmodTest where + + import submodule B as C + + submodule A where + propA = C::y > 5 + + submodule B where + y : Integer + y = 42 + +## New features + +* What4 prover backends now feature an improved multi-SAT procedure + which is significantly faster than the old algorithm. Thanks to + Levent Erkök for the suggestion. + +* There is a new `w4-abc` solver option, which communicates to ABC + as an external process via What4. + +* Expanded support for declaration forms in the REPL. You can now + define infix operators, type synonyms and mutually-recursive functions, + and state signatures and fixity declarations. Multiple declarations + can be combined into a single line by separating them with `;`, + which is necessary for stating a signature together with a + definition, etc. + +* There is a new `:set path` REPL option that provides an alternative to + `CRYPTOLPATH` for controlling where to search for imported modules + (issue #631). + +* The `cryptol-remote-api` server now natively supports HTTPS (issue + #1008), `newtype` values (issue #1033), and safety checking (issue + #1166). + +* Releases optionally include solvers (issue #1111). See the + `*-with-solvers*` files in the assets list for this release. + +## Bug fixes + +* Closed issues #422, #436, #619, #631, #633, #640, #680, #734, #735, + #759, #760, #764, #849, #996, #1000, #1008, #1019, #1032, #1033, + #1034, #1043, #1047, #1060, #1064, #1083, #1084, #1087, #1102, #1111, + #1113, #1117, #1125, #1133, #1142, #1144, #1145, #1146, #1157, #1160, + #1163, #1166, #1169, #1175, #1179, #1182, #1190, #1191, #1196, #1197, + #1204, #1209, #1210, #1213, #1216, #1223, #1226, #1238, #1239, #1240, + #1241, #1250, #1256, #1259, #1261, #1266, #1274, #1275, #1283, and + #1291. + +* Merged pull requests #1048, #1128, #1129, #1130, #1131, #1135, #1136, + #1137, #1139, #1148, #1149, #1150, #1152, #1154, #1156, #1158, #1159, + #1161, #1164, #1165, #1168, #1170, #1171, #1172, #1173, #1174, #1176, + #1181, #1183, #1186, #1188, #1192, #1193, #1194, #1195, #1199, #1200, + #1202, #1203, #1205, #1207, #1211, #1214, #1215, #1218, #1219, #1221, + #1224, #1225, #1227, #1228, #1230, #1231, #1232, #1234, #1242, #1243, + #1244, #1245, #1246, #1247, #1248, #1251, #1252, #1254, #1255, #1258, + #1263, #1265, #1268, #1269, #1270, #1271, #1272, #1273, #1276, #1281, + #1282, #1284, #1285, #1286, #1287, #1288, #1293, #1294, and #1295. + # 2.11.0 ## Language changes 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: 2.11.0 +Version: 2.12.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 @@ -25,7 +25,8 @@ source-repository this type: git location: https://github.com/GaloisInc/cryptol.git - tag: 2.11.0 + -- add a tag on release branches + tag: 2.12.0 flag static @@ -61,11 +62,10 @@ monad-control >= 1.0, monadLib >= 3.7.2, parameterized-utils >= 2.0.2, - pretty >= 1.1, + prettyprinter >= 1.7.0, process >= 1.2, - random >= 1.0.1, - sbv >= 8.6 && < 8.13, - simple-smt >= 0.7.1, + sbv >= 8.6 && < 8.17, + simple-smt >= 0.9.7, stm >= 2.4, strict, text >= 1.1, @@ -74,13 +74,15 @@ mtl >= 2.2.1, time >= 1.6.0.1, panic >= 0.3, - what4 >= 1.1 && < 1.2 + what4 >= 1.2 && < 1.3 Build-tool-depends: alex:alex, happy:happy hs-source-dirs: src Exposed-modules: Cryptol.Parser, Cryptol.Parser.Lexer, + Cryptol.Parser.Token, + Cryptol.Parser.Layout, Cryptol.Parser.AST, Cryptol.Parser.Position, Cryptol.Parser.Names, @@ -110,9 +112,11 @@ Cryptol.ModuleSystem.Monad, Cryptol.ModuleSystem.Name, Cryptol.ModuleSystem.NamingEnv, - Cryptol.ModuleSystem.Renamer, Cryptol.ModuleSystem.Exports, Cryptol.ModuleSystem.InstantiateModule, + Cryptol.ModuleSystem.Renamer, + Cryptol.ModuleSystem.Renamer.Monad, + Cryptol.ModuleSystem.Renamer.Error, Cryptol.TypeCheck, Cryptol.TypeCheck.Type, @@ -125,12 +129,12 @@ Cryptol.TypeCheck.Infer, Cryptol.TypeCheck.CheckModuleInstance, Cryptol.TypeCheck.InferTypes, + Cryptol.TypeCheck.Interface, Cryptol.TypeCheck.Error, Cryptol.TypeCheck.Kind, Cryptol.TypeCheck.Subst, Cryptol.TypeCheck.Instantiate, Cryptol.TypeCheck.Unify, - Cryptol.TypeCheck.Depends, Cryptol.TypeCheck.PP, Cryptol.TypeCheck.Solve, Cryptol.TypeCheck.Default, @@ -162,8 +166,10 @@ Cryptol.Backend.Concrete, Cryptol.Backend.FloatHelpers, Cryptol.Backend.Monad, + Cryptol.Backend.SeqMap, Cryptol.Backend.SBV, Cryptol.Backend.What4, + Cryptol.Backend.WordValue, Cryptol.Eval, Cryptol.Eval.Concrete, @@ -188,6 +194,7 @@ Cryptol.Symbolic.What4, Cryptol.REPL.Command, + Cryptol.REPL.Browse, Cryptol.REPL.Monad, Cryptol.REPL.Trie @@ -224,6 +231,7 @@ , directory , filepath , haskeline >= 0.7 && < 0.9 + , exceptions , monad-control , text , transformers diff --git a/cryptol/Main.hs b/cryptol/Main.hs --- a/cryptol/Main.hs +++ b/cryptol/Main.hs @@ -15,7 +15,7 @@ import Cryptol.REPL.Command (loadCmd,loadPrelude,CommandExitCode(..)) import Cryptol.REPL.Monad (REPL,updateREPLTitle,setUpdateREPLTitle, - io,prependSearchPath,setSearchPath) + io,prependSearchPath,setSearchPath,parseSearchPath) import qualified Cryptol.REPL.Monad as REPL import Cryptol.ModuleSystem.Env(ModulePath(..)) @@ -32,7 +32,7 @@ import System.Directory (getTemporaryDirectory, removeFile) import System.Environment (getArgs, getProgName, lookupEnv) import System.Exit (exitFailure,exitSuccess) -import System.FilePath (searchPathSeparator, splitSearchPath, takeDirectory) +import System.FilePath (searchPathSeparator, takeDirectory) import System.IO (hClose, hPutStr, openTempFile) @@ -256,14 +256,8 @@ mCryptolPath <- io $ lookupEnv "CRYPTOLPATH" case mCryptolPath of Nothing -> return () - Just path | optCryptolPathOnly opts -> setSearchPath path' - | otherwise -> prependSearchPath path' -#if defined(mingw32_HOST_OS) || defined(__MINGW32__) - -- Windows paths search from end to beginning - where path' = reverse (splitSearchPath path) -#else - where path' = splitSearchPath path -#endif + Just path | optCryptolPathOnly opts -> setSearchPath (parseSearchPath path) + | otherwise -> prependSearchPath (parseSearchPath path) smoke <- REPL.smokeTest case smoke of [] -> return () diff --git a/cryptol/REPL/Haskeline.hs b/cryptol/REPL/Haskeline.hs --- a/cryptol/REPL/Haskeline.hs +++ b/cryptol/REPL/Haskeline.hs @@ -16,7 +16,7 @@ import Cryptol.REPL.Command import Cryptol.REPL.Monad import Cryptol.REPL.Trie -import Cryptol.Utils.PP +import Cryptol.Utils.PP hiding (()) import Cryptol.Utils.Logger(stdoutLogger) import Cryptol.Utils.Ident(modNameToText, interactiveName) @@ -99,7 +99,7 @@ getInputLines = handleInterrupt (MTL.lift (handleCtrlC Interrupted)) . loop [] where loop ls prompt = - do mb <- getInputLine prompt + do mb <- fmap (filter (/= '\r')) <$> getInputLine prompt let newPropmpt = map (\_ -> ' ') prompt case mb of Nothing -> return NoMoreLines diff --git a/lib/Array.cry b/lib/Array.cry --- a/lib/Array.cry +++ b/lib/Array.cry @@ -11,3 +11,47 @@ primitive arrayLookup : {a, b} (Array a b) -> a -> b primitive arrayUpdate : {a, b} (Array a b) -> a -> b -> (Array a b) +/** + * Copy elements from the source array to the destination array. + * + * 'arrayCopy dest_arr dest_idx src_arr src_idx len' copies the + * elements from 'src_arr' at indices '[src_idx ..< (src_idx + len)]' into + * 'dest_arr' at indices '[dest_idx ..< (dest_idx + len)]'. + * + * The result is undefined if either 'dest_idx + len' or 'src_idx + len' + * wraps around. + */ +primitive arrayCopy : {n, a} (Array [n] a) -> [n] -> (Array [n] a) -> [n] -> [n] -> (Array [n] a) +/** + * Set elements of the given array. + * + * 'arraySet' arr idx val len' sets the elements of 'arr' at indices + * '[idx ..< (idx + len)]' to 'val'. + * + * The result is undefined if 'idx + len' wraps around. + */ +primitive arraySet : {n, a} (Array [n] a) -> [n] -> a -> [n] -> (Array [n] a) +/** + * Check whether the lhs array and rhs array are equal at a range of + * indices. + * + * 'arrayRangeEq sym lhs_arr lhs_idx rhs_arr rhs_idx len' checks whether + * the elements of 'lhs_arr' at indices '[lhs_idx ..< (lhs_idx + len)]' and + * the elements of 'rhs_arr' at indices '[rhs_idx ..< (rhs_idx + len)]' are + * equal. + * + * The result is undefined if either 'lhs_idx + len' or 'rhs_idx + len' + * wraps around. + */ +primitive arrayRangeEqual : {n, a} (Array [n] a) -> [n] -> (Array [n] a) -> [n] -> [n] -> Bool + +arrayRangeLookup : {a, b, n} (Integral a, fin n, LiteralLessThan n a) => (Array a b) -> a -> [n]b +arrayRangeLookup arr idx = res + where + res @ i = arrayLookup arr (idx + i) + +arrayRangeUpdate : {a, b, n} (Integral a, fin n, LiteralLessThan n a) => (Array a b) -> a -> [n]b -> (Array a b) +arrayRangeUpdate arr idx vals = arrs ! 0 + where + arrs = [arr] # [ arrayUpdate acc (idx + i) val | acc <- arrs | i <- [0 ..< n] | val <- vals ] + diff --git a/lib/Cryptol.cry b/lib/Cryptol.cry --- a/lib/Cryptol.cry +++ b/lib/Cryptol.cry @@ -32,7 +32,7 @@ /** * 'Z n' is the type of integers, modulo 'n'. * - * The values of 'Z n' may be thought of as equivalance + * The values of 'Z n' may be thought of as equivalence * classes of integers according to the equivalence * 'x ~ y' iff 'n' divides 'x - y'. 'Z n' naturally * forms a ring, but does not support integral division @@ -41,9 +41,9 @@ * However, you may use the 'fromZ' operation * to project values in 'Z n' into the integers if such operations * are required. This will compute the reduced representative - * of the equivalance class. In other words, 'fromZ' computes + * of the equivalence class. In other words, 'fromZ' computes * the (unique) integer value 'i' where '0 <= i < n' and - * 'i' is in the given equivalance class. + * 'i' is in the given equivalence class. * * If the modulus 'n' is prime, 'Z n' also * supports computing inverses and forms a field. @@ -131,13 +131,13 @@ /** Divide numeric types, rounding up. */ primitive type { m : #, n : # } - (fin m, fin n, n >= 1) => + (fin n, n >= 1) => m /^ n : # /** How much we need to add to make a proper multiple of the second argument. */ primitive type { m : #, n : # } - (fin m, fin n, n >= 1) => + (fin n, n >= 1) => m %^ n : # /** The length of an enumeration. */ @@ -195,26 +195,76 @@ /** * A finite sequence counting up from 'first' to 'last'. * - * '[a..b]' is syntactic sugar for 'fromTo`{first=a,last=b}'. + * '[x .. y]' is syntactic sugar for 'fromTo`{first=x,last=y}'. */ -primitive fromTo : {first, last, a} (fin last, last >= first, - Literal first a, Literal last a) => - [1 + (last - first)]a +primitive fromTo : {first, last, a} + (fin last, last >= first, Literal last a) => + [1 + (last - first)]a /** * A possibly infinite sequence counting up from 'first' up to (but not including) 'bound'. * - * Note that if 'first' = 'bound' then the sequence will be empty. + * '[ x ..< y ]' is syntactic sugar for 'fromToLessThan`{first=x,bound=y}'. + * + * Note that if 'first' = 'bound' then the sequence will be empty. If 'bound = inf' + * then the sequence will be infinite, and will eventually wrap around for bounded types. */ primitive fromToLessThan : - {first, bound, a} (fin first, bound >= first, LiteralLessThan bound a) => [bound - first]a + {first, bound, a} (fin first, bound >= first, LiteralLessThan bound a) => + [bound - first]a +/** + * A finite sequence counting up from 'first' to 'last' by 'stride'. + * Note that 'last' will only be an element of the enumeration if + * 'stride' divides 'last - first' evenly. + * + * '[x .. y by n]' is syntactic sugar for 'fromToBy`{first=x,last=y,stride=n}'. + */ +primitive fromToBy : {first, last, stride, a} + (fin last, fin stride, stride >= 1, last >= first, Literal last a) => + [1 + (last - first)/stride]a /** + * A finite sequence counting from 'first' up to (but not including) 'bound' + * by 'stride'. Note that if 'first = bound' then the sequence will + * be empty. If 'bound = inf' then the sequence will be infinite, and will + * eventually wrap around for bounded types. + * + * '[x ..< y by n]' is syntactic sugar for 'fromToByLessThan`{first=x,bound=y,stride=n}'. + */ +primitive fromToByLessThan : {first, bound, stride, a} + (fin first, fin stride, stride >= 1, bound >= first, LiteralLessThan bound a) => + [(bound - first)/^stride]a + +/** + * A finite sequence counting from 'first' down to 'last' by 'stride'. + * Note that 'last' will only be an element of the enumeration if + * 'stride' divides 'first - last' evenly. + * + * '[x .. y down by n]' is syntactic sugar for 'fromToDownBy`{first=x,last=y,stride=n}'. + */ +primitive fromToDownBy : {first, last, stride, a} + (fin first, fin stride, stride >= 1, first >= last, Literal first a) => + [1 + (first - last)/stride]a + +/** + * A finite sequence counting from 'first' down to (but not including) + * 'bound' by 'stride'. + * + * '[x ..> y down by n]' is syntactic sugar for + * 'fromToDownByGreaterThan`{first=x,bound=y,stride=n}'. + * + * Note that if 'first = bound' the sequence will be empty. + */ +primitive fromToDownByGreaterThan : {first, bound, stride, a} + (fin first, fin stride, stride >= 1, first >= bound, Literal first a) => + [(first - bound)/^stride]a + +/** * A finite arithmetic sequence starting with 'first' and 'next', * stopping when the values reach or would skip over 'last'. * - * '[a,b..c]' is syntactic sugar for 'fromThenTo`{first=a,next=b,last=c}'. + * '[x,y..z]' is syntactic sugar for 'fromThenTo`{first=x,next=y,last=z}'. */ primitive fromThenTo : {first, next, last, a, len} ( fin first, fin next, fin last @@ -224,12 +274,12 @@ // Fractional Literals --------------------- -/** 'FLiteral m n r a' asserts that the type `a' contains the -fraction `m/n`. The flag `r` indicates if we should round (`r >= 1`) +/** 'FLiteral m n r a' asserts that the type 'a' contains the +fraction 'm/n'. The flag 'r' indicates if we should round ('r >= 1') or report an error if the number can't be represented exactly. */ primitive type FLiteral : # -> # -> # -> * -> Prop -/** A fractional literal corresponding to `m/n` */ +/** A fractional literal corresponding to 'm/n' */ primitive fraction : { m, n, r, a } FLiteral m n r a => a @@ -387,7 +437,7 @@ /** * Value types that correspond to a field; that is, - * a ring also posessing multiplicative inverses for + * a ring also possessing multiplicative inverses for * non-zero elements. * * Floating-point values are only approximately a field, @@ -684,7 +734,12 @@ */ primitive lg2 : {n} (fin n) => [n] -> [n] +/** + * Convert a signed 2's complement bitvector to an integer. + */ +primitive toSignedInteger : {n} (fin n, n >= 1) => [n] -> Integer + // Rational specific operations ---------------------------------------------- /** @@ -717,8 +772,9 @@ * Splits a sequence into a pair of sequences. * 'splitAt z = (x, y)' iff 'x # y = z'. */ -primitive splitAt : {front, back, a} (fin front) => [front + back]a - -> ([front]a, [back]a) +splitAt : {front, back, a} (fin front) => [front + back]a + -> ([front]a, [back]a) +splitAt xs = (take`{front,back} xs, drop`{front,back} xs) /** * Concatenates a list of sequences. @@ -745,18 +801,15 @@ */ primitive transpose : {rows, cols, a} [rows][cols]a -> [cols][rows]a - /** * Select the first (left-most) 'front' elements of a sequence. */ -take : {front, back, a} (fin front) => [front + back]a -> [front]a -take (x # _) = x +primitive take : {front, back, a} [front + back]a -> [front]a /** * Select all the elements after (to the right of) the 'front' elements of a sequence. */ -drop : {front, back, a} (fin front) => [front + back]a -> [back]a -drop ((_ : [front] _) # y) = y +primitive drop : {front, back, a} (fin front) => [front + back]a -> [back]a /** * Drop the first (left-most) element of a sequence. @@ -899,6 +952,31 @@ generate f = [ f i | i <- [0 .. [n]a -> [n]a +sort = sortBy (<=) + +/** + * Sort a sequence according to the given less-than-or-equal relation. + * The sorting is stable, so it preserves the relative position of any + * pair of elements that are equivalent according to the order relation. + */ +sortBy : {a, n} (fin n) => (a -> a -> Bit) -> [n]a -> [n]a +sortBy le vs = + if `n == (0 : Integer) then vs + else drop`{1 - min 1 n} (insertBy (vs@0) (sortBy le (drop`{min 1 n} vs))) + where + insertBy : {k} (fin k) => a -> [k]a -> [k+1]a + insertBy x0 ys = xys.0 # [last xs] + where + xs : [k+1]a + xs = [x0] # xys.1 + xys : [k](a, a) + xys = [ if le x y then (x, y) else (y, x) | x <- xs | y <- ys ] + + // GF_2^n polynomial computations ------------------------------------------- /** @@ -920,7 +998,7 @@ /** * Parallel map. The given function is applied to each element in the - * given finite seqeuence, and the results are computed in parallel. + * given finite sequence, and the results are computed in parallel. * The values in the resulting sequence are reduced to normal form, * as is done with the deepseq operation. * diff --git a/lib/CryptolTC.z3 b/lib/CryptolTC.z3 --- a/lib/CryptolTC.z3 +++ b/lib/CryptolTC.z3 @@ -267,10 +267,12 @@ )) ) - - (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 @@ -291,15 +293,19 @@ ) (define-fun cryCeilDiv ((x InfNat) (y InfNat)) InfNat - (ite (or (isErr x) (isErr y) (not (isFin x)) (not (isFin y))) cryErr - (ite (= (value y) 0) cryErr (cryNat (- (div (- (value x)) (value y))))) - ) + (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 x)) (not (isFin y))) cryErr - (ite (= (value y) 0) cryErr (cryNat (mod (- (value x)) (value y)))) - ) + (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 diff --git a/lib/SuiteB.cry b/lib/SuiteB.cry --- a/lib/SuiteB.cry +++ b/lib/SuiteB.cry @@ -205,7 +205,7 @@ type sha2_padded_size w L = sha2_num_blocks w L * sha2_block_size w sha2pad : {w, L} (fin w, fin L, w >= 1) => [L] -> [sha2_padded_size w L] - sha2pad M = M # 0b1 # zero # ((fromInteger `L) : [2*w]) + sha2pad M = rnf (M # 0b1 # zero # ((fromInteger `L) : [2*w])) sha2blocks : {w, L} (fin w, fin L, w >= 1) => [L] -> [sha2_num_blocks w L][16][w] diff --git a/src/Cryptol/Backend.hs b/src/Cryptol/Backend.hs --- a/src/Cryptol/Backend.hs +++ b/src/Cryptol/Backend.hs @@ -7,7 +7,11 @@ , cryUserError , cryNoPrimError , FPArith2 + , IndexDirection(..) + , enumerateIntBits + , enumerateIntBits' + -- * Rationals , SRational(..) , intToRational @@ -29,15 +33,21 @@ , iteRational ) where +import qualified Control.Exception as X import Control.Monad.IO.Class import Data.Kind (Type) import Cryptol.Backend.FloatHelpers (BF) import Cryptol.Backend.Monad - ( EvalError(..), CallStack, pushCallFrame ) + ( EvalError(..), Unsupported(..), CallStack, pushCallFrame ) import Cryptol.ModuleSystem.Name(Name) import Cryptol.Parser.Position +import Cryptol.TypeCheck.Solver.InfNat(Nat'(..),widthInteger) +data IndexDirection + = IndexForward + | IndexBackward + invalidIndex :: Backend sym => sym -> Integer -> SEval sym a invalidIndex sym i = raiseError sym (InvalidIndex (Just i)) @@ -191,6 +201,31 @@ iteRational sym p (SRational a b) (SRational c d) = SRational <$> iteInteger sym p a c <*> iteInteger sym p b d +-- | Compute the list of bits in an integer in big-endian order. +-- The integer argument is a concrete upper bound for +-- the symbolic integer. +enumerateIntBits' :: Backend sym => + sym -> + Integer -> + SInteger sym -> + SEval sym (Integer, [SBit sym]) +enumerateIntBits' sym n idx = + do let width = widthInteger n + w <- wordFromInt sym width idx + bs <- unpackWord sym w + pure (width, bs) + +-- | Compute the list of bits in an integer in big-endian order. +-- Fails if neither the sequence length nor the type value +-- provide an upper bound for the integer. +enumerateIntBits :: Backend sym => + sym -> + Nat' -> + SInteger sym -> + SEval sym (Integer, [SBit sym]) +enumerateIntBits sym (Nat n) idx = enumerateIntBits' sym n idx +enumerateIntBits _sym Inf _ = liftIO (X.throw (UnsupportedSymbolicOp "unbounded integer shifting")) + -- | This type class defines a collection of operations on bits, words and integers that -- are necessary to define generic evaluator primitives that operate on both concrete -- and symbolic values uniformly. @@ -205,7 +240,7 @@ -- | Check if an operation is "ready", which means its -- evaluation will be trivial. - isReady :: sym -> SEval sym a -> Bool + isReady :: sym -> SEval sym a -> SEval sym (Maybe a) -- | Produce a thunk value which can be filled with its associated computation -- after the fact. A preallocated thunk is returned, along with an operation to @@ -488,6 +523,51 @@ SWord sym -> SEval sym (SWord sym) + -- | Shift a bitvector left by the specified amount. + -- The shift amount is considered as an unsigned value. + -- Shifting by more than the word length results in 0. + wordShiftLeft :: + sym -> + SWord sym {- ^ value to shift -} -> + SWord sym {- ^ amount to shift by -} -> + SEval sym (SWord sym) + + -- | Shift a bitvector right by the specified amount. + -- This is a logical shift, which shifts in 0 values + -- on the left. The shift amount is considered as an + -- unsigned value. Shifting by more than the word length + -- results in 0. + wordShiftRight :: + sym -> + SWord sym {- ^ value to shift -} -> + SWord sym {- ^ amount to shift by -} -> + SEval sym (SWord sym) + + -- | Shift a bitvector right by the specified amount. This is an + -- arithmetic shift, which shifts in copies of the high bit on the + -- left. The shift amount is considered as an unsigned + -- value. Shifting by more than the word length results in filling + -- the bitvector with the high bit. + wordSignedShiftRight :: + sym -> + SWord sym {- ^ value to shift -} -> + SWord sym {- ^ amount to shift by -} -> + SEval sym (SWord sym) + + wordRotateLeft :: + sym -> + SWord sym {- ^ value to rotate -} -> + SWord sym {- ^ amount to rotate by -} -> + SEval sym (SWord sym) + + wordRotateRight :: + sym -> + SWord sym {- ^ value to rotate -} -> + SWord sym {- ^ amount to rotate by -} -> + SEval sym (SWord sym) + + + -- | 2's complement negation of bitvectors wordNegate :: sym -> @@ -530,6 +610,12 @@ -- | Construct an integer value from the given packed word. wordToInt :: + sym -> + SWord sym -> + SEval sym (SInteger sym) + + -- | Construct a signed integer value from the given packed word. + wordToSignedInt :: sym -> SWord sym -> SEval sym (SInteger sym) diff --git a/src/Cryptol/Backend/Concrete.hs b/src/Cryptol/Backend/Concrete.hs --- a/src/Cryptol/Backend/Concrete.hs +++ b/src/Cryptol/Backend/Concrete.hs @@ -114,7 +114,7 @@ prefix = case base of 2 -> text "0b" <.> padding 1 8 -> text "0o" <.> padding 3 - 10 -> empty + 10 -> mempty 16 -> text "0x" <.> padding 4 _ -> text "0" <.> char '<' <.> int base <.> char '>' @@ -152,8 +152,7 @@ wordUpdate _ (BV w x) idx True = pure $! BV w (setBit x (fromInteger (w - 1 - idx))) wordUpdate _ (BV w x) idx False = pure $! BV w (clearBit x (fromInteger (w - 1 - idx))) - isReady _ (Ready _) = True - isReady _ _ = False + isReady _ = maybeReady mergeEval _sym f c mx my = do x <- mx @@ -186,6 +185,7 @@ integerAsLit _ = Just wordToInt _ (BV _ x) = pure x + wordToSignedInt _ (BV w x) = pure $! signedValue w x wordFromInt _ w x = pure $! mkBv w x packWord _ bits = pure $! BV (toInteger w) a @@ -284,6 +284,33 @@ sy = signedValue i y pure $! mkBv i (sx `rem` sy) | otherwise = panic "Attempt to mod words of different sizes: wordSignedMod" [show i, show j] + + wordShiftLeft _sym (BV w ival) (BV _ by) + | by >= w = pure $! BV w 0 + | by > toInteger (maxBound :: Int) = panic "shl" ["Shift amount too large", show by] + | otherwise = pure $! mkBv w (shiftL ival (fromInteger by)) + + wordShiftRight _sym (BV w ival) (BV _ by) + | by >= w = pure $! BV w 0 + | by > toInteger (maxBound :: Int) = panic "lshr" ["Shift amount too large", show by] + | otherwise = pure $! BV w (shiftR ival (fromInteger by)) + + wordSignedShiftRight _sym (BV w ival) (BV _ by) = + let by' = min w by in + if by' > toInteger (maxBound :: Int) then + panic "wordSignedShiftRight" ["Shift amount too large", show by] + else + pure $! mkBv w (shiftR (signedValue w ival) (fromInteger by')) + + wordRotateRight _sym (BV 0 i) _ = pure (BV 0 i) + wordRotateRight _sym (BV w i) (BV _ by) = + pure . mkBv w $! (i `shiftR` b) .|. (i `shiftL` (fromInteger w - b)) + where b = fromInteger (by `mod` w) + + wordRotateLeft _sym (BV 0 i) _ = pure (BV 0 i) + wordRotateLeft _sym (BV w i) (BV _ by) = + pure . mkBv w $! (i `shiftL` b) .|. (i `shiftR` (fromInteger w - b)) + where b = fromInteger (by `mod` w) wordLg2 _ (BV i x) = pure $! mkBv i (lg2 x) 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 @@ -63,12 +63,33 @@ -- | The type of dynamic call stacks for the interpreter. -- New frames are pushed onto the right side of the sequence. -type CallStack = Seq (Name, Range) +data CallStack + = EmptyCallStack + | CombineCallStacks !CallStack !CallStack + | PushCallFrame !Name !Range !CallStack +instance Semigroup CallStack where + (<>) = CombineCallStacks + +instance Monoid CallStack where + mempty = EmptyCallStack + +type CallStack' = Seq (Name, Range) + +evalCallStack :: CallStack -> CallStack' +evalCallStack stk = + case stk of + EmptyCallStack -> mempty + CombineCallStacks appstk fnstk -> combineCallStacks' (evalCallStack appstk) (evalCallStack fnstk) + PushCallFrame n r stk1 -> pushCallFrame' n r (evalCallStack stk1) + -- | Pretty print a call stack with each call frame on a separate -- line, with most recent call frames at the top. displayCallStack :: CallStack -> Doc -displayCallStack = vcat . map f . toList . Seq.reverse +displayCallStack = displayCallStack' . evalCallStack + +displayCallStack' :: CallStack' -> Doc +displayCallStack' = vcat . map f . toList . Seq.reverse where f (nm,rng) | rng == emptyRange = pp nm @@ -92,7 +113,15 @@ CallStack {- ^ call stack of the application context -} -> CallStack {- ^ call stack of the function being applied -} -> CallStack -combineCallStacks appstk fnstk = appstk <> dropCommonPrefix appstk fnstk +combineCallStacks appstk EmptyCallStack = appstk +combineCallStacks EmptyCallStack fnstk = fnstk +combineCallStacks appstk fnstk = CombineCallStacks appstk fnstk + +combineCallStacks' :: + CallStack' {- ^ call stack of the application context -} -> + CallStack' {- ^ call stack of the function being applied -} -> + CallStack' +combineCallStacks' appstk fnstk = appstk <> dropCommonPrefix appstk fnstk where dropCommonPrefix _ Seq.Empty = Seq.Empty dropCommonPrefix Seq.Empty fs = fs @@ -102,9 +131,12 @@ -- | Add a call frame to the top of a call stack pushCallFrame :: Name -> Range -> CallStack -> CallStack -pushCallFrame nm rng stk@( _ Seq.:|> (nm',rng')) +pushCallFrame nm rng stk = PushCallFrame nm rng stk + +pushCallFrame' :: Name -> Range -> CallStack' -> CallStack' +pushCallFrame' nm rng stk@( _ Seq.:|> (nm',rng')) | nm == nm', rng == rng' = stk -pushCallFrame nm rng stk = stk Seq.:|> (nm,rng) +pushCallFrame' nm rng stk = stk Seq.:|> (nm,rng) -- | The monad for Cryptol evaluation. @@ -328,13 +360,15 @@ Eval $ \stk -> do let stk' = f stk -- putStrLn $ unwords ["Pushing call stack", show (displayCallStack stk')] - runEval stk' m + seq stk' (runEval stk' m) +{-# INLINE modifyCallStack #-} -- | Execute the given evaluation action. runEval :: CallStack -> Eval a -> IO a runEval _ (Ready a) = return a runEval stk (Eval x) = x stk runEval _ (Thunk tv) = unDelay tv +{-# INLINE runEval #-} {-# INLINE evalBind #-} evalBind :: Eval a -> (a -> Eval b) -> Eval b @@ -415,11 +449,12 @@ deriving Typeable instance PP EvalErrorEx where - ppPrec _ (EvalErrorEx stk ex) = vcat ([ pp ex ] ++ callStk) + ppPrec _ (EvalErrorEx stk0 ex) = vcat ([ pp ex ] ++ callStk) where + stk = evalCallStack stk0 callStk | Seq.null stk = [] - | otherwise = [ text "-- Backtrace --", displayCallStack stk ] + | otherwise = [ text "-- Backtrace --", displayCallStack' stk ] instance Show EvalErrorEx where show = show . pp diff --git a/src/Cryptol/Backend/SBV.hs b/src/Cryptol/Backend/SBV.hs --- a/src/Cryptol/Backend/SBV.hs +++ b/src/Cryptol/Backend/SBV.hs @@ -48,7 +48,7 @@ import Cryptol.Backend.Monad ( Eval(..), blackhole, delayFill, evalSpark , EvalError(..), EvalErrorEx(..), Unsupported(..) - , modifyCallStack, getCallStack + , modifyCallStack, getCallStack, maybeReady ) import Cryptol.Utils.Panic (panic) @@ -162,8 +162,10 @@ | Just False <- svAsBool cond = raiseError sym err | otherwise = SBVEval (pure (SBVResult cond ())) - isReady _ (SBVEval (Ready _)) = True - isReady _ _ = False + isReady _ (SBVEval m) = SBVEval $ + maybeReady m >>= \case + Just x -> pure (Just <$> x) + Nothing -> pure (pure Nothing) sDelayFill _ m retry msg = SBVEval $ do m' <- delayFill (sbvEval m) (sbvEval <$> retry) msg @@ -262,6 +264,12 @@ wordMult _ a b = pure $! svTimes a b wordNegate _ a = pure $! svUNeg a + wordShiftLeft _ a b = pure $! shl a b + wordShiftRight _ a b = pure $! lshr a b + wordRotateLeft _ a b = pure $! SBV.svRotateLeft a b + wordRotateRight _ a b = pure $! SBV.svRotateRight a b + wordSignedShiftRight _ a b = pure $! ashr a b + wordDiv sym a b = do let z = literalSWord (intSizeOf b) 0 assertSideCondition sym (svNot (svEqual b z)) DivideByZero @@ -285,6 +293,7 @@ wordLg2 _ a = sLg2 a wordToInt _ x = pure $! svToInteger x + wordToSignedInt _ x = pure $! svToInteger (svSign x) wordFromInt _ w i = pure $! svFromInteger w i intEq _ a b = pure $! svEqual a b diff --git a/src/Cryptol/Backend/SeqMap.hs b/src/Cryptol/Backend/SeqMap.hs new file mode 100644 --- /dev/null +++ b/src/Cryptol/Backend/SeqMap.hs @@ -0,0 +1,301 @@ +-- | +-- Module : Cryptol.Backend.SeqMap +-- Copyright : (c) 2013-2021 Galois, Inc. +-- License : BSD3 +-- Maintainer : cryptol@galois.com +-- Stability : provisional +-- Portability : portable + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DoAndIfThenElse #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +module Cryptol.Backend.SeqMap + ( -- * Sequence Maps + SeqMap + , indexSeqMap + , lookupSeqMap + , finiteSeqMap + , infiniteSeqMap + , enumerateSeqMap + , streamSeqMap + , reverseSeqMap + , updateSeqMap + , dropSeqMap + , concatSeqMap + , splitSeqMap + , memoMap + , delaySeqMap + , zipSeqMap + , mapSeqMap + , mergeSeqMap + , barrelShifter + , shiftSeqByInteger + + , IndexSegment(..) + ) where + +import qualified Control.Exception as X +import Control.Monad +import Control.Monad.IO.Class +import Data.Bits +import Data.List +import Data.IORef +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map + +import Cryptol.Backend +import Cryptol.Backend.Concrete (Concrete) +import Cryptol.Backend.Monad (Unsupported(..)) + +import Cryptol.TypeCheck.Solver.InfNat(Nat'(..)) +import Cryptol.Utils.Panic + +-- | A sequence map represents a mapping from nonnegative integer indices +-- to values. These are used to represent both finite and infinite sequences. +data SeqMap sym a + = IndexSeqMap !(Integer -> SEval sym a) + | UpdateSeqMap !(Map Integer (SEval sym a)) + !(SeqMap sym a) + | MemoSeqMap + !Nat' + !(IORef (Map Integer a)) + !(IORef (Integer -> SEval sym a)) + +indexSeqMap :: (Integer -> SEval sym a) -> SeqMap sym a +indexSeqMap = IndexSeqMap + +lookupSeqMap :: Backend sym => SeqMap sym a -> Integer -> SEval sym a +lookupSeqMap (IndexSeqMap f) i = f i +lookupSeqMap (UpdateSeqMap m xs) i = + case Map.lookup i m of + Just x -> x + Nothing -> lookupSeqMap xs i +lookupSeqMap (MemoSeqMap sz cache eval) i = + do mz <- liftIO (Map.lookup i <$> readIORef cache) + case mz of + Just z -> return z + Nothing -> + do f <- liftIO (readIORef eval) + v <- f i + msz <- liftIO $ atomicModifyIORef' cache (\m -> + let m' = Map.insert i v m in (m', Map.size m')) + -- If we memoize the entire map, overwrite the evaluation closure to let + -- the garbage collector reap it + when (case sz of Inf -> False; Nat sz' -> toInteger msz >= sz') + (liftIO (writeIORef eval + (\j -> panic "lookupSeqMap" ["Messed up size accounting", show sz, show j]))) + return v + +instance Backend sym => Functor (SeqMap sym) where + fmap f xs = IndexSeqMap (\i -> f <$> lookupSeqMap xs i) + +-- | Generate a finite sequence map from a list of values +finiteSeqMap :: Backend sym => sym -> [SEval sym a] -> SeqMap sym a +finiteSeqMap sym xs = + UpdateSeqMap + (Map.fromList (zip [0..] xs)) + (IndexSeqMap (\i -> invalidIndex sym i)) + +-- | Generate an infinite sequence map from a stream of values +infiniteSeqMap :: Backend sym => sym -> [SEval sym a] -> SEval sym (SeqMap sym a) +infiniteSeqMap sym xs = + -- TODO: use an int-trie? + memoMap sym Inf (IndexSeqMap $ \i -> genericIndex xs i) + +-- | Create a finite list of length @n@ of the values from @[0..n-1]@ in +-- the given the sequence emap. +enumerateSeqMap :: (Backend sym, Integral n) => n -> SeqMap sym a -> [SEval sym a] +enumerateSeqMap n m = [ lookupSeqMap m i | i <- [0 .. (toInteger n)-1] ] + +-- | Create an infinite stream of all the values in a sequence map +streamSeqMap :: Backend sym => SeqMap sym a -> [SEval sym a] +streamSeqMap m = [ lookupSeqMap m i | i <- [0..] ] + +-- | Reverse the order of a finite sequence map +reverseSeqMap :: Backend sym => + Integer {- ^ Size of the sequence map -} -> + SeqMap sym a -> + SeqMap sym a +reverseSeqMap n vals = IndexSeqMap $ \i -> lookupSeqMap vals (n - 1 - i) + +updateSeqMap :: SeqMap sym a -> Integer -> SEval sym a -> SeqMap sym a +updateSeqMap (UpdateSeqMap m sm) i x = UpdateSeqMap (Map.insert i x m) sm +updateSeqMap xs i x = UpdateSeqMap (Map.singleton i x) xs + +-- | Concatenate the first @n@ values of the first sequence map onto the +-- beginning of the second sequence map. +concatSeqMap :: Backend sym => Integer -> SeqMap sym a -> SeqMap sym a -> SeqMap sym a +concatSeqMap n x y = + IndexSeqMap $ \i -> + if i < n + then lookupSeqMap x i + else lookupSeqMap y (i-n) + +-- | Given a number @n@ and a sequence map, return two new sequence maps: +-- the first containing the values from @[0..n-1]@ and the next containing +-- the values from @n@ onward. +splitSeqMap :: Backend sym => Integer -> SeqMap sym a -> (SeqMap sym a, SeqMap sym a) +splitSeqMap n xs = (hd,tl) + where + hd = xs + tl = IndexSeqMap $ \i -> lookupSeqMap xs (i+n) + +-- | Drop the first @n@ elements of the given 'SeqMap'. +dropSeqMap :: Backend sym => Integer -> SeqMap sym a -> SeqMap sym a +dropSeqMap 0 xs = xs +dropSeqMap n xs = IndexSeqMap $ \i -> lookupSeqMap xs (i+n) + +delaySeqMap :: Backend sym => sym -> SEval sym (SeqMap sym a) -> SEval sym (SeqMap sym a) +delaySeqMap sym xs = + do xs' <- sDelay sym xs + pure $ IndexSeqMap $ \i -> do m <- xs'; lookupSeqMap m i + +-- | Given a sequence map, return a new sequence map that is memoized using +-- a finite map memo table. +memoMap :: Backend sym => sym -> Nat' -> SeqMap sym a -> SEval sym (SeqMap sym a) + +-- Sequence is alreay memoized, just return it +memoMap _sym _sz x@(MemoSeqMap{}) = pure x + +memoMap sym sz x = do + stk <- sGetCallStack sym + cache <- liftIO $ newIORef $ Map.empty + evalRef <- liftIO $ newIORef $ eval stk + return (MemoSeqMap sz cache evalRef) + + where + eval stk i = sWithCallStack sym stk (lookupSeqMap x i) + + +-- | Apply the given evaluation function pointwise to the two given +-- sequence maps. +zipSeqMap :: + Backend sym => + sym -> + (a -> a -> SEval sym a) -> + Nat' -> + SeqMap sym a -> + SeqMap sym a -> + SEval sym (SeqMap sym a) +zipSeqMap sym f sz x y = + memoMap sym sz (IndexSeqMap $ \i -> join (f <$> lookupSeqMap x i <*> lookupSeqMap y i)) + +-- | Apply the given function to each value in the given sequence map +mapSeqMap :: + Backend sym => + sym -> + (a -> SEval sym a) -> + Nat' -> + SeqMap sym a -> + SEval sym (SeqMap sym a) +mapSeqMap sym f sz x = + memoMap sym sz (IndexSeqMap $ \i -> f =<< lookupSeqMap x i) + + +{-# INLINE mergeSeqMap #-} +mergeSeqMap :: Backend sym => + sym -> + (SBit sym -> a -> a -> SEval sym a) -> + SBit sym -> + SeqMap sym a -> + SeqMap sym a -> + SeqMap sym a +mergeSeqMap sym f c x y = + IndexSeqMap $ \i -> mergeEval sym f c (lookupSeqMap x i) (lookupSeqMap y i) + + +{-# INLINE shiftSeqByInteger #-} +shiftSeqByInteger :: Backend sym => + sym -> + (SBit sym -> a -> a -> SEval sym a) + {- ^ if/then/else operation of values -} -> + (Integer -> Integer -> Maybe Integer) + {- ^ reindexing operation -} -> + SEval sym a {- ^ zero value -} -> + Nat' {- ^ size of the sequence -} -> + SeqMap sym a {- ^ sequence to shift -} -> + SInteger sym {- ^ shift amount, assumed to be in range [0,len] -} -> + SEval sym (SeqMap sym a) +shiftSeqByInteger sym merge reindex zro m xs idx + | Just j <- integerAsLit sym idx = shiftOp xs j + | otherwise = + do (n, idx_bits) <- enumerateIntBits sym m idx + barrelShifter sym merge shiftOp m xs n (map BitIndexSegment idx_bits) + where + shiftOp vs shft = + pure $ indexSeqMap $ \i -> + case reindex i shft of + Nothing -> zro + Just i' -> lookupSeqMap vs i' + + +data IndexSegment sym + = BitIndexSegment (SBit sym) + | WordIndexSegment (SWord sym) + +{-# SPECIALIZE + barrelShifter :: + Concrete -> + (SBit Concrete -> a -> a -> SEval Concrete a) -> + (SeqMap Concrete a -> Integer -> SEval Concrete (SeqMap Concrete a)) -> + Nat' -> + SeqMap Concrete a -> + Integer -> + [IndexSegment Concrete] -> + SEval Concrete (SeqMap Concrete a) + #-} +barrelShifter :: Backend sym => + sym -> + (SBit sym -> a -> a -> SEval sym a) + {- ^ if/then/else operation of values -} -> + (SeqMap sym a -> Integer -> SEval sym (SeqMap sym a)) + {- ^ concrete shifting operation -} -> + Nat' {- ^ Size of the map being shifted -} -> + SeqMap sym a {- ^ initial value -} -> + Integer {- Number of bits in shift amount -} -> + [IndexSegment sym] {- ^ segments of the shift amount, in big-endian order -} -> + SEval sym (SeqMap sym a) +barrelShifter sym mux shift_op sz x0 n0 bs0 + | n0 >= toInteger (maxBound :: Int) = + liftIO (X.throw (UnsupportedSymbolicOp ("Barrel shifter with too many bits in shift amount: " ++ show n0))) + | otherwise = go x0 (fromInteger n0) bs0 + + where + go x !_n [] = return x + + go x !n (WordIndexSegment w:bs) = + let n' = n - fromInteger (wordLen sym w) in + case wordAsLit sym w of + Just (_,0) -> go x n' bs + Just (_,j) -> + do x_shft <- shift_op x (j * bit n') + go x_shft n' bs + Nothing -> + do wbs <- unpackWord sym w + go x n (map BitIndexSegment wbs ++ bs) + + go x !n (BitIndexSegment b:bs) = + let n' = n - 1 in + case bitAsLit sym b of + Just False -> go x n' bs + Just True -> + do x_shft <- shift_op x (bit n') + go x_shft n' bs + Nothing -> + do x_shft <- shift_op x (bit n') + x' <- memoMap sym sz (mergeSeqMap sym mux b x_shft x) + go x' n' bs diff --git a/src/Cryptol/Backend/What4.hs b/src/Cryptol/Backend/What4.hs --- a/src/Cryptol/Backend/What4.hs +++ b/src/Cryptol/Backend/What4.hs @@ -39,7 +39,7 @@ import Cryptol.Backend.Monad ( Eval(..), EvalError(..), EvalErrorEx(..) , Unsupported(..), delayFill, blackhole, evalSpark - , modifyCallStack, getCallStack + , modifyCallStack, getCallStack, maybeReady ) import Cryptol.Utils.Panic @@ -76,7 +76,7 @@ | W4Result !(W4.Pred sym) !a -- ^ safety predicate and result: the result only makes sense when -- the predicate holds. - + deriving Functor -------------------------------------------------------------------------------- -- Moving between the layers @@ -215,10 +215,10 @@ | Just False <- W4.asConstantPred cond = evalError err | otherwise = addSafety cond - isReady sym m = - case w4Eval m (w4 sym) of - Ready _ -> True - _ -> False + isReady sym m = W4Eval $ W4Conn $ \_ -> + maybeReady (w4Eval m (w4 sym)) >>= \case + Just x -> pure (Just <$> x) + Nothing -> pure (W4Result (W4.backendPred (w4 sym) True) Nothing) sDelayFill _ m retry msg = total @@ -342,6 +342,12 @@ wordNegate sym x = liftIO (SW.bvNeg (w4 sym) x) wordLg2 sym x = sLg2 (w4 sym) x + wordShiftLeft sym x y = w4bvShl (w4 sym) x y + wordShiftRight sym x y = w4bvLshr (w4 sym) x y + wordRotateLeft sym x y = w4bvRol (w4 sym) x y + wordRotateRight sym x y = w4bvRor (w4 sym) x y + wordSignedShiftRight sym x y = w4bvAshr (w4 sym) x y + wordDiv sym x y = do assertBVDivisor sym y liftIO (SW.bvUDiv (w4 sym) x y) @@ -356,6 +362,7 @@ liftIO (SW.bvSRem (w4 sym) x y) wordToInt sym x = liftIO (SW.bvToInteger (w4 sym) x) + wordToSignedInt sym x = liftIO (SW.sbvToInteger (w4 sym) x) wordFromInt sym width i = liftIO (SW.integerToBV (w4 sym) i width) intPlus sym x y = liftIO $ W4.intAdd (w4 sym) x y diff --git a/src/Cryptol/Backend/WordValue.hs b/src/Cryptol/Backend/WordValue.hs new file mode 100644 --- /dev/null +++ b/src/Cryptol/Backend/WordValue.hs @@ -0,0 +1,759 @@ +-- | +-- Module : Cryptol.Backend.WordValue +-- Copyright : (c) 2013-2021 Galois, Inc. +-- License : BSD3 +-- Maintainer : cryptol@galois.com +-- Stability : provisional +-- Portability : portable + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DoAndIfThenElse #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +module Cryptol.Backend.WordValue + ( -- * WordValue + WordValue + , wordVal + , bitmapWordVal + , asWordList + , asWordVal + , asBitsMap + , joinWordVal + , takeWordVal + , dropWordVal + , extractWordVal + , wordValLogicOp + , wordValUnaryOp + , assertWordValueInBounds + , enumerateWordValue + , enumerateWordValueRev + , enumerateIndexSegments + , wordValueSize + , indexWordValue + , updateWordValue + , delayWordValue + , joinWords + , shiftSeqByWord + , shiftWordByInteger + , shiftWordByWord + , wordValAsLit + , reverseWordVal + , forceWordValue + , wordValueEqualsInteger + , updateWordByWord + + , mergeWord + , mergeWord' + ) where + +import Control.Monad (unless) +import Data.Bits +import GHC.Generics (Generic) + +import Cryptol.Backend +import Cryptol.Backend.Concrete (Concrete(..)) +import Cryptol.Backend.Monad (EvalError(..)) +import Cryptol.Backend.SeqMap + +import Cryptol.TypeCheck.Solver.InfNat(widthInteger, Nat'(..)) + +-- | Force the evaluation of a word value +forceWordValue :: Backend sym => WordValue sym -> SEval sym () +forceWordValue (WordVal w) = seq w (return ()) +forceWordValue (ThunkWordVal _ m) = forceWordValue =<< m +forceWordValue (BitmapVal _n packed _) = do w <- packed; seq w (return ()) + +-- | An arbitrarily-chosen number of elements where we switch from a dense +-- sequence representation of bit-level words to 'SeqMap' representation. +largeBitSize :: Integer +largeBitSize = bit 32 + +-- | For efficiency reasons, we handle finite sequences of bits as special cases +-- in the evaluator. In cases where we know it is safe to do so, we prefer to +-- used a "packed word" representation of bit sequences. This allows us to rely +-- directly on Integer types (in the concrete evaluator) and SBV's Word types (in +-- the symbolic simulator). +-- +-- However, if we cannot be sure all the bits of the sequence +-- will eventually be forced, we must instead rely on an explicit sequence of bits +-- representation. +data WordValue sym + = ThunkWordVal Integer !(SEval sym (WordValue sym)) + | WordVal !(SWord sym) -- ^ Packed word representation for bit sequences. + | BitmapVal + !Integer -- ^ Length of the word + !(SEval sym (SWord sym)) -- ^ Thunk for packing the word + !(SeqMap sym (SBit sym)) -- ^ + deriving (Generic) + +wordVal :: SWord sym -> WordValue sym +wordVal = WordVal + +packBitmap :: Backend sym => sym -> Integer -> SeqMap sym (SBit sym) -> SEval sym (SWord sym) +packBitmap sym sz bs = packWord sym =<< sequence (enumerateSeqMap sz bs) + +unpackBitmap :: Backend sym => sym -> SWord sym -> SeqMap sym (SBit sym) +unpackBitmap sym w = indexSeqMap $ \i -> wordBit sym w i + +bitmapWordVal :: Backend sym => sym -> Integer -> SeqMap sym (SBit sym) -> SEval sym (WordValue sym) +bitmapWordVal sym sz bs = + do packed <- sDelay sym (packBitmap sym sz bs) + pure (BitmapVal sz packed bs) + +{-# INLINE joinWordVal #-} +joinWordVal :: Backend sym => sym -> WordValue sym -> WordValue sym -> SEval sym (WordValue sym) +joinWordVal sym wv1 wv2 = + let fallback = fallbackWordJoin sym wv1 wv2 in + case (wv1, wv2) of + (WordVal w1, WordVal w2) -> + WordVal <$> joinWord sym w1 w2 + + (ThunkWordVal _ m1, _) -> + isReady sym m1 >>= \case + Just x -> joinWordVal sym x wv2 + Nothing -> fallback + + (_,ThunkWordVal _ m2) -> + isReady sym m2 >>= \case + Just x -> joinWordVal sym wv1 x + Nothing -> fallback + + (WordVal w1, BitmapVal _ packed2 _) -> + isReady sym packed2 >>= \case + Just w2 -> WordVal <$> joinWord sym w1 w2 + Nothing -> fallback + + (BitmapVal _ packed1 _, WordVal w2) -> + isReady sym packed1 >>= \case + Just w1 -> WordVal <$> joinWord sym w1 w2 + Nothing -> fallback + + (BitmapVal _ packed1 _, BitmapVal _ packed2 _) -> + do r1 <- isReady sym packed1 + r2 <- isReady sym packed2 + case (r1,r2) of + (Just w1, Just w2) -> WordVal <$> joinWord sym w1 w2 + _ -> fallback + +{-# INLINE fallbackWordJoin #-} +fallbackWordJoin :: Backend sym => sym -> WordValue sym -> WordValue sym -> SEval sym (WordValue sym) +fallbackWordJoin sym w1 w2 = + do let n1 = wordValueSize sym w1 + let n2 = wordValueSize sym w2 + let len = n1 + n2 + packed <- sDelay sym + (do a <- asWordVal sym w1 + b <- asWordVal sym w2 + joinWord sym a b) + let bs = concatSeqMap n1 (asBitsMap sym w1) (asBitsMap sym w2) + pure (BitmapVal len packed bs) + + +{-# INLINE takeWordVal #-} +takeWordVal :: + Backend sym => + sym -> + Integer -> + Integer -> + WordValue sym -> + SEval sym (WordValue sym) +takeWordVal sym leftWidth rigthWidth (WordVal w) = + do (lw, _rw) <- splitWord sym leftWidth rigthWidth w + pure (WordVal lw) + +takeWordVal sym leftWidth rightWidth (ThunkWordVal _ m) = + isReady sym m >>= \case + Just w -> takeWordVal sym leftWidth rightWidth w + Nothing -> + do m' <- sDelay sym (takeWordVal sym leftWidth rightWidth =<< m) + return (ThunkWordVal leftWidth m') + +takeWordVal sym leftWidth rightWidth (BitmapVal _n packed xs) = + isReady sym packed >>= \case + Just w -> do (lw, _rw) <- splitWord sym leftWidth rightWidth w + pure (WordVal lw) + Nothing -> bitmapWordVal sym leftWidth xs + +{-# INLINE dropWordVal #-} +dropWordVal :: + Backend sym => + sym -> + Integer -> + Integer -> + WordValue sym -> + SEval sym (WordValue sym) +dropWordVal sym leftWidth rigthWidth (WordVal w) = + do (_lw, rw) <- splitWord sym leftWidth rigthWidth w + pure (WordVal rw) + +dropWordVal sym leftWidth rightWidth (ThunkWordVal _ m) = + isReady sym m >>= \case + Just w -> dropWordVal sym leftWidth rightWidth w + Nothing -> + do m' <- sDelay sym (dropWordVal sym leftWidth rightWidth =<< m) + return (ThunkWordVal rightWidth m') + +dropWordVal sym leftWidth rightWidth (BitmapVal _n packed xs) = + isReady sym packed >>= \case + Just w -> do (_lw, rw) <- splitWord sym leftWidth rightWidth w + pure (WordVal rw) + Nothing -> + do let rxs = dropSeqMap leftWidth xs + bitmapWordVal sym rightWidth rxs + +{-# INLINE extractWordVal #-} + +-- | Extract a subsequence of bits from a @WordValue@. +-- The first integer argument is the number of bits in the +-- resulting word. The second integer argument is the +-- number of less-significant digits to discard. Stated another +-- way, the operation `extractWordVal n i w` is equivalent to +-- first shifting `w` right by `i` bits, and then truncating to +-- `n` bits. +extractWordVal :: + Backend sym => + sym -> + Integer -> + Integer -> + WordValue sym -> + SEval sym (WordValue sym) +extractWordVal sym len start (WordVal w) = + WordVal <$> extractWord sym len start w +extractWordVal sym len start (ThunkWordVal _n m) = + isReady sym m >>= \case + Just w -> extractWordVal sym len start w + Nothing -> + do m' <- sDelay sym (extractWordVal sym len start =<< m) + pure (ThunkWordVal len m') +extractWordVal sym len start (BitmapVal n packed xs) = + isReady sym packed >>= \case + Just w -> WordVal <$> extractWord sym len start w + Nothing -> + do let xs' = dropSeqMap (n - start - len) xs + bitmapWordVal sym len xs' + +{-# INLINE wordValLogicOp #-} + +wordValLogicOp :: + Backend sym => + sym -> + (SBit sym -> SBit sym -> SEval sym (SBit sym)) -> + (SWord sym -> SWord sym -> SEval sym (SWord sym)) -> + WordValue sym -> + WordValue sym -> + SEval sym (WordValue sym) +wordValLogicOp _sym _ wop (WordVal w1) (WordVal w2) = WordVal <$> wop w1 w2 + +wordValLogicOp sym bop wop (WordVal w1) (BitmapVal n2 packed2 bs2) = + isReady sym packed2 >>= \case + Just w2 -> WordVal <$> wop w1 w2 + Nothing -> bitmapWordVal sym n2 =<< zipSeqMap sym bop (Nat n2) (unpackBitmap sym w1) bs2 + +wordValLogicOp sym bop wop (BitmapVal n1 packed1 bs1) (WordVal w2) = + isReady sym packed1 >>= \case + Just w1 -> WordVal <$> wop w1 w2 + Nothing -> bitmapWordVal sym n1 =<< zipSeqMap sym bop (Nat n1) bs1 (unpackBitmap sym w2) + +wordValLogicOp sym bop wop (BitmapVal n1 packed1 bs1) (BitmapVal _n2 packed2 bs2) = + do r1 <- isReady sym packed1 + r2 <- isReady sym packed2 + case (r1,r2) of + (Just w1, Just w2) -> WordVal <$> wop w1 w2 + _ -> bitmapWordVal sym n1 =<< zipSeqMap sym bop (Nat n1) bs1 bs2 + +wordValLogicOp sym bop wop (ThunkWordVal _ m1) w2 = + do w1 <- m1 + wordValLogicOp sym bop wop w1 w2 + +wordValLogicOp sym bop wop w1 (ThunkWordVal _ m2) = + do w2 <- m2 + wordValLogicOp sym bop wop w1 w2 + +{-# INLINE wordValUnaryOp #-} +wordValUnaryOp :: + Backend sym => + sym -> + (SBit sym -> SEval sym (SBit sym)) -> + (SWord sym -> SEval sym (SWord sym)) -> + WordValue sym -> + SEval sym (WordValue sym) +wordValUnaryOp _ _ wop (WordVal w) = WordVal <$> wop w +wordValUnaryOp sym bop wop (ThunkWordVal _ m) = wordValUnaryOp sym bop wop =<< m +wordValUnaryOp sym bop wop (BitmapVal n packed xs) = + isReady sym packed >>= \case + Just w -> WordVal <$> wop w + Nothing -> bitmapWordVal sym n =<< mapSeqMap sym bop (Nat n) xs + +{-# SPECIALIZE joinWords :: + Concrete -> + Integer -> + Integer -> + SeqMap Concrete (WordValue Concrete)-> + SEval Concrete (WordValue Concrete) + #-} +joinWords :: forall sym. + Backend sym => + sym -> + Integer -> + Integer -> + SeqMap sym (WordValue sym) -> + SEval sym (WordValue sym) + +-- small enough to pack +joinWords sym nParts nEach xs | nParts * nEach < largeBitSize = + do z <- wordLit sym 0 0 + loop (wordVal z) (enumerateSeqMap nParts xs) + + where + loop :: WordValue sym -> [SEval sym (WordValue sym)] -> SEval sym (WordValue sym) + loop !wv [] = pure wv + loop !wv (w : ws) = + do w' <- delayWordValue sym nEach w + wv' <- joinWordVal sym wv w' + loop wv' ws + +-- too large to pack +joinWords sym nParts nEach xs = bitmapWordVal sym (nParts * nEach) zs + where + zs = indexSeqMap $ \i -> + do let (q,r) = divMod i nEach + ys <- lookupSeqMap xs q + indexWordValue sym ys r + +reverseWordVal :: Backend sym => sym -> WordValue sym -> SEval sym (WordValue sym) +reverseWordVal sym w = + let m = wordValueSize sym w in + bitmapWordVal sym m <$> reverseSeqMap m $ asBitsMap sym w + +wordValAsLit :: Backend sym => sym -> WordValue sym -> SEval sym (Maybe Integer) +wordValAsLit sym (WordVal w) = pure (snd <$> wordAsLit sym w) +wordValAsLit sym (ThunkWordVal _ m) = + isReady sym m >>= \case + Just v -> wordValAsLit sym v + Nothing -> pure Nothing +wordValAsLit sym (BitmapVal _ packed _) = + isReady sym packed >>= \case + Just w -> pure (snd <$> wordAsLit sym w) + Nothing -> pure Nothing + +-- | Force a word value into packed word form +asWordVal :: Backend sym => sym -> WordValue sym -> SEval sym (SWord sym) +asWordVal _ (WordVal w) = return w +asWordVal sym (ThunkWordVal _ m) = asWordVal sym =<< m +asWordVal _ (BitmapVal _ packed _) = packed + +wordValueEqualsInteger :: forall sym. Backend sym => + sym -> + WordValue sym -> + Integer -> + SEval sym (SBit sym) +wordValueEqualsInteger sym wv i + | wordValueSize sym wv < widthInteger i = return (bitLit sym False) + | otherwise = loop wv + + where + loop (ThunkWordVal _ m) = loop =<< m + loop (WordVal w) = wordEq sym w =<< wordLit sym (wordLen sym w) i + loop (BitmapVal n packed bs) = + isReady sym packed >>= \case + Just w -> loop (WordVal w) + Nothing -> bitsAre i =<< sequence (enumerateSeqMap n (reverseSeqMap n bs)) + + -- NB little-endian sequence of bits + bitsAre :: Integer -> [SBit sym] -> SEval sym (SBit sym) + bitsAre !n [] = return (bitLit sym (n == 0)) + bitsAre !n (b:bs) = + do pb <- bitIs (testBit n 0) b + pbs <- bitsAre (n `shiftR` 1) bs + bitAnd sym pb pbs + + bitIs :: Bool -> SBit sym -> SEval sym (SBit sym) + bitIs b x = if b then pure x else bitComplement sym x + +asWordList :: forall sym. Backend sym => sym -> [WordValue sym] -> SEval sym (Maybe [SWord sym]) +asWordList sym = loop id + where + loop :: ([SWord sym] -> [SWord sym]) -> [WordValue sym] -> SEval sym (Maybe [SWord sym]) + loop f [] = pure (Just (f [])) + loop f (WordVal x : vs) = loop (f . (x:)) vs + loop f (ThunkWordVal _ m : vs) = + isReady sym m >>= \case + Just m' -> loop f (m' : vs) + Nothing -> pure Nothing + loop f (BitmapVal _ packed _ : vs) = + isReady sym packed >>= \case + Just x -> loop (f . (x:)) vs + Nothing -> pure Nothing + +-- | Force a word value into a sequence of bits +asBitsMap :: Backend sym => sym -> WordValue sym -> SeqMap sym (SBit sym) +asBitsMap _ (BitmapVal _ _ xs) = xs +asBitsMap sym (WordVal w) = indexSeqMap $ \i -> wordBit sym w i +asBitsMap sym (ThunkWordVal _ m) = + indexSeqMap $ \i -> + do mp <- asBitsMap sym <$> (unwindThunks m) + lookupSeqMap mp i + +-- | Turn a word value into a sequence of bits, forcing each bit. +-- The sequence is returned in big-endian order. +enumerateWordValue :: Backend sym => sym -> WordValue sym -> SEval sym [SBit sym] +enumerateWordValue sym (WordVal w) = unpackWord sym w +enumerateWordValue sym (ThunkWordVal _ m) = enumerateWordValue sym =<< m + -- TODO? used the packed value if it is ready? +enumerateWordValue _ (BitmapVal n _ xs) = sequence (enumerateSeqMap n xs) + +-- | Turn a word value into a sequence of bits, forcing each bit. +-- The sequence is returned in reverse of the usual order, which is little-endian order. +enumerateWordValueRev :: Backend sym => sym -> WordValue sym -> SEval sym [SBit sym] +enumerateWordValueRev sym (WordVal w) = reverse <$> unpackWord sym w +enumerateWordValueRev sym (ThunkWordVal _ m) = enumerateWordValueRev sym =<< m + -- TODO? used the packed value if it is ready? +enumerateWordValueRev _ (BitmapVal n _ xs) = sequence (enumerateSeqMap n (reverseSeqMap n xs)) + + +enumerateIndexSegments :: Backend sym => sym -> WordValue sym -> SEval sym [IndexSegment sym] +enumerateIndexSegments _sym (WordVal w) = pure [WordIndexSegment w] +enumerateIndexSegments sym (ThunkWordVal _ m) = enumerateIndexSegments sym =<< m +enumerateIndexSegments sym (BitmapVal n packed xs) = + isReady sym packed >>= \case + Just w -> pure [WordIndexSegment w] + Nothing -> traverse (BitIndexSegment <$>) (enumerateSeqMap n xs) + +{-# SPECIALIZE bitsValueLessThan :: + Concrete -> + Integer -> + [SBit Concrete] -> + Integer -> + SEval Concrete (SBit Concrete) + #-} +bitsValueLessThan :: + Backend sym => + sym -> + Integer {- ^ bit-width -} -> + [SBit sym] {- ^ big-endian list of index bits -} -> + Integer {- ^ Upper bound to test against -} -> + SEval sym (SBit sym) +bitsValueLessThan sym _w [] _n = pure $ bitLit sym False +bitsValueLessThan sym w (b:bs) n + | nbit = + do notb <- bitComplement sym b + bitOr sym notb =<< bitsValueLessThan sym (w-1) bs n + | otherwise = + do notb <- bitComplement sym b + bitAnd sym notb =<< bitsValueLessThan sym (w-1) bs n + where + nbit = testBit n (fromInteger (w-1)) + + +assertWordValueInBounds :: + Backend sym => sym -> Integer -> WordValue sym -> SEval sym () + +-- Can't index out of bounds for a sequence that is +-- longer than the expressible index values +assertWordValueInBounds sym n idx + | n >= 2^(wordValueSize sym idx) + = return () + +assertWordValueInBounds sym n (WordVal idx) + | Just (_w,i) <- wordAsLit sym idx + = unless (i < n) (raiseError sym (InvalidIndex (Just i))) + +-- If the index is a packed word, test that it +-- is less than the concrete value of n, which +-- fits into w bits because of the above test. +assertWordValueInBounds sym n (WordVal idx) = + do n' <- wordLit sym (wordLen sym idx) n + p <- wordLessThan sym idx n' + assertSideCondition sym p (InvalidIndex Nothing) + +-- Force thunks +assertWordValueInBounds sym n (ThunkWordVal _ m) = + assertWordValueInBounds sym n =<< m + +-- If the index is an unpacked word, force all the bits +-- and compute the unsigned less-than test directly. +assertWordValueInBounds sym n (BitmapVal sz packed bits) = + isReady sym packed >>= \case + Just w -> assertWordValueInBounds sym n (WordVal w) + Nothing -> + do bitsList <- sequence (enumerateSeqMap sz bits) + p <- bitsValueLessThan sym sz bitsList n + assertSideCondition sym p (InvalidIndex Nothing) + +delayWordValue :: Backend sym => sym -> Integer -> SEval sym (WordValue sym) -> SEval sym (WordValue sym) +delayWordValue sym sz m = + isReady sym m >>= \case + Just w -> pure w + Nothing -> ThunkWordVal sz <$> sDelay sym (unwindThunks m) + +-- If we are calling this, we know the spine of the word value has been +-- demanded, so we unwind any chains of `ThunkWordValue` that may have built up. +unwindThunks :: Backend sym => SEval sym (WordValue sym) -> SEval sym (WordValue sym) +unwindThunks m = + m >>= \case + ThunkWordVal _ m' -> unwindThunks m' + x -> pure x + +{-# INLINE shiftWordByInteger #-} +shiftWordByInteger :: + Backend sym => + sym -> + (SWord sym -> SWord sym -> SEval sym (SWord sym)) + {- ^ operation on word values -} -> + (Integer -> Integer -> Maybe Integer) + {- ^ reindexing operation -} -> + WordValue sym {- ^ word value to shift -} -> + SInteger sym {- ^ shift amount, assumed to be in range [0,len] -} -> + SEval sym (WordValue sym) + +shiftWordByInteger sym wop reindex x idx = + case x of + ThunkWordVal w wm -> + isReady sym wm >>= \case + Just x' -> shiftWordByInteger sym wop reindex x' idx + Nothing -> + do m' <- sDelay sym + (do x' <- wm + shiftWordByInteger sym wop reindex x' idx) + return (ThunkWordVal w m') + + WordVal x' -> WordVal <$> (wop x' =<< wordFromInt sym (wordLen sym x') idx) + + BitmapVal n packed bs0 -> + isReady sym packed >>= \case + Just w -> shiftWordByInteger sym wop reindex (WordVal w) idx + Nothing -> + bitmapWordVal sym n =<< + shiftSeqByInteger sym (iteBit sym) reindex (pure (bitLit sym False)) (Nat n) bs0 idx + + +{-# INLINE shiftWordByWord #-} +shiftWordByWord :: + Backend sym => + sym -> + (SWord sym -> SWord sym -> SEval sym (SWord sym)) + {- ^ operation on word values -} -> + (Integer -> Integer -> Maybe Integer) + {- ^ reindexing operation -} -> + WordValue sym {- ^ value to shift -} -> + WordValue sym {- ^ amount to shift -} -> + SEval sym (WordValue sym) +shiftWordByWord sym wop reindex x idx = + case x of + ThunkWordVal w wm -> + isReady sym wm >>= \case + Just wm' -> shiftWordByWord sym wop reindex wm' idx + Nothing -> + do m' <- sDelay sym (do wm' <- wm + shiftWordByWord sym wop reindex wm' idx) + return (ThunkWordVal w m') + + WordVal x' -> WordVal <$> (wop x' =<< asWordVal sym idx) + + BitmapVal n packed bs0 -> + isReady sym packed >>= \case + Just w -> shiftWordByWord sym wop reindex (WordVal w) idx + Nothing -> + bitmapWordVal sym n =<< + shiftSeqByWord sym (iteBit sym) reindex (pure (bitLit sym False)) (Nat n) bs0 idx + + +{-# INLINE updateWordByWord #-} +updateWordByWord :: + Backend sym => + sym -> + IndexDirection -> + WordValue sym {- ^ value to update -} -> + WordValue sym {- ^ index to update at -} -> + SEval sym (SBit sym) {- ^ fresh bit -} -> + SEval sym (WordValue sym) +updateWordByWord sym dir w0 idx bitval = + wordValAsLit sym idx >>= \case + Just j -> + let sz = wordValueSize sym w0 in + case dir of + IndexForward -> updateWordValue sym w0 j bitval + IndexBackward -> updateWordValue sym w0 (sz - j - 1) bitval + Nothing -> loop w0 + + where + loop (ThunkWordVal sz m) = + isReady sym m >>= \case + Just w' -> loop w' + Nothing -> delayWordValue sym sz (loop =<< m) + + loop (BitmapVal sz packed bs) = + isReady sym packed >>= \case + Just w -> loop (WordVal w) + Nothing -> + case dir of + IndexForward -> + bitmapWordVal sym sz $ indexSeqMap $ \i -> + do b <- wordValueEqualsInteger sym idx i + mergeEval sym (iteBit sym) b bitval (lookupSeqMap bs i) + IndexBackward -> + bitmapWordVal sym sz $ indexSeqMap $ \i -> + do b <- wordValueEqualsInteger sym idx (sz - i - 1) + mergeEval sym (iteBit sym) b bitval (lookupSeqMap bs i) + + loop (WordVal wv) = WordVal <$> + -- TODO, this is too strict in bit + do let sz = wordLen sym wv + b <- bitval + msk <- case dir of + IndexForward -> + do highbit <- wordLit sym sz (bit (fromInteger (sz-1))) + wordShiftRight sym highbit =<< asWordVal sym idx + IndexBackward -> + do lowbit <- wordLit sym sz 1 + wordShiftLeft sym lowbit =<< asWordVal sym idx + case bitAsLit sym b of + Just True -> wordOr sym wv msk + Just False -> wordAnd sym wv =<< wordComplement sym msk + Nothing -> + do zro <- wordLit sym sz 0 + one <- wordComplement sym zro + q <- iteWord sym b one zro + w' <- wordAnd sym wv =<< wordComplement sym msk + wordXor sym w' =<< wordAnd sym msk q + + +{-# INLINE shiftSeqByWord #-} +shiftSeqByWord :: + Backend sym => + sym -> + (SBit sym -> a -> a -> SEval sym a) + {- ^ if/then/else operation of values -} -> + (Integer -> Integer -> Maybe Integer) + {- ^ reindexing operation -} -> + SEval sym a {- ^ zero value -} -> + Nat' {- ^ size of the sequence -} -> + SeqMap sym a {- ^ sequence to shift -} -> + WordValue sym {- ^ shift amount -} -> + SEval sym (SeqMap sym a) +shiftSeqByWord sym merge reindex zro sz xs idx = + wordValAsLit sym idx >>= \case + Just j -> shiftOp xs j + Nothing -> + do idx_segs <- enumerateIndexSegments sym idx + barrelShifter sym merge shiftOp sz xs idx_bits idx_segs + where + idx_bits = wordValueSize sym idx + + shiftOp vs shft = + pure $ indexSeqMap $ \i -> + case reindex i shft of + Nothing -> zro + Just i' -> lookupSeqMap vs i' + +-- | Compute the size of a word value +-- TODO, can we get rid of this? If feels like it should be +-- unnecessary. +wordValueSize :: Backend sym => sym -> WordValue sym -> Integer +wordValueSize sym (WordVal w) = wordLen sym w +wordValueSize _ (ThunkWordVal n _) = n +wordValueSize _ (BitmapVal n _ _) = n + +-- | Select an individual bit from a word value +indexWordValue :: Backend sym => sym -> WordValue sym -> Integer -> SEval sym (SBit sym) +indexWordValue sym (ThunkWordVal _ m) idx = do m' <- m ; indexWordValue sym m' idx +indexWordValue sym (WordVal w) idx + | 0 <= idx && idx < wordLen sym w = wordBit sym w idx + | otherwise = invalidIndex sym idx +indexWordValue sym (BitmapVal n _packed xs) idx + | 0 <= idx && idx < n = lookupSeqMap xs idx + | otherwise = invalidIndex sym idx + +-- | Produce a new 'WordValue' from the one given by updating the @i@th bit with the +-- given bit value. +updateWordValue :: Backend sym => + sym -> WordValue sym -> Integer -> SEval sym (SBit sym) -> SEval sym (WordValue sym) +updateWordValue sym wv0 idx b = loop wv0 + where + loop (ThunkWordVal sz m) = + isReady sym m >>= \case + Just w -> loop w + Nothing -> delayWordValue sym sz (loop =<< m) + + loop (WordVal w) + | idx < 0 || idx >= wordLen sym w = invalidIndex sym idx + | otherwise = + isReady sym b >>= \case + Just b' -> WordVal <$> wordUpdate sym w idx b' + Nothing -> + do let bs = unpackBitmap sym w + bitmapWordVal sym (wordLen sym w) $ updateSeqMap bs idx b + + loop (BitmapVal sz packed bs) + | 0 <= idx && idx < sz = + isReady sym packed >>= \case + Just w -> loop (WordVal w) + Nothing -> bitmapWordVal sym sz $ updateSeqMap bs idx b + | otherwise = invalidIndex sym idx + +{-# INLINE mergeWord #-} +mergeWord :: Backend sym => + sym -> + SBit sym -> + WordValue sym -> + WordValue sym -> + SEval sym (WordValue sym) +mergeWord sym c (ThunkWordVal _ m1) (ThunkWordVal _ m2) = + mergeWord' sym c (unwindThunks m1) (unwindThunks m2) +mergeWord sym c (ThunkWordVal _ m1) w2 = + mergeWord' sym c (unwindThunks m1) (pure w2) +mergeWord sym c w1 (ThunkWordVal _ m2) = + mergeWord' sym c (pure w1) (unwindThunks m2) + +mergeWord sym c (WordVal w1) (WordVal w2) = + WordVal <$> iteWord sym c w1 w2 + +mergeWord sym c (BitmapVal n1 packed1 bs1) (WordVal w2) = + isReady sym packed1 >>= \case + Just w1 -> WordVal <$> iteWord sym c w1 w2 + Nothing -> mergeBitmaps sym c n1 bs1 (unpackBitmap sym w2) + +mergeWord sym c (WordVal w1) (BitmapVal n2 packed2 bs2) = + isReady sym packed2 >>= \case + Just w2 -> WordVal <$> iteWord sym c w1 w2 + Nothing -> mergeBitmaps sym c n2 (unpackBitmap sym w1) bs2 + +mergeWord sym c (BitmapVal n1 packed1 bs1) (BitmapVal _n2 packed2 bs2) = + do r1 <- isReady sym packed1 + r2 <- isReady sym packed2 + case (r1,r2) of + (Just w1, Just w2) -> WordVal <$> iteWord sym c w1 w2 + _ -> mergeBitmaps sym c n1 bs1 bs2 + +mergeBitmaps :: Backend sym => + sym -> + SBit sym -> + Integer -> + SeqMap sym (SBit sym) -> + SeqMap sym (SBit sym) -> + SEval sym (WordValue sym) +mergeBitmaps sym c sz bs1 bs2 = + do bs <- memoMap sym (Nat sz) (mergeSeqMap sym (iteBit sym) c bs1 bs2) + bitmapWordVal sym sz bs + +{-# INLINE mergeWord' #-} +mergeWord' :: Backend sym => + sym -> + SBit sym -> + SEval sym (WordValue sym) -> + SEval sym (WordValue sym) -> + SEval sym (WordValue sym) +mergeWord' sym c x y + | Just b <- bitAsLit sym c = if b then x else y + | otherwise = mergeEval sym (mergeWord sym) c x y diff --git a/src/Cryptol/Eval.hs b/src/Cryptol/Eval.hs --- a/src/Cryptol/Eval.hs +++ b/src/Cryptol/Eval.hs @@ -40,7 +40,9 @@ import Cryptol.Backend import Cryptol.Backend.Concrete( Concrete(..) ) import Cryptol.Backend.Monad -import Cryptol.Eval.Generic ( iteValue ) +import Cryptol.Backend.SeqMap +import Cryptol.Backend.WordValue + import Cryptol.Eval.Env import Cryptol.Eval.Prims import Cryptol.Eval.Type @@ -122,14 +124,14 @@ -- NB, even if the list cannot be packed, we must use `VWord` -- when the element type is `Bit`. | isTBit tyv -> {-# SCC "evalExpr->Elist/bit" #-} - return $ VWord len $ - case tryFromBits sym vs of - Just w -> WordVal <$> w - Nothing -> do xs <- mapM (sDelay sym) vs - return $ LargeBitsVal len $ finiteSeqMap xs + VWord len <$> + (tryFromBits sym vs >>= \case + Just w -> pure (wordVal w) + Nothing -> do xs <- mapM (\x -> sDelay sym (fromVBit <$> x)) vs + bitmapWordVal sym len $ finiteSeqMap sym xs) | otherwise -> {-# SCC "evalExpr->EList" #-} do xs <- mapM (sDelay sym) vs - return $ VSeq len $ finiteSeqMap xs + return $ VSeq len $ finiteSeqMap sym xs where tyv = evalValType (envTypes env) ty vs = map eval es @@ -362,186 +364,12 @@ GenEvalEnv sym -> (Name, Schema, SEval sym (GenValue sym), SEval sym (GenValue sym) -> SEval sym ()) -> SEval sym () -fillHole sym env (nm, sch, _, fill) = do +fillHole _sym env (nm, _sch, _, fill) = do case lookupVar nm env of - Just (Right v) - | isValueType env sch -> - fill =<< sDelayFill sym v - (Just (etaDelay sym env sch v)) - (show (ppLocName nm)) - - | otherwise -> fill (etaDelay sym env sch v) - + Just (Right v) -> fill v _ -> evalPanic "fillHole" ["Recursive definition not completed", show (ppLocName nm)] --- | 'Value' types are non-polymorphic types recursive constructed from --- bits, finite sequences, tuples and records. Types of this form can --- be implemented rather more efficiently than general types because we can --- rely on the 'delayFill' operation to build a thunk that falls back on performing --- eta-expansion rather than doing it eagerly. -isValueType :: GenEvalEnv sym -> Schema -> Bool -isValueType env Forall{ sVars = [], sProps = [], sType = t0 } - = go (evalValType (envTypes env) t0) - where - go TVBit = True - go (TVSeq _ x) = go x - go (TVTuple xs) = and (map go xs) - go (TVRec xs) = and (fmap go xs) - go (TVNewtype _ _ xs) = and (fmap go xs) - go _ = False -isValueType _ _ = False - - -{-# SPECIALIZE etaWord :: - Concrete -> - Integer -> - SEval Concrete (GenValue Concrete) -> - SEval Concrete (WordValue Concrete) - #-} - --- | Eta-expand a word value. This forces an unpacked word representation. -etaWord :: - Backend sym => - sym -> - Integer -> - SEval sym (GenValue sym) -> - SEval sym (WordValue sym) -etaWord sym n val = do - w <- sDelay sym (fromWordVal "during eta-expansion" =<< val) - xs <- memoMap sym $ IndexSeqMap $ \i -> - do w' <- w; VBit <$> indexWordValue sym w' i - pure $ LargeBitsVal n xs - -{-# SPECIALIZE etaDelay :: - Concrete -> - GenEvalEnv Concrete -> - Schema -> - SEval Concrete (GenValue Concrete) -> - SEval Concrete (GenValue Concrete) - #-} - --- | Given a simulator value and its type, fully eta-expand the value. This --- is a type-directed pass that always produces a canonical value of the --- expected shape. Eta expansion of values is sometimes necessary to ensure --- the correct evaluation semantics of recursive definitions. Otherwise, --- expressions that should be expected to produce well-defined values in the --- denotational semantics will fail to terminate instead. -etaDelay :: - Backend sym => - sym -> - GenEvalEnv sym -> - Schema -> - SEval sym (GenValue sym) -> - SEval sym (GenValue sym) -etaDelay sym env0 Forall{ sVars = vs0, sType = tp0 } = goTpVars env0 vs0 - where - goTpVars env [] val = - do stk <- sGetCallStack sym - go stk (evalValType (envTypes env) tp0) val - goTpVars env (v:vs) val = - case tpKind v of - KType -> tlam sym $ \t -> - goTpVars (bindType (tpVar v) (Right t) env) vs ( ($t) . fromVPoly sym =<< val ) - KNum -> nlam sym $ \n -> - goTpVars (bindType (tpVar v) (Left n) env) vs ( ($n) . fromVNumPoly sym =<< val ) - k -> panic "[Eval] etaDelay" ["invalid kind on type abstraction", show k] - - go stk tp x | isReady sym x = x >>= \case - VBit{} -> x - VInteger{} -> x - VWord{} -> x - VRational{} -> x - VFloat{} -> x - VSeq n xs -> - case tp of - TVSeq _nt el -> return $ VSeq n $ IndexSeqMap $ \i -> go stk el (lookupSeqMap xs i) - _ -> evalPanic "type mismatch during eta-expansion" ["Expected sequence type, but got " ++ show tp] - - VStream xs -> - case tp of - TVStream el -> return $ VStream $ IndexSeqMap $ \i -> go stk el (lookupSeqMap xs i) - _ -> evalPanic "type mismatch during eta-expansion" ["Expected stream type, but got " ++ show tp] - - VTuple xs -> - case tp of - TVTuple ts | length ts == length xs -> return $ VTuple (zipWith (go stk) ts xs) - _ -> evalPanic "type mismatch during eta-expansion" ["Expected tuple type with " ++ show (length xs) - ++ " elements, but got " ++ show tp] - - VRecord fs -> - case tp of - TVNewtype _ _ fts -> - do let res = zipRecords (\_ v t -> go stk t v) fs fts - case res of - Left (Left f) -> evalPanic "type mismatch during eta-expansion" ["missing field " ++ show f] - Left (Right f) -> evalPanic "type mismatch during eta-expansion" ["unexpected field " ++ show f] - Right fs' -> return (VRecord fs') - TVRec fts -> - do let res = zipRecords (\_ v t -> go stk t v) fs fts - case res of - Left (Left f) -> evalPanic "type mismatch during eta-expansion" ["missing field " ++ show f] - Left (Right f) -> evalPanic "type mismatch during eta-expansion" ["unexpected field " ++ show f] - Right fs' -> return (VRecord fs') - _ -> evalPanic "type mismatch during eta-expansion" ["Expected record type, but got " ++ show tp] - - f@VFun{} -> - case tp of - TVFun _t1 t2 -> lam sym $ \a -> go stk t2 (fromVFun sym f a) - _ -> evalPanic "type mismatch during eta-expansion" ["Expected function type but got " ++ show tp] - - VPoly{} -> - evalPanic "type mismatch during eta-expansion" ["Encountered polymorphic value"] - - VNumPoly{} -> - evalPanic "type mismatch during eta-expansion" ["Encountered numeric polymorphic value"] - - go stk tp v = sWithCallStack sym stk $ - case tp of - TVBit -> v - TVInteger -> v - TVFloat {} -> v - TVIntMod _ -> v - TVRational -> v - TVArray{} -> v - - TVSeq n TVBit -> - do w <- sDelayFill sym (fromWordVal "during eta-expansion" =<< v) (Just (etaWord sym n v)) "" - return $ VWord n w - - TVSeq n el -> - do x' <- sDelay sym (fromSeq "during eta-expansion" =<< v) - return $ VSeq n $ IndexSeqMap $ \i -> do - go stk el (flip lookupSeqMap i =<< x') - - TVStream el -> - do x' <- sDelay sym (fromSeq "during eta-expansion" =<< v) - return $ VStream $ IndexSeqMap $ \i -> - go stk el (flip lookupSeqMap i =<< x') - - TVFun _t1 t2 -> - do v' <- sDelay sym (fromVFun sym <$> v) - lam sym $ \a -> go stk t2 ( ($a) =<< v' ) - - TVTuple ts -> - do let n = length ts - v' <- sDelay sym (fromVTuple <$> v) - return $ VTuple $ - [ go stk t =<< (flip genericIndex i <$> v') - | i <- [0..(n-1)] - | t <- ts - ] - - TVRec fs -> - do v' <- sDelay sym (fromVRecord <$> v) - let err f = evalPanic "expected record value with field" [show f] - let eta f t = go stk t =<< (fromMaybe (err f) . lookupField f <$> v') - return $ VRecord (mapWithFieldName eta fs) - - TVAbstract {} -> v - - TVNewtype _ _ body -> go stk (TVRec body) v - {-# SPECIALIZE declHole :: Concrete -> Decl -> @@ -600,9 +428,11 @@ SEval Concrete (GenValue Concrete) #-} --- | Apply the the given "selector" form to the given value. This function pushes --- tuple and record selections pointwise down into other value constructs --- (e.g., streams and functions). +-- | Apply the the given "selector" form to the given value. Note that +-- selectors are expected to apply only to values of the right type, +-- e.g. tuple selectors expect only tuple values. The lifting of +-- tuple an record selectors over functions and sequences has already +-- been resolved earlier in the typechecker. evalSel :: Backend sym => sym -> @@ -636,7 +466,7 @@ case v of VSeq _ vs -> lookupSeqMap vs (toInteger n) VStream vs -> lookupSeqMap vs (toInteger n) - VWord _ wv -> VBit <$> (flip (indexWordValue sym) (toInteger n) =<< wv) + VWord _ wv -> VBit <$> indexWordValue sym wv (toInteger n) _ -> do vdoc <- ppValue sym defaultPPOpts val evalPanic "Cryptol.Eval.evalSel" [ "Unexpected value in list selection" @@ -685,8 +515,7 @@ case e of VSeq i mp -> pure $ VSeq i $ updateSeqMap mp n v VStream mp -> pure $ VStream $ updateSeqMap mp n v - VWord i m -> pure $ VWord i $ do m1 <- m - updateWordValue sym m1 n asBit + VWord i m -> VWord i <$> updateWordValue sym m n asBit _ -> bad "Sequence update on a non-sequence." asBit = do res <- v @@ -776,7 +605,7 @@ SEval sym (GenValue sym) evalComp sym env len elty body ms = do lenv <- mconcat <$> mapM (branchEnvs sym (toListEnv env)) ms - mkSeq len elty <$> memoMap sym (IndexSeqMap $ \i -> do + mkSeq sym len elty =<< memoMap sym len (indexSeqMap $ \i -> do evalExpr sym (evalListEnv lenv i) body) {-# SPECIALIZE branchEnvs :: @@ -794,24 +623,24 @@ ListEnv sym -> [Match] -> SEval sym (ListEnv sym) -branchEnvs sym env matches = foldM (evalMatch sym) env matches +branchEnvs sym env matches = snd <$> foldM (evalMatch sym) (1, env) matches {-# SPECIALIZE evalMatch :: (?range :: Range, ConcPrims) => Concrete -> - ListEnv Concrete -> + (Integer, ListEnv Concrete) -> Match -> - SEval Concrete (ListEnv Concrete) + SEval Concrete (Integer, ListEnv Concrete) #-} -- | Turn a match into the list of environments it represents. evalMatch :: (?range :: Range, EvalPrims sym) => sym -> - ListEnv sym -> + (Integer, ListEnv sym) -> Match -> - SEval sym (ListEnv sym) -evalMatch sym lenv m = case m of + SEval sym (Integer, ListEnv sym) +evalMatch sym (lsz, lenv) m = seq lsz $ case m of -- many envs From n l _ty expr -> @@ -819,16 +648,16 @@ -- Select from a sequence of finite length. This causes us to 'stutter' -- through our previous choices `nLen` times. Nat nLen -> do - vss <- memoMap sym $ IndexSeqMap $ \i -> evalExpr sym (evalListEnv lenv i) expr + vss <- memoMap sym (Nat lsz) $ indexSeqMap $ \i -> evalExpr sym (evalListEnv lenv i) expr let stutter xs = \i -> xs (i `div` nLen) let lenv' = lenv { leVars = fmap stutter (leVars lenv) } let vs i = do let (q, r) = i `divMod` nLen lookupSeqMap vss q >>= \case - VWord _ w -> VBit <$> (flip (indexWordValue sym) r =<< w) + VWord _ w -> VBit <$> indexWordValue sym w r VSeq _ xs' -> lookupSeqMap xs' r VStream xs' -> lookupSeqMap xs' r _ -> evalPanic "evalMatch" ["Not a list value"] - return $ bindVarList n vs lenv' + return (lsz * nLen, bindVarList n vs lenv') -- Select from a sequence of infinite length. Note that this means we -- will never need to backtrack into previous branches. Thus, we can convert @@ -842,11 +671,13 @@ let env = EvalEnv allvars (leTypes lenv) xs <- evalExpr sym env expr let vs i = case xs of - VWord _ w -> VBit <$> (flip (indexWordValue sym) i =<< w) + VWord _ w -> VBit <$> indexWordValue sym w i VSeq _ xs' -> lookupSeqMap xs' i VStream xs' -> lookupSeqMap xs' i _ -> evalPanic "evalMatch" ["Not a list value"] - return $ bindVarList n vs lenv' + -- Selecting from an infinite list effectively resets the length of the + -- list environment, so return 1 as the length + return (1, bindVarList n vs lenv') where len = evalNumType (leTypes lenv) l @@ -854,7 +685,7 @@ -- XXX we don't currently evaluate these as though they could be recursive, as -- they are typechecked that way; the read environment to evalExpr is the same -- as the environment to bind a new name in. - Let d -> return $ bindVarList (dName d) (\i -> f (evalListEnv lenv i)) lenv + Let d -> return (lsz, bindVarList (dName d) (\i -> f (evalListEnv lenv i)) lenv) where f env = case dDefinition d of 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 @@ -26,7 +26,6 @@ ) where import Control.Monad (guard, zipWithM, foldM, mzero) -import Data.Bits (Bits(..)) import Data.Ratio(numerator,denominator) import Data.Word(Word32, Word64) import MonadLib( ChoiceT, findOne, lift ) @@ -42,8 +41,10 @@ import Cryptol.Backend.Concrete import Cryptol.Backend.FloatHelpers import Cryptol.Backend.Monad +import Cryptol.Backend.SeqMap +import Cryptol.Backend.WordValue -import Cryptol.Eval.Generic hiding (logicShift) +import Cryptol.Eval.Generic import Cryptol.Eval.Prims import Cryptol.Eval.Type import Cryptol.Eval.Value @@ -110,7 +111,7 @@ do ses <- traverse (go b) =<< lift (sequence (enumerateSeqMap n svs)) pure $ EList ses (tValTy b) (TVSeq n TVBit, VWord _ wval) -> - do BV _ v <- lift (asWordVal Concrete =<< wval) + do BV _ v <- lift (asWordVal Concrete wval) pure $ ETApp (ETApp (prim "number") (tNum v)) (tWord (tNum n)) (_,VStream{}) -> mzero @@ -125,7 +126,7 @@ panic "Cryptol.Eval.Concrete.toExpr" ["type mismatch:" , pretty (tValTy ty) - , render doc + , show doc ] floatToExpr :: PrimMap -> AST.Type -> AST.Type -> FP.BigFloat -> AST.Expr @@ -159,24 +160,11 @@ Map.fromList $ map (\(n, v) -> (prelPrim n, v)) - [ (">>$" , {-# SCC "Prelude::(>>$)" #-} - sshrV) - - -- Shifts and rotates - , ("<<" , {-# SCC "Prelude::(<<)" #-} - logicShift shiftLW shiftLS) - , (">>" , {-# SCC "Prelude::(>>)" #-} - logicShift shiftRW shiftRS) - , ("<<<" , {-# SCC "Prelude::(<<<)" #-} - logicShift rotateLW rotateLS) - , (">>>" , {-# SCC "Prelude::(>>>)" #-} - logicShift rotateRW rotateRS) - - -- Indexing and updates - , ("@" , {-# SCC "Prelude::(@)" #-} - indexPrim sym indexFront_int indexFront_bits indexFront) + [ -- Indexing and updates + ("@" , {-# SCC "Prelude::(@)" #-} + indexPrim sym IndexForward indexFront_int indexFront_segs) , ("!" , {-# SCC "Prelude::(!)" #-} - indexPrim sym indexBack_int indexBack_bits indexBack) + indexPrim sym IndexBackward indexFront_int indexFront_segs) , ("update" , {-# SCC "Prelude::update" #-} updatePrim sym updateFront_word updateFront) @@ -194,7 +182,7 @@ F2.pmult (fromInteger (u+1)) x y else F2.pmult (fromInteger (v+1)) y x - in return . VWord (1+u+v) . pure . WordVal . mkBv (1+u+v) $! z) + in return . VWord (1+u+v) . wordVal . mkBv (1+u+v) $! z) , ("pmod", PFinPoly \_u -> @@ -203,7 +191,7 @@ PWordFun \(BV _ m) -> PPrim do assertSideCondition sym (m /= 0) DivideByZero - return . VWord v . pure . WordVal . mkBv v $! F2.pmod (fromInteger w) x m) + return . VWord v . wordVal . mkBv v $! F2.pmod (fromInteger w) x m) , ("pdiv", PFinPoly \_u -> @@ -212,7 +200,7 @@ PWordFun \(BV _ m) -> PPrim do assertSideCondition sym (m /= 0) DivideByZero - return . VWord w . pure . WordVal . mkBv w $! F2.pdiv (fromInteger w) x m) + return . VWord w . wordVal . mkBv w $! F2.pdiv (fromInteger w) x m) ] @@ -230,7 +218,7 @@ PFinPoly \p -> PFun \s -> PFun \t -> - PPrim + PPrim do s' <- toProjectivePoint =<< s t' <- toProjectivePoint =<< t let r = PrimeEC.ec_add_nonzero (PrimeEC.primeModulus p) s' t' @@ -285,8 +273,8 @@ foldM (\st blk -> seq st (SHA.processSHA256Block st <$> (toSHA256Block =<< blk))) SHA.initialSHA224State blks let f :: Word32 -> Eval Value - f = pure . VWord 32 . pure . WordVal . BV 32 . toInteger - zs = finiteSeqMap (map f [w0,w1,w2,w3,w4,w5,w6]) + f = pure . VWord 32 . wordVal . BV 32 . toInteger + zs = finiteSeqMap Concrete (map f [w0,w1,w2,w3,w4,w5,w6]) seq zs (pure (VSeq 7 zs))) , ("processSHA2_256", {-# SCC "SuiteB::processSHA2_256" #-} @@ -298,8 +286,8 @@ foldM (\st blk -> seq st (SHA.processSHA256Block st <$> (toSHA256Block =<< blk))) SHA.initialSHA256State blks let f :: Word32 -> Eval Value - f = pure . VWord 32 . pure . WordVal . BV 32 . toInteger - zs = finiteSeqMap (map f [w0,w1,w2,w3,w4,w5,w6,w7]) + f = pure . VWord 32 . wordVal . BV 32 . toInteger + zs = finiteSeqMap Concrete (map f [w0,w1,w2,w3,w4,w5,w6,w7]) seq zs (pure (VSeq 8 zs))) , ("processSHA2_384", {-# SCC "SuiteB::processSHA2_384" #-} @@ -311,8 +299,8 @@ foldM (\st blk -> seq st (SHA.processSHA512Block st <$> (toSHA512Block =<< blk))) SHA.initialSHA384State blks let f :: Word64 -> Eval Value - f = pure . VWord 64 . pure . WordVal . BV 64 . toInteger - zs = finiteSeqMap (map f [w0,w1,w2,w3,w4,w5]) + f = pure . VWord 64 . wordVal . BV 64 . toInteger + zs = finiteSeqMap Concrete (map f [w0,w1,w2,w3,w4,w5]) seq zs (pure (VSeq 6 zs))) , ("processSHA2_512", {-# SCC "SuiteB::processSHA2_512" #-} @@ -324,8 +312,8 @@ foldM (\st blk -> seq st (SHA.processSHA512Block st <$> (toSHA512Block =<< blk))) SHA.initialSHA512State blks let f :: Word64 -> Eval Value - f = pure . VWord 64 . pure . WordVal . BV 64 . toInteger - zs = finiteSeqMap (map f [w0,w1,w2,w3,w4,w5,w6,w7]) + f = pure . VWord 64 . wordVal . BV 64 . toInteger + zs = finiteSeqMap Concrete (map f [w0,w1,w2,w3,w4,w5,w6,w7]) seq zs (pure (VSeq 8 zs))) , ("AESKeyExpand", {-# SCC "SuiteB::AESKeyExpand" #-} @@ -336,11 +324,11 @@ let toWord :: Integer -> Eval Word32 toWord i = fromInteger. bvVal <$> (fromVWord Concrete "AESInfKeyExpand" =<< lookupSeqMap ss i) let fromWord :: Word32 -> Eval Value - fromWord = pure . VWord 32 . pure . WordVal . BV 32 . toInteger + fromWord = pure . VWord 32 . wordVal . BV 32 . toInteger kws <- mapM toWord [0 .. k-1] let ws = AES.keyExpansionWords k kws let len = 4*(k+7) - pure (VSeq len (finiteSeqMap (map fromWord ws)))) + pure (VSeq len (finiteSeqMap Concrete (map fromWord ws)))) , ("AESInvMixColumns", {-# SCC "SuiteB::AESInvMixColumns" #-} PFun \st -> @@ -349,10 +337,10 @@ let toWord :: Integer -> Eval Word32 toWord i = fromInteger. bvVal <$> (fromVWord Concrete "AESInvMixColumns" =<< lookupSeqMap ss i) let fromWord :: Word32 -> Eval Value - fromWord = pure . VWord 32 . pure . WordVal . BV 32 . toInteger + fromWord = pure . VWord 32 . wordVal . BV 32 . toInteger ws <- mapM toWord [0,1,2,3] let ws' = AES.invMixColumns ws - pure . VSeq 4 . finiteSeqMap . map fromWord $ ws') + pure . VSeq 4 . finiteSeqMap Concrete . map fromWord $ ws') , ("AESEncRound", {-# SCC "SuiteB::AESEncRound" #-} PFun \st -> @@ -361,10 +349,10 @@ let toWord :: Integer -> Eval Word32 toWord i = fromInteger. bvVal <$> (fromVWord Concrete "AESEncRound" =<< lookupSeqMap ss i) let fromWord :: Word32 -> Eval Value - fromWord = pure . VWord 32 . pure . WordVal . BV 32 . toInteger + fromWord = pure . VWord 32 . wordVal . BV 32 . toInteger ws <- mapM toWord [0,1,2,3] let ws' = AES.aesRound ws - pure . VSeq 4 . finiteSeqMap . map fromWord $ ws') + pure . VSeq 4 . finiteSeqMap Concrete . map fromWord $ ws') , ("AESEncFinalRound", {-# SCC "SuiteB::AESEncFinalRound" #-} PFun \st -> @@ -373,10 +361,10 @@ let toWord :: Integer -> Eval Word32 toWord i = fromInteger. bvVal <$> (fromVWord Concrete "AESEncFinalRound" =<< lookupSeqMap ss i) let fromWord :: Word32 -> Eval Value - fromWord = pure . VWord 32 . pure . WordVal . BV 32 . toInteger + fromWord = pure . VWord 32 . wordVal . BV 32 . toInteger ws <- mapM toWord [0,1,2,3] let ws' = AES.aesFinalRound ws - pure . VSeq 4 . finiteSeqMap . map fromWord $ ws') + pure . VSeq 4 . finiteSeqMap Concrete . map fromWord $ ws') , ("AESDecRound", {-# SCC "SuiteB::AESDecRound" #-} PFun \st -> @@ -385,10 +373,10 @@ let toWord :: Integer -> Eval Word32 toWord i = fromInteger. bvVal <$> (fromVWord Concrete "AESDecRound" =<< lookupSeqMap ss i) let fromWord :: Word32 -> Eval Value - fromWord = pure . VWord 32 . pure . WordVal . BV 32 . toInteger + fromWord = pure . VWord 32 . wordVal . BV 32 . toInteger ws <- mapM toWord [0,1,2,3] let ws' = AES.aesInvRound ws - pure . VSeq 4 . finiteSeqMap . map fromWord $ ws') + pure . VSeq 4 . finiteSeqMap Concrete . map fromWord $ ws') , ("AESDecFinalRound", {-# SCC "SuiteB::AESDecFinalRound" #-} PFun \st -> @@ -397,10 +385,10 @@ let toWord :: Integer -> Eval Word32 toWord i = fromInteger. bvVal <$> (fromVWord Concrete "AESDecFinalRound" =<< lookupSeqMap ss i) let fromWord :: Word32 -> Eval Value - fromWord = pure . VWord 32 . pure . WordVal . BV 32 . toInteger + fromWord = pure . VWord 32 . wordVal . BV 32 . toInteger ws <- mapM toWord [0,1,2,3] let ws' = AES.aesInvFinalRound ws - pure . VSeq 4 . finiteSeqMap . map fromWord $ ws') + pure . VSeq 4 . finiteSeqMap Concrete . map fromWord $ ws') ] @@ -449,152 +437,39 @@ (toWord 14) <*> (toWord 15) --------------------------------------------------------------------------------- -sshrV :: Prim Concrete -sshrV = - PNumPoly \_n -> - PTyPoly \ix -> - PWordFun \(BV w x) -> - PFun \y -> - PPrim - do idx <- y >>= asIndex Concrete ">>$" ix >>= \case - Left idx -> pure idx - Right wv -> bvVal <$> asWordVal Concrete wv - return $ VWord w $ pure $ WordVal $ mkBv w $ signedShiftRW w x idx - -logicShift :: (Integer -> Integer -> Integer -> Integer) - -- ^ The function may assume its arguments are masked. - -- It is responsible for masking its result if needed. - -> (Nat' -> TValue -> SeqMap Concrete -> Integer -> SeqMap Concrete) - -> Prim Concrete -logicShift opW opS = - PNumPoly \a -> - PTyPoly \_ix -> - PTyPoly \c -> - PFun \l -> - PFun \r -> - PPrim - do i <- r >>= \case - VInteger i -> pure i - VWord _ wval -> bvVal <$> (asWordVal Concrete =<< wval) - _ -> evalPanic "logicShift" ["not an index"] - l >>= \case - VWord w wv -> return $ VWord w $ wv >>= \case - WordVal (BV _ x) -> return $ WordVal (BV w (opW w x i)) - LargeBitsVal n xs -> return $ LargeBitsVal n $ opS (Nat n) c xs i - - _ -> mkSeq a c <$> (opS a c <$> (fromSeq "logicShift" =<< l) <*> return i) - --- Left shift for words. -shiftLW :: Integer -> Integer -> Integer -> Integer -shiftLW w ival by - | by < 0 = shiftRW w ival (negate by) - | by >= w = 0 - | by > toInteger (maxBound :: Int) = panic "shiftLW" ["Shift amount too large", show by] - | otherwise = mask w (shiftL ival (fromInteger by)) - --- Right shift for words -shiftRW :: Integer -> Integer -> Integer -> Integer -shiftRW w ival by - | by < 0 = shiftLW w ival (negate by) - | by >= w = 0 - | by > toInteger (maxBound :: Int) = panic "shiftRW" ["Shift amount too large", show by] - | otherwise = shiftR ival (fromInteger by) - --- signed right shift for words -signedShiftRW :: Integer -> Integer -> Integer -> Integer -signedShiftRW w ival by - | by < 0 = shiftLW w ival (negate by) - | otherwise = - let by' = min w by in - if by' > toInteger (maxBound :: Int) then - panic "signedShiftRW" ["Shift amount too large", show by] - else - shiftR (signedValue w ival) (fromInteger by') - -shiftLS :: Nat' -> TValue -> SeqMap Concrete -> Integer -> SeqMap Concrete -shiftLS w ety vs by - | by < 0 = shiftRS w ety vs (negate by) - -shiftLS w ety vs by = IndexSeqMap $ \i -> - case w of - Nat len - | i+by < len -> lookupSeqMap vs (i+by) - | i < len -> zeroV Concrete ety - | otherwise -> evalPanic "shiftLS" ["Index out of bounds"] - Inf -> lookupSeqMap vs (i+by) - -shiftRS :: Nat' -> TValue -> SeqMap Concrete -> Integer -> SeqMap Concrete -shiftRS w ety vs by - | by < 0 = shiftLS w ety vs (negate by) - -shiftRS w ety vs by = IndexSeqMap $ \i -> - case w of - Nat len - | i >= by -> lookupSeqMap vs (i-by) - | i < len -> zeroV Concrete ety - | otherwise -> evalPanic "shiftLS" ["Index out of bounds"] - Inf - | i >= by -> lookupSeqMap vs (i-by) - | otherwise -> zeroV Concrete ety - - --- XXX integer doesn't implement rotateL, as there's no bit bound -rotateLW :: Integer -> Integer -> Integer -> Integer -rotateLW 0 i _ = i -rotateLW w i by = mask w $ (i `shiftL` b) .|. (i `shiftR` (fromInteger w - b)) - where b = fromInteger (by `mod` w) - -rotateLS :: Nat' -> TValue -> SeqMap Concrete -> Integer -> SeqMap Concrete -rotateLS w _ vs by = IndexSeqMap $ \i -> - case w of - Nat len -> lookupSeqMap vs ((by + i) `mod` len) - _ -> panic "Cryptol.Eval.Prim.rotateLS" [ "unexpected infinite sequence" ] - --- XXX integer doesn't implement rotateR, as there's no bit bound -rotateRW :: Integer -> Integer -> Integer -> Integer -rotateRW 0 i _ = i -rotateRW w i by = mask w $ (i `shiftR` b) .|. (i `shiftL` (fromInteger w - b)) - where b = fromInteger (by `mod` w) - -rotateRS :: Nat' -> TValue -> SeqMap Concrete -> Integer -> SeqMap Concrete -rotateRS w _ vs by = IndexSeqMap $ \i -> - case w of - Nat len -> lookupSeqMap vs ((len - by + i) `mod` len) - _ -> panic "Cryptol.Eval.Prim.rotateRS" [ "unexpected infinite sequence" ] - - -- Sequence Primitives --------------------------------------------------------- -indexFront :: Nat' -> TValue -> SeqMap Concrete -> TValue -> BV -> Eval Value -indexFront _mblen _a vs _ix (bvVal -> ix) = lookupSeqMap vs ix - -indexFront_bits :: Nat' -> TValue -> SeqMap Concrete -> TValue -> [Bool] -> Eval Value -indexFront_bits mblen a vs ix bs = indexFront mblen a vs ix =<< packWord Concrete bs - -indexFront_int :: Nat' -> TValue -> SeqMap Concrete -> TValue -> Integer -> Eval Value +indexFront_int :: Nat' -> TValue -> SeqMap Concrete (GenValue Concrete) -> TValue -> Integer -> Eval Value indexFront_int _mblen _a vs _ix idx = lookupSeqMap vs idx -indexBack :: Nat' -> TValue -> SeqMap Concrete -> TValue -> BV -> Eval Value -indexBack mblen a vs ix (bvVal -> idx) = indexBack_int mblen a vs ix idx - -indexBack_bits :: Nat' -> TValue -> SeqMap Concrete -> TValue -> [Bool] -> Eval Value -indexBack_bits mblen a vs ix bs = indexBack mblen a vs ix =<< packWord Concrete bs +indexFront_segs :: Nat' -> TValue -> SeqMap Concrete (GenValue Concrete) -> TValue -> Integer -> [IndexSegment Concrete] -> Eval Value +indexFront_segs _mblen _a vs _ix idx_bits segs = lookupSeqMap vs $! packSegments idx_bits segs -indexBack_int :: Nat' -> TValue -> SeqMap Concrete -> TValue -> Integer -> Eval Value -indexBack_int mblen _a vs _ix idx = - case mblen of - Nat len -> lookupSeqMap vs (len - idx - 1) - Inf -> evalPanic "indexBack" ["unexpected infinite sequence"] +packSegments :: Integer -> [IndexSegment Concrete] -> Integer +packSegments = loop 0 + where + loop !val !n segs = + case segs of + [] -> val + [WordIndexSegment (BV _ x)] -> val + x + WordIndexSegment (BV xlen x) : bs -> + let n' = n - xlen + in loop (val + (x*2^n')) n' bs + BitIndexSegment True : bs -> + let n' = n - 1 + in loop (val + 2^n') n' bs + BitIndexSegment False : bs -> + let n' = n - 1 + in loop val n' bs updateFront :: Nat' {- ^ length of the sequence -} -> TValue {- ^ type of values in the sequence -} -> - SeqMap Concrete {- ^ sequence to update -} -> + SeqMap Concrete (GenValue Concrete) {- ^ sequence to update -} -> Either Integer (WordValue Concrete) {- ^ index -} -> Eval Value {- ^ new value at index -} -> - Eval (SeqMap Concrete) + Eval (SeqMap Concrete (GenValue Concrete)) updateFront _len _eltTy vs (Left idx) val = do return $ updateSeqMap vs idx val @@ -619,10 +494,10 @@ updateBack :: Nat' {- ^ length of the sequence -} -> TValue {- ^ type of values in the sequence -} -> - SeqMap Concrete {- ^ sequence to update -} -> + SeqMap Concrete (GenValue Concrete) {- ^ sequence to update -} -> Either Integer (WordValue Concrete) {- ^ index -} -> Eval Value {- ^ new value at index -} -> - Eval (SeqMap Concrete) + Eval (SeqMap Concrete (GenValue Concrete)) updateBack Inf _eltTy _vs _w _val = evalPanic "Unexpected infinite sequence in updateEnd" [] updateBack (Nat n) _eltTy vs (Left idx) val = do diff --git a/src/Cryptol/Eval/Env.hs b/src/Cryptol/Eval/Env.hs --- a/src/Cryptol/Eval/Env.hs +++ b/src/Cryptol/Eval/Env.hs @@ -6,8 +6,6 @@ -- Stability : provisional -- Portability : portable -{-# LANGUAGE Safe #-} - {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DeriveAnyClass #-} diff --git a/src/Cryptol/Eval/Generic.hs b/src/Cryptol/Eval/Generic.hs --- a/src/Cryptol/Eval/Generic.hs +++ b/src/Cryptol/Eval/Generic.hs @@ -19,25 +19,28 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE BangPatterns #-} + {-# OPTIONS_GHC -fno-warn-orphans #-} module Cryptol.Eval.Generic where import qualified Control.Exception as X +import Control.Monad(join) import Control.Monad.IO.Class (MonadIO(..)) -import Control.Monad (join, unless) import System.Random.TF.Gen (seedTFGen) -import Data.Bits (testBit, (.&.), shiftR) +import Data.Bits ((.&.), shiftR) import Data.Maybe (fromMaybe) import qualified Data.Map.Strict as Map import Data.Map(Map) import Data.Ratio ((%)) import Cryptol.TypeCheck.AST -import Cryptol.TypeCheck.Solver.InfNat (Nat'(..),nMul,widthInteger) +import Cryptol.TypeCheck.Solver.InfNat (Nat'(..),nMul) import Cryptol.Backend import Cryptol.Backend.Concrete (Concrete(..)) import Cryptol.Backend.Monad( Eval, evalPanic, EvalError(..), Unsupported(..) ) +import Cryptol.Backend.SeqMap +import Cryptol.Backend.WordValue import Cryptol.Testing.Random( randomValue ) import Cryptol.Eval.Prims @@ -63,7 +66,7 @@ | m == 0 -> evalPanic "mkLit" ["0 modulus not allowed"] | otherwise -> VInteger <$> integerLit sym (i `mod` m) TVFloat e p -> VFloat <$> fpLit sym e p (fromInteger i) - TVSeq w TVBit -> pure $ word sym w i + TVSeq w TVBit -> word sym w i TVRational -> VRational <$> (intToRational sym =<< integerLit sym i) _ -> evalPanic "Cryptol.Eval.Prim.evalConst" [ "Invalid type for number" ] @@ -217,14 +220,14 @@ lw <- fromVWord sym "ringLeft" l rw <- fromVWord sym "ringRight" r stk <- sGetCallStack sym - return $ VWord w (WordVal <$> (sWithCallStack sym stk (opw w lw rw))) - | otherwise -> VSeq w <$> (join (zipSeqMap sym (loop a) <$> + VWord w . wordVal <$> (sWithCallStack sym stk (opw w lw rw)) + | otherwise -> VSeq w <$> (join (zipSeqMap sym (loop a) (Nat w) <$> (fromSeq "ringBinary left" l) <*> (fromSeq "ringBinary right" r))) TVStream a -> -- streams - VStream <$> (join (zipSeqMap sym (loop a) <$> + VStream <$> (join (zipSeqMap sym (loop a) Inf <$> (fromSeq "ringBinary left" l) <*> (fromSeq "ringBinary right" r))) @@ -303,11 +306,11 @@ | isTBit a -> do wx <- fromVWord sym "ringUnary" v stk <- sGetCallStack sym - return $ VWord w (WordVal <$> sWithCallStack sym stk (opw w wx)) - | otherwise -> VSeq w <$> (mapSeqMap sym (loop a) =<< fromSeq "ringUnary" v) + VWord w . wordVal <$> sWithCallStack sym stk (opw w wx) + | otherwise -> VSeq w <$> (mapSeqMap sym (loop a) (Nat w) =<< fromSeq "ringUnary" v) TVStream a -> - VStream <$> (mapSeqMap sym (loop a) =<< fromSeq "ringUnary" v) + VStream <$> (mapSeqMap sym (loop a) Inf =<< fromSeq "ringUnary" v) -- functions TVFun _ ety -> @@ -372,14 +375,14 @@ -- words and finite sequences | isTBit a -> do stk <- sGetCallStack sym - pure $ VWord w $ (WordVal <$> sWithCallStack sym stk (opw w)) + VWord w . wordVal <$> sWithCallStack sym stk (opw w) | otherwise -> do v <- sDelay sym (loop a) - pure $ VSeq w $ IndexSeqMap \_i -> v + pure $ VSeq w $ indexSeqMap \_i -> v TVStream a -> do v <- sDelay sym (loop a) - pure $ VStream $ IndexSeqMap \_i -> v + pure $ VStream $ indexSeqMap \_i -> v TVFun _ b -> do v <- sDelay sym (loop b) @@ -420,7 +423,7 @@ do wl <- fromVWord sym "integralBinary left" l wr <- fromVWord sym "integralBinary right" r stk <- sGetCallStack sym - return $ VWord w (WordVal <$> sWithCallStack sym stk (opw w wl wr)) + VWord w . wordVal <$> sWithCallStack sym stk (opw w wl wr) _ -> evalPanic "integralBinary" [show ty ++ " not int class `Integral`"] @@ -509,7 +512,7 @@ intV sym onei aty | n > 0 -> - do ebits <- enumerateIntBits' sym n ei + do (_,ebits) <- enumerateIntBits' sym n ei computeExponent sym aty a ebits | otherwise -> raiseError sym NegativeExponent @@ -517,7 +520,7 @@ Nothing -> liftIO (X.throw (UnsupportedSymbolicOp "integer exponentiation")) TVSeq _w el | isTBit el -> - do ebits <- enumerateWordValue sym =<< fromWordVal "(^^)" e + do ebits <- enumerateWordValue sym (fromWordVal "(^^)" e) computeExponent sym aty a ebits _ -> evalPanic "expV" [show ety ++ " not int class `Integral`"] @@ -695,7 +698,7 @@ lg2V sym = PFinPoly \w -> PWordFun \x -> - PVal (VWord w (WordVal <$> wordLg2 sym x)) + PPrim (VWord w . wordVal <$> wordLg2 sym x) {-# SPECIALIZE sdivV :: Concrete -> Prim Concrete #-} sdivV :: Backend sym => sym -> Prim sym @@ -703,7 +706,7 @@ PFinPoly \w -> PWordFun \x -> PWordFun \y -> - PVal (VWord w (WordVal <$> wordSignedDiv sym x y)) + PPrim (VWord w . wordVal <$> wordSignedDiv sym x y) {-# SPECIALIZE smodV :: Concrete -> Prim Concrete #-} smodV :: Backend sym => sym -> Prim sym @@ -711,8 +714,15 @@ PFinPoly \w -> PWordFun \x -> PWordFun \y -> - PVal (VWord w (WordVal <$> wordSignedMod sym x y)) + PPrim (VWord w . wordVal <$> wordSignedMod sym x y) +{-# SPECIALIZE toSignedIntegerV :: Concrete -> Prim Concrete #-} +toSignedIntegerV :: Backend sym => sym -> Prim sym +toSignedIntegerV sym = + PFinPoly \_w -> + PWordFun \x -> + PPrim (VInteger <$> wordToSignedInt sym x) + -- Cmp ------------------------------------------------------------------------- {-# SPECIALIZE cmpValue :: @@ -915,14 +925,14 @@ -- sequences TVSeq w ety - | isTBit ety -> pure $ word sym w 0 + | isTBit ety -> word sym w 0 | otherwise -> do z <- sDelay sym (zeroV sym ety) - pure $ VSeq w (IndexSeqMap \_i -> z) + pure $ VSeq w (indexSeqMap \_i -> z) TVStream ety -> do z <- sDelay sym (zeroV sym ety) - pure $ VStream (IndexSeqMap \_i -> z) + pure $ VStream (indexSeqMap \_i -> z) -- functions TVFun _ bty -> @@ -943,52 +953,13 @@ TVNewtype {} -> evalPanic "zeroV" [ "Newtype not in `Zero`" ] --- | otherwise = evalPanic "zeroV" ["invalid type for zero"] -{-# INLINE joinWordVal #-} -joinWordVal :: Backend sym => sym -> WordValue sym -> WordValue sym -> SEval sym (WordValue sym) -joinWordVal sym (WordVal w1) (WordVal w2) - | wordLen sym w1 + wordLen sym w2 < largeBitSize - = WordVal <$> joinWord sym w1 w2 -joinWordVal sym w1 w2 - = pure $ LargeBitsVal (n1+n2) (concatSeqMap n1 (asBitsMap sym w1) (asBitsMap sym w2)) - where n1 = wordValueSize sym w1 - n2 = wordValueSize sym w2 - - -{-# SPECIALIZE joinWords :: - Concrete -> - Integer -> - Integer -> - SeqMap Concrete -> - SEval Concrete (GenValue Concrete) - #-} -joinWords :: forall sym. - Backend sym => - sym -> - Integer -> - Integer -> - SeqMap sym -> - SEval sym (GenValue sym) -joinWords sym nParts nEach xs = - loop (WordVal <$> wordLit sym 0 0) (enumerateSeqMap nParts xs) - - where - loop :: SEval sym (WordValue sym) -> [SEval sym (GenValue sym)] -> SEval sym (GenValue sym) - loop !wv [] = - VWord (nParts * nEach) <$> sDelay sym wv - loop !wv (w : ws) = - w >>= \case - VWord _ w' -> - loop (join (joinWordVal sym <$> wv <*> w')) ws - _ -> evalPanic "joinWords: expected word value" [] - {-# SPECIALIZE joinSeq :: Concrete -> Nat' -> Integer -> TValue -> - SeqMap Concrete -> + SEval Concrete (SeqMap Concrete (GenValue Concrete)) -> SEval Concrete (GenValue Concrete) #-} joinSeq :: @@ -997,35 +968,32 @@ Nat' -> Integer -> TValue -> - SeqMap sym -> + SEval sym (SeqMap sym (GenValue sym)) -> SEval sym (GenValue sym) -- Special case for 0 length inner sequences. -joinSeq sym _parts 0 a _xs +joinSeq sym _parts 0 a _val = zeroV sym (TVSeq 0 a) -- finite sequence of words -joinSeq sym (Nat parts) each TVBit xs - | parts * each < largeBitSize - = joinWords sym parts each xs - | otherwise - = do let zs = IndexSeqMap $ \i -> - do let (q,r) = divMod i each - ys <- fromWordVal "join seq" =<< lookupSeqMap xs q - VBit <$> indexWordValue sym ys r - return $ VWord (parts * each) $ pure $ LargeBitsVal (parts * each) zs +joinSeq sym (Nat parts) each TVBit val + = do w <- delayWordValue sym (parts*each) + (joinWords sym parts each . fmap (fromWordVal "joinV") =<< val) + pure (VWord (parts*each) w) -- infinite sequence of words -joinSeq sym Inf each TVBit xs - = return $ VStream $ IndexSeqMap $ \i -> +joinSeq sym Inf each TVBit val + = return $ VStream $ indexSeqMap $ \i -> do let (q,r) = divMod i each - ys <- fromWordVal "join seq" =<< lookupSeqMap xs q + xs <- val + ys <- fromWordVal "join seq" <$> lookupSeqMap xs q VBit <$> indexWordValue sym ys r -- finite or infinite sequence of non-words -joinSeq _sym parts each _a xs - = return $ vSeq $ IndexSeqMap $ \i -> do +joinSeq _sym parts each _a val + = return $ vSeq $ indexSeqMap $ \i -> do let (q,r) = divMod i each + xs <- val ys <- fromSeq "join seq" =<< lookupSeqMap xs q lookupSeqMap ys r where @@ -1044,146 +1012,115 @@ Nat' -> Integer -> TValue -> - GenValue sym -> + SEval sym (GenValue sym) -> SEval sym (GenValue sym) -joinV sym parts each a val = joinSeq sym parts each a =<< fromSeq "joinV" val - - -{-# INLINE splitWordVal #-} - -splitWordVal :: - Backend sym => - sym -> - Integer -> - Integer -> - WordValue sym -> - SEval sym (WordValue sym, WordValue sym) -splitWordVal sym leftWidth rightWidth (WordVal w) = - do (lw, rw) <- splitWord sym leftWidth rightWidth w - pure (WordVal lw, WordVal rw) -splitWordVal _ leftWidth rightWidth (LargeBitsVal _n xs) = - let (lxs, rxs) = splitSeqMap leftWidth xs - in pure (LargeBitsVal leftWidth lxs, LargeBitsVal rightWidth rxs) +joinV sym parts each a val = + do xs <- sDelay sym (fromSeq "joinV" =<< val) + joinSeq sym parts each a xs -{-# INLINE splitAtV #-} -splitAtV :: +{-# INLINE takeV #-} +takeV :: Backend sym => sym -> Nat' -> Nat' -> TValue -> - GenValue sym -> + SEval sym (GenValue sym) -> SEval sym (GenValue sym) -splitAtV sym front back a val = - case back of - - Nat rightWidth | aBit -> do - ws <- sDelay sym (splitWordVal sym leftWidth rightWidth =<< fromWordVal "splitAtV" val) - return $ VTuple - [ VWord leftWidth . pure . fst <$> ws - , VWord rightWidth . pure . snd <$> ws - ] - - Inf | aBit -> do - vs <- sDelay sym (fromSeq "splitAtV" val) - ls <- sDelay sym (fst . splitSeqMap leftWidth <$> vs) - rs <- sDelay sym (snd . splitSeqMap leftWidth <$> vs) - return $ VTuple [ return $ VWord leftWidth (LargeBitsVal leftWidth <$> ls) - , VStream <$> rs - ] - - _ -> do - vs <- sDelay sym (fromSeq "splitAtV" val) - ls <- sDelay sym (fst . splitSeqMap leftWidth <$> vs) - rs <- sDelay sym (snd . splitSeqMap leftWidth <$> vs) - return $ VTuple [ VSeq leftWidth <$> ls - , mkSeq back a <$> rs - ] - - where - aBit = isTBit a - - leftWidth = case front of - Nat n -> n - _ -> evalPanic "splitAtV" ["invalid `front` len"] +takeV sym front back a val = + case front of + Inf -> val + Nat front' -> + case back of + Nat back' | isTBit a -> + do w <- delayWordValue sym front' (takeWordVal sym front' back' =<< (fromWordVal "takeV" <$> val)) + pure (VWord front' w) + Inf | isTBit a -> + do w <- delayWordValue sym front' (bitmapWordVal sym front' . fmap fromVBit =<< (fromSeq "takeV" =<< val)) + pure (VWord front' w) -{-# INLINE extractWordVal #-} + _ -> + do xs <- delaySeqMap sym (fromSeq "takeV" =<< val) + pure (VSeq front' xs) --- | Extract a subsequence of bits from a @WordValue@. --- The first integer argument is the number of bits in the --- resulting word. The second integer argument is the --- number of less-significant digits to discard. Stated another --- way, the operation `extractWordVal n i w` is equivalent to --- first shifting `w` right by `i` bits, and then truncating to --- `n` bits. -extractWordVal :: +{-# INLINE dropV #-} +dropV :: Backend sym => sym -> Integer -> - Integer -> - WordValue sym -> - SEval sym (WordValue sym) -extractWordVal sym len start (WordVal w) = - WordVal <$> extractWord sym len start w -extractWordVal _ len start (LargeBitsVal n xs) = - let xs' = dropSeqMap (n - start - len) xs - in pure $ LargeBitsVal len xs' + Nat' -> + TValue -> + SEval sym (GenValue sym) -> + SEval sym (GenValue sym) +dropV sym front back a val = + case back of + Nat back' | isTBit a -> + do w <- delayWordValue sym back' (dropWordVal sym front back' =<< (fromWordVal "dropV" <$> val)) + pure (VWord back' w) -{-# INLINE ecSplitV #-} + _ -> + do xs <- delaySeqMap sym (dropSeqMap front <$> (fromSeq "dropV" =<< val)) + mkSeq sym back a xs + +{-# INLINE splitV #-} + -- | Split implementation. -ecSplitV :: Backend sym => sym -> Prim sym -ecSplitV sym = - PNumPoly \parts -> - PNumPoly \each -> - PTyPoly \a -> - PFun \val -> - PPrim +splitV :: Backend sym => + sym -> + Nat' -> + Integer -> + TValue -> + SEval sym (GenValue sym) -> + SEval sym (GenValue sym) +splitV sym parts each a val = case (parts, each) of - (Nat p, Nat e) | isTBit a -> do - ~(VWord _ val') <- val - return $ VSeq p $ IndexSeqMap $ \i -> - pure $ VWord e (extractWordVal sym e ((p-i-1)*e) =<< val') - (Inf, Nat e) | isTBit a -> do - val' <- sDelay sym (fromSeq "ecSplitV" =<< val) - return $ VStream $ IndexSeqMap $ \i -> - return $ VWord e $ return $ LargeBitsVal e $ IndexSeqMap $ \j -> + (Nat p, e) | isTBit a -> do + val' <- sDelay sym (fromWordVal "splitV" <$> val) + return $ VSeq p $ indexSeqMap $ \i -> + VWord e <$> (extractWordVal sym e ((p-i-1)*e) =<< val') + (Inf, e) | isTBit a -> do + val' <- sDelay sym (fromSeq "splitV" =<< val) + return $ VStream $ indexSeqMap $ \i -> + VWord e <$> bitmapWordVal sym e (indexSeqMap $ \j -> let idx = i*e + toInteger j in idx `seq` do xs <- val' - lookupSeqMap xs idx - (Nat p, Nat e) -> do - val' <- sDelay sym (fromSeq "ecSplitV" =<< val) - return $ VSeq p $ IndexSeqMap $ \i -> - return $ VSeq e $ IndexSeqMap $ \j -> do + fromVBit <$> lookupSeqMap xs idx) + (Nat p, e) -> do + val' <- sDelay sym (fromSeq "splitV" =<< val) + return $ VSeq p $ indexSeqMap $ \i -> + return $ VSeq e $ indexSeqMap $ \j -> do xs <- val' lookupSeqMap xs (e * i + j) - (Inf , Nat e) -> do - val' <- sDelay sym (fromSeq "ecSplitV" =<< val) - return $ VStream $ IndexSeqMap $ \i -> - return $ VSeq e $ IndexSeqMap $ \j -> do + (Inf , e) -> do + val' <- sDelay sym (fromSeq "splitV" =<< val) + return $ VStream $ indexSeqMap $ \i -> + return $ VSeq e $ indexSeqMap $ \j -> do xs <- val' lookupSeqMap xs (e * i + j) - _ -> evalPanic "splitV" ["invalid type arguments to split"] + {-# INLINE reverseV #-} reverseV :: forall sym. Backend sym => sym -> - GenValue sym -> + Integer -> + TValue -> + SEval sym (GenValue sym) -> SEval sym (GenValue sym) -reverseV _ (VSeq n xs) = - return $ VSeq n $ reverseSeqMap n xs -reverseV sym (VWord n x) = return (VWord n (revword <$> x)) - where - revword wv = - let m = wordValueSize sym wv in - LargeBitsVal m $ reverseSeqMap m $ asBitsMap sym wv -reverseV _ _ = - evalPanic "reverseV" ["Not a finite sequence"] +reverseV sym n TVBit val = + do w <- delayWordValue sym n (reverseWordVal sym . fromWordVal "reverseV" =<< val) + pure (VWord n w) + +reverseV sym n _a val = + do xs <- delaySeqMap sym (reverseSeqMap n <$> (fromSeq "reverseV" =<< val)) + pure (VSeq n xs) + + {-# INLINE transposeV #-} transposeV :: @@ -1196,28 +1133,28 @@ SEval sym (GenValue sym) transposeV sym a b c xs | isTBit c, Nat na <- a = -- Fin a => [a][b]Bit -> [b][a]Bit - return $ bseq $ IndexSeqMap $ \bi -> - return $ VWord na $ return $ LargeBitsVal na $ IndexSeqMap $ \ai -> + return $ bseq $ indexSeqMap $ \bi -> + VWord na <$> bitmapWordVal sym na (indexSeqMap $ \ai -> do xs' <- fromSeq "transposeV" xs ys <- lookupSeqMap xs' ai case ys of - VStream ys' -> lookupSeqMap ys' bi - VWord _ wv -> VBit <$> (flip (indexWordValue sym) bi =<< wv) - _ -> evalPanic "transpose" ["expected sequence of bits"] + VStream ys' -> fromVBit <$> lookupSeqMap ys' bi + VWord _ wv -> indexWordValue sym wv bi + _ -> evalPanic "transpose" ["expected sequence of bits"]) | isTBit c, Inf <- a = -- [inf][b]Bit -> [b][inf]Bit - return $ bseq $ IndexSeqMap $ \bi -> - return $ VStream $ IndexSeqMap $ \ai -> + return $ bseq $ indexSeqMap $ \bi -> + return $ VStream $ indexSeqMap $ \ai -> do xs' <- fromSeq "transposeV" xs ys <- lookupSeqMap xs' ai case ys of VStream ys' -> lookupSeqMap ys' bi - VWord _ wv -> VBit <$> (flip (indexWordValue sym) bi =<< wv) + VWord _ wv -> VBit <$> indexWordValue sym wv bi _ -> evalPanic "transpose" ["expected sequence of bits"] | otherwise = -- [a][b]c -> [b][a]c - return $ bseq $ IndexSeqMap $ \bi -> - return $ aseq $ IndexSeqMap $ \ai -> do + return $ bseq $ indexSeqMap $ \bi -> + return $ aseq $ indexSeqMap $ \ai -> do xs' <- fromSeq "transposeV 1" xs ys <- fromSeq "transposeV 2" =<< lookupSeqMap xs' ai z <- lookupSeqMap ys bi @@ -1239,54 +1176,52 @@ ccatV :: Backend sym => sym -> - Nat' -> + Integer -> Nat' -> TValue -> - (GenValue sym) -> - (GenValue sym) -> + SEval sym (GenValue sym) -> + SEval sym (GenValue sym) -> SEval sym (GenValue sym) -ccatV sym _front _back _elty (VWord m l) (VWord n r) = - return $ VWord (m+n) (join (joinWordVal sym <$> l <*> r)) +-- Finite bitvectors +ccatV sym front (Nat back) TVBit l r = + do ml <- isReady sym l + mr <- isReady sym r + case (ml, mr) of + (Just l', Just r') -> + VWord (front+back) <$> + joinWordVal sym (fromWordVal "ccatV left" l') (fromWordVal "ccatV right" r') + _ -> + VWord (front+back) <$> delayWordValue sym (front+back) + (do l' <- fromWordVal "ccatV left" <$> l + r' <- fromWordVal "ccatV right" <$> r + joinWordVal sym l' r') -ccatV sym _front _back _elty (VWord m l) (VStream r) = do - l' <- sDelay sym l - return $ VStream $ IndexSeqMap $ \i -> - if i < m then - VBit <$> (flip (indexWordValue sym) i =<< l') - else - lookupSeqMap r (i-m) +-- Infinite bitstream +ccatV sym front Inf TVBit l r = + do l'' <- sDelay sym (asBitsMap sym . fromWordVal "ccatV left" <$> l) + r'' <- sDelay sym (fromSeq "ccatV right" =<< r) + pure $ VStream $ indexSeqMap $ \i -> + if i < front then do + ls <- l'' + VBit <$> lookupSeqMap ls i + else do + rs <- r'' + lookupSeqMap rs (i-front) -ccatV sym front back elty l r = do - l'' <- sDelay sym (fromSeq "ccatV left" l) - r'' <- sDelay sym (fromSeq "ccatV right" r) - let Nat n = front - mkSeq (evalTF TCAdd [front,back]) elty <$> return (IndexSeqMap $ \i -> - if i < n then do - ls <- l'' - lookupSeqMap ls i - else do - rs <- r'' - lookupSeqMap rs (i-n)) +-- streams/sequences of nonbits +ccatV sym front back elty l r = + do l'' <- sDelay sym (fromSeq "ccatV left" =<< l) + r'' <- sDelay sym (fromSeq "ccatV right" =<< r) + mkSeq sym (evalTF TCAdd [Nat front,back]) elty $ indexSeqMap $ \i -> + if i < front then do + ls <- l'' + lookupSeqMap ls i + else do + rs <- r'' + lookupSeqMap rs (i-front) -{-# INLINE wordValLogicOp #-} -wordValLogicOp :: - Backend sym => - sym -> - (SBit sym -> SBit sym -> SEval sym (SBit sym)) -> - (SWord sym -> SWord sym -> SEval sym (SWord sym)) -> - WordValue sym -> - WordValue sym -> - SEval sym (WordValue sym) -wordValLogicOp _sym _ wop (WordVal w1) (WordVal w2) = WordVal <$> wop w1 w2 - -wordValLogicOp sym bop _ w1 w2 = LargeBitsVal (wordValueSize sym w1) <$> zs - where zs = memoMap sym $ IndexSeqMap $ \i -> join (op <$> (lookupSeqMap xs i) <*> (lookupSeqMap ys i)) - xs = asBitsMap sym w1 - ys = asBitsMap sym w2 - op x y = VBit <$> (bop (fromVBit x) (fromVBit y)) - {-# SPECIALIZE logicBinary :: Concrete -> (SBit Concrete -> SBit Concrete -> SEval Concrete (SBit Concrete)) -> @@ -1325,20 +1260,19 @@ TVSeq w aty -- words | isTBit aty - -> do v <- sDelay sym $ join - (wordValLogicOp sym opb opw <$> - fromWordVal "logicBinary l" l <*> - fromWordVal "logicBinary r" r) - return $ VWord w v + -> VWord w <$> delayWordValue sym w + (wordValLogicOp sym opb opw + (fromWordVal "logicBinary l" l) + (fromWordVal "logicBinary r" r)) -- finite sequences | otherwise -> VSeq w <$> - (join (zipSeqMap sym (loop aty) <$> + (join (zipSeqMap sym (loop aty) (Nat w) <$> (fromSeq "logicBinary left" l) <*> (fromSeq "logicBinary right" r))) TVStream aty -> - VStream <$> (join (zipSeqMap sym (loop aty) <$> + VStream <$> (join (zipSeqMap sym (loop aty) Inf <$> (fromSeq "logicBinary left" l) <*> (fromSeq "logicBinary right" r))) @@ -1362,18 +1296,6 @@ TVNewtype {} -> evalPanic "logicBinary" [ "Newtype not in `Logic`" ] -{-# INLINE wordValUnaryOp #-} -wordValUnaryOp :: - Backend sym => - sym -> - (SBit sym -> SEval sym (SBit sym)) -> - (SWord sym -> SEval sym (SWord sym)) -> - WordValue sym -> - SEval sym (WordValue sym) -wordValUnaryOp _ _ wop (WordVal w) = WordVal <$> (wop w) -wordValUnaryOp sym bop _ (LargeBitsVal n xs) = LargeBitsVal n <$> mapSeqMap sym f xs - where f x = VBit <$> (bop (fromVBit x)) - {-# SPECIALIZE logicUnary :: Concrete -> (SBit Concrete -> SEval Concrete (SBit Concrete)) -> @@ -1405,16 +1327,15 @@ TVSeq w ety -- words | isTBit ety - -> do v <- sDelay sym (wordValUnaryOp sym opb opw =<< fromWordVal "logicUnary" val) - return $ VWord w v + -> VWord w <$> delayWordValue sym w (wordValUnaryOp sym opb opw (fromWordVal "logicUnary" val)) -- finite sequences | otherwise - -> VSeq w <$> (mapSeqMap sym (loop ety) =<< fromSeq "logicUnary" val) + -> VSeq w <$> (mapSeqMap sym (loop ety) (Nat w) =<< fromSeq "logicUnary" val) -- streams TVStream ety -> - VStream <$> (mapSeqMap sym (loop ety) =<< fromSeq "logicUnary" val) + VStream <$> (mapSeqMap sym (loop ety) Inf =<< fromSeq "logicUnary" val) TVTuple etys -> do as <- mapM (sDelay sym) (fromVTuple val) @@ -1433,32 +1354,7 @@ TVNewtype {} -> evalPanic "logicUnary" [ "Newtype not in `Logic`" ] -{-# SPECIALIZE bitsValueLessThan :: - Concrete -> - Integer -> - [SBit Concrete] -> - Integer -> - SEval Concrete (SBit Concrete) - #-} -bitsValueLessThan :: - Backend sym => - sym -> - Integer {- ^ bit-width -} -> - [SBit sym] {- ^ big-endian list of index bits -} -> - Integer {- ^ Upper bound to test against -} -> - SEval sym (SBit sym) -bitsValueLessThan sym _w [] _n = pure $ bitLit sym False -bitsValueLessThan sym w (b:bs) n - | nbit = - do notb <- bitComplement sym b - bitOr sym notb =<< bitsValueLessThan sym (w-1) bs n - | otherwise = - do notb <- bitComplement sym b - bitAnd sym notb =<< bitsValueLessThan sym (w-1) bs n - where - nbit = testBit n (fromInteger (w-1)) - {-# INLINE assertIndexInBounds #-} assertIndexInBounds :: Backend sym => @@ -1486,30 +1382,8 @@ -- Can't index out of bounds for a sequence that is -- longer than the expressible index values -assertIndexInBounds sym (Nat n) (Right idx) - | n >= 2^(wordValueSize sym idx) - = return () - --- If the index is concrete, test it directly -assertIndexInBounds sym (Nat n) (Right (WordVal idx)) - | Just (_w,i) <- wordAsLit sym idx - = unless (i < n) (raiseError sym (InvalidIndex (Just i))) - --- If the index is a packed word, test that it --- is less than the concrete value of n, which --- fits into w bits because of the above test. -assertIndexInBounds sym (Nat n) (Right (WordVal idx)) = - do n' <- wordLit sym (wordLen sym idx) n - p <- wordLessThan sym idx n' - assertSideCondition sym p (InvalidIndex Nothing) - --- If the index is an unpacked word, force all the bits --- and compute the unsigned less-than test directly. -assertIndexInBounds sym (Nat n) (Right (LargeBitsVal w bits)) = - do bitsList <- traverse (fromVBit <$>) (enumerateSeqMap w bits) - p <- bitsValueLessThan sym w bitsList n - assertSideCondition sym p (InvalidIndex Nothing) - +assertIndexInBounds sym (Nat n) (Right idx) = + assertWordValueInBounds sym n idx -- | Indexing operations. @@ -1517,11 +1391,11 @@ indexPrim :: Backend sym => sym -> - (Nat' -> TValue -> SeqMap sym -> TValue -> SInteger sym -> SEval sym (GenValue sym)) -> - (Nat' -> TValue -> SeqMap sym -> TValue -> [SBit sym] -> SEval sym (GenValue sym)) -> - (Nat' -> TValue -> SeqMap sym -> TValue -> SWord sym -> SEval sym (GenValue sym)) -> + IndexDirection -> + (Nat' -> TValue -> SeqMap sym (GenValue sym) -> TValue -> SInteger sym -> SEval sym (GenValue sym)) -> + (Nat' -> TValue -> SeqMap sym (GenValue sym) -> TValue -> Integer -> [IndexSegment sym] -> SEval sym (GenValue sym)) -> Prim sym -indexPrim sym int_op bits_op word_op = +indexPrim sym dir int_op word_op = PNumPoly \len -> PTyPoly \eltTy -> PTyPoly \ix -> @@ -1529,16 +1403,19 @@ PFun \idx -> PPrim do vs <- xs >>= \case - VWord _ w -> w >>= \w' -> return $ IndexSeqMap (\i -> VBit <$> indexWordValue sym w' i) + VWord _ w -> return $ indexSeqMap (\i -> VBit <$> indexWordValue sym w i) VSeq _ vs -> return vs VStream vs -> return vs _ -> evalPanic "Expected sequence value" ["indexPrim"] - idx' <- asIndex sym "index" ix =<< idx + let vs' = case (len, dir) of + (_ , IndexForward) -> vs + (Nat n, IndexBackward) -> reverseSeqMap n vs + (Inf , IndexBackward) -> evalPanic "Expected finite sequence" ["!"] + idx' <- asIndex sym "index" ix <$> idx assertIndexInBounds sym len idx' case idx' of - Left i -> int_op len eltTy vs ix i - Right (WordVal w') -> word_op len eltTy vs ix w' - Right (LargeBitsVal m bs) -> bits_op len eltTy vs ix =<< traverse (fromVBit <$>) (enumerateSeqMap m bs) + Left i -> int_op len eltTy vs' ix i + Right w -> word_op len eltTy vs' ix (wordValueSize sym w) =<< enumerateIndexSegments sym w {-# INLINE updatePrim #-} @@ -1546,7 +1423,7 @@ Backend sym => sym -> (Nat' -> TValue -> WordValue sym -> Either (SInteger sym) (WordValue sym) -> SEval sym (GenValue sym) -> SEval sym (WordValue sym)) -> - (Nat' -> TValue -> SeqMap sym -> Either (SInteger sym) (WordValue sym) -> SEval sym (GenValue sym) -> SEval sym (SeqMap sym)) -> + (Nat' -> TValue -> SeqMap sym (GenValue sym) -> Either (SInteger sym) (WordValue sym) -> SEval sym (GenValue sym) -> SEval sym (SeqMap sym (GenValue sym))) -> Prim sym updatePrim sym updateWord updateSeq = PNumPoly \len -> @@ -1556,17 +1433,17 @@ PFun \idx -> PFun \val -> PPrim - do idx' <- asIndex sym "update" ix =<< idx + do idx' <- asIndex sym "update" ix <$> idx assertIndexInBounds sym len idx' - xs >>= \case - VWord l w -> do w' <- sDelay sym w - return $ VWord l (w' >>= \w'' -> updateWord len eltTy w'' idx' val) - VSeq l vs -> VSeq l <$> updateSeq len eltTy vs idx' val - VStream vs -> VStream <$> updateSeq len eltTy vs idx' val - _ -> evalPanic "Expected sequence value" ["updatePrim"] + case (len, eltTy) of + (Nat n, TVBit) -> VWord n <$> delayWordValue sym n + (do w <- fromWordVal "updatePrim" <$> xs; updateWord len eltTy w idx' val) + (Nat n, _ ) -> VSeq n <$> delaySeqMap sym + (do vs <- fromSeq "updatePrim" =<< xs; updateSeq len eltTy vs idx' val) + (Inf , _ ) -> VStream <$> delaySeqMap sym + (do vs <- fromSeq "updatePrim" =<< xs; updateSeq len eltTy vs idx' val) {-# INLINE fromToV #-} - -- @[ 0 .. 10 ]@ fromToV :: Backend sym => sym -> Prim sym fromToV sym = @@ -1578,26 +1455,10 @@ case (first, lst) of (Nat first', Nat lst') -> let len = 1 + (lst' - first') - in VSeq len $ IndexSeqMap $ \i -> f (first' + i) + in VSeq len $ indexSeqMap $ \i -> f (first' + i) _ -> evalPanic "fromToV" ["invalid arguments"] -{-# INLINE fromToLessThanV #-} - --- @[ 0 .. <10 ]@ -fromToLessThanV :: Backend sym => sym -> Prim sym -fromToLessThanV sym = - PFinPoly \first -> - PNumPoly \bound -> - PTyPoly \ty -> - PVal - let !f = mkLit sym ty - ss = IndexSeqMap $ \i -> f (first + i) - in case bound of - Inf -> VStream ss - Nat bound' -> VSeq (bound' - first) ss - {-# INLINE fromThenToV #-} - -- @[ 0, 1 .. 10 ]@ fromThenToV :: Backend sym => sym -> Prim sym fromThenToV sym = @@ -1611,9 +1472,78 @@ case (first, next, lst, len) of (Nat first', Nat next', Nat _lst', Nat len') -> let diff = next' - first' - in VSeq len' $ IndexSeqMap $ \i -> f (first' + i*diff) + in VSeq len' $ indexSeqMap $ \i -> f (first' + i*diff) _ -> evalPanic "fromThenToV" ["invalid arguments"] +{-# INLINE fromToLessThanV #-} +-- @[ 0 .. <10 ]@ +fromToLessThanV :: Backend sym => sym -> Prim sym +fromToLessThanV sym = + PFinPoly \first -> + PNumPoly \bound -> + PTyPoly \ty -> + PVal + let !f = mkLit sym ty + ss = indexSeqMap $ \i -> f (first + i) + in case bound of + Inf -> VStream ss + Nat bound' -> VSeq (bound' - first) ss + +{-# INLINE fromToByV #-} +-- @[ 0 .. 10 by 2 ]@ +fromToByV :: Backend sym => sym -> Prim sym +fromToByV sym = + PFinPoly \first -> + PFinPoly \lst -> + PFinPoly \stride -> + PTyPoly \ty -> + PVal + let !f = mkLit sym ty + ss = indexSeqMap $ \i -> f (first + i*stride) + in VSeq (1 + ((lst - first) `div` stride)) ss + +{-# INLINE fromToByLessThanV #-} +-- @[ 0 .. <10 by 2 ]@ +fromToByLessThanV :: Backend sym => sym -> Prim sym +fromToByLessThanV sym = + PFinPoly \first -> + PNumPoly \bound -> + PFinPoly \stride -> + PTyPoly \ty -> + PVal + let !f = mkLit sym ty + ss = indexSeqMap $ \i -> f (first + i*stride) + in case bound of + Inf -> VStream ss + Nat bound' -> VSeq ((bound' - first + stride - 1) `div` stride) ss + + +{-# INLINE fromToDownByV #-} +-- @[ 10 .. 0 down by 2 ]@ +fromToDownByV :: Backend sym => sym -> Prim sym +fromToDownByV sym = + PFinPoly \first -> + PFinPoly \lst -> + PFinPoly \stride -> + PTyPoly \ty -> + PVal + let !f = mkLit sym ty + ss = indexSeqMap $ \i -> f (first - i*stride) + in VSeq (1 + ((first - lst) `div` stride)) ss + +{-# INLINE fromToDownByGreaterThanV #-} +-- @[ 10 .. >0 down by 2 ]@ +fromToDownByGreaterThanV :: Backend sym => sym -> Prim sym +fromToDownByGreaterThanV sym = + PFinPoly \first -> + PFinPoly \bound -> + PFinPoly \stride -> + PTyPoly \ty -> + PVal + let !f = mkLit sym ty + ss = indexSeqMap $ \i -> f (first - i*stride) + in VSeq ((first - bound + stride - 1) `div` stride) ss + {-# INLINE infFromV #-} infFromV :: Backend sym => sym -> Prim sym infFromV sym = @@ -1621,7 +1551,7 @@ PFun \x -> PPrim do mx <- sDelay sym x - return $ VStream $ IndexSeqMap $ \i -> + return $ VStream $ indexSeqMap $ \i -> do x' <- mx i' <- integerLit sym i addV sym ty x' =<< intV sym i' ty @@ -1638,37 +1568,14 @@ y <- next d <- subV sym ty y x pure (x,d)) - return $ VStream $ IndexSeqMap $ \i -> do + return $ VStream $ indexSeqMap $ \i -> do (x,d) <- mxd i' <- integerLit sym i addV sym ty x =<< mulV sym ty d =<< intV sym i' ty -- Shifting --------------------------------------------------- -barrelShifter :: Backend sym => - sym -> - (SeqMap sym -> Integer -> SEval sym (SeqMap sym)) - {- ^ concrete shifting operation -} -> - SeqMap sym {- ^ initial value -} -> - [SBit sym] {- ^ bits of shift amount, in big-endian order -} -> - SEval sym (SeqMap sym) -barrelShifter sym shift_op = go - where - go x [] = return x - go x (b:bs) - | Just True <- bitAsLit sym b - = do x_shft <- shift_op x (2 ^ length bs) - go x_shft bs - - | Just False <- bitAsLit sym b - = do go x bs - - | otherwise - = do x_shft <- shift_op x (2 ^ length bs) - x' <- memoMap sym (mergeSeqMap sym b x_shft x) - go x' bs - {-# INLINE shiftLeftReindex #-} shiftLeftReindex :: Nat' -> Integer -> Integer -> Maybe Integer shiftLeftReindex sz i shft = @@ -1695,30 +1602,8 @@ Inf -> evalPanic "cannot rotate infinite sequence" [] Nat n -> Just ((i+n-shft) `mod` n) --- | Compute the list of bits in an integer in big-endian order. --- Fails if neither the sequence length nor the type value --- provide an upper bound for the integer. -enumerateIntBits :: Backend sym => - sym -> - Nat' -> - TValue -> - SInteger sym -> - SEval sym [SBit sym] -enumerateIntBits sym (Nat n) _ idx = enumerateIntBits' sym n idx -enumerateIntBits _sym Inf _ _ = liftIO (X.throw (UnsupportedSymbolicOp "unbounded integer shifting")) --- | Compute the list of bits in an integer in big-endian order. --- The integer argument is a concrete upper bound for --- the symbolic integer. -enumerateIntBits' :: Backend sym => - sym -> - Integer -> - SInteger sym -> - SEval sym [SBit sym] -enumerateIntBits' sym n idx = - do w <- wordFromInt sym (widthInteger n) idx - unpackWord sym w - +{-# INLINE logicShift #-} -- | Generic implementation of shifting. -- Uses the provided word-level operation to perform the shift, when -- possible. Otherwise falls back on a barrel shifter that uses @@ -1749,16 +1634,19 @@ PFun \y -> PPrim do xs' <- xs - y' <- asIndex sym "shift" ix =<< y + y' <- asIndex sym "shift" ix <$> y case y' of Left int_idx -> do pneg <- intLessThan sym int_idx =<< integerLit sym 0 iteValue sym pneg - (intShifter sym nm wopNeg reindexNeg m ix a xs' =<< shrinkRange sym m ix =<< intNegate sym int_idx) - (intShifter sym nm wopPos reindexPos m ix a xs' =<< shrinkRange sym m ix int_idx) + (intShifter sym nm wopNeg reindexNeg m a xs' =<< shrinkRange sym m ix =<< intNegate sym int_idx) + (intShifter sym nm wopPos reindexPos m a xs' =<< shrinkRange sym m ix int_idx) Right idx -> wordShifter sym nm wopPos reindexPos m a xs' idx + + +{-# INLINE intShifter #-} intShifter :: Backend sym => sym -> String -> @@ -1766,36 +1654,18 @@ (Nat' -> Integer -> Integer -> Maybe Integer) -> Nat' -> TValue -> - TValue -> GenValue sym -> SInteger sym -> SEval sym (GenValue sym) -intShifter sym nm wop reindex m ix a xs idx = - do let shiftOp vs shft = - memoMap sym $ IndexSeqMap $ \i -> - case reindex m i shft of - Nothing -> zeroV sym a - Just i' -> lookupSeqMap vs i' - case xs of - VWord w x -> - return $ VWord w $ do - x >>= \case - WordVal x' -> WordVal <$> (wop x' =<< wordFromInt sym w idx) - LargeBitsVal n bs0 -> - do idx_bits <- enumerateIntBits sym m ix idx - LargeBitsVal n <$> barrelShifter sym shiftOp bs0 idx_bits - - VSeq w vs0 -> - do idx_bits <- enumerateIntBits sym m ix idx - VSeq w <$> barrelShifter sym shiftOp vs0 idx_bits - - VStream vs0 -> - do idx_bits <- enumerateIntBits sym m ix idx - VStream <$> barrelShifter sym shiftOp vs0 idx_bits - - _ -> evalPanic "expected sequence value in shift operation" [nm] +intShifter sym nm wop reindex m a xs idx = + case xs of + VWord w x -> VWord w <$> shiftWordByInteger sym wop (reindex m) x idx + VSeq w vs -> VSeq w <$> shiftSeqByInteger sym (mergeValue sym) (reindex m) (zeroV sym a) m vs idx + VStream vs -> VStream <$> shiftSeqByInteger sym (mergeValue sym) (reindex m) (zeroV sym a) m vs idx + _ -> evalPanic "expected sequence value in shift operation" [nm] +{-# INLINE wordShifter #-} wordShifter :: Backend sym => sym -> String -> @@ -1807,31 +1677,15 @@ WordValue sym -> SEval sym (GenValue sym) wordShifter sym nm wop reindex m a xs idx = - let shiftOp vs shft = - memoMap sym $ IndexSeqMap $ \i -> - case reindex m i shft of - Nothing -> zeroV sym a - Just i' -> lookupSeqMap vs i' - in case xs of - VWord w x -> - return $ VWord w $ do - x >>= \case - WordVal x' -> WordVal <$> (wop x' =<< asWordVal sym idx) - LargeBitsVal n bs0 -> - do idx_bits <- enumerateWordValue sym idx - LargeBitsVal n <$> barrelShifter sym shiftOp bs0 idx_bits + case xs of + VWord w x -> VWord w <$> shiftWordByWord sym wop (reindex m) x idx + VSeq w vs -> VSeq w <$> shiftSeqByWord sym (mergeValue sym) (reindex m) (zeroV sym a) (Nat w) vs idx + VStream vs -> VStream <$> shiftSeqByWord sym (mergeValue sym) (reindex m) (zeroV sym a) Inf vs idx + _ -> evalPanic "expected sequence value in shift operation" [nm] - VSeq w vs0 -> - do idx_bits <- enumerateWordValue sym idx - VSeq w <$> barrelShifter sym shiftOp vs0 idx_bits - VStream vs0 -> - do idx_bits <- enumerateWordValue sym idx - VStream <$> barrelShifter sym shiftOp vs0 idx_bits - _ -> evalPanic "expected sequence value in shift operation" [nm] - - +{-# INLINE shiftShrink #-} shiftShrink :: Backend sym => sym -> Nat' -> TValue -> SInteger sym -> SEval sym (SInteger sym) shiftShrink _sym Inf _ x = return x shiftShrink sym (Nat w) _ x = @@ -1839,6 +1693,7 @@ p <- intLessThan sym w' x iteInteger sym p w' x +{-# INLINE rotateShrink #-} rotateShrink :: Backend sym => sym -> Nat' -> TValue -> SInteger sym -> SEval sym (SInteger sym) rotateShrink _sym Inf _ _ = panic "rotateShrink" ["expected finite sequence in rotate"] rotateShrink sym (Nat 0) _ _ = integerLit sym 0 @@ -1846,6 +1701,30 @@ do w' <- integerLit sym w intMod sym x w' +{-# INLINE sshrV #-} +sshrV :: Backend sym => sym -> Prim sym +sshrV sym = + PFinPoly \n -> + PTyPoly \ix -> + PWordFun \x -> + PStrict \y -> + PPrim $ + case asIndex sym ">>$" ix y of + Left i -> + do pneg <- intLessThan sym i =<< integerLit sym 0 + VWord n <$> mergeWord' sym + pneg + (do i' <- shiftShrink sym (Nat n) ix =<< intNegate sym i + amt <- wordFromInt sym n i' + wordVal <$> wordShiftLeft sym x amt) + (do i' <- shiftShrink sym (Nat n) ix i + amt <- wordFromInt sym n i' + wordVal <$> wordSignedShiftRight sym x amt) + + Right wv -> + do amt <- asWordVal sym wv + VWord n . wordVal <$> wordSignedShiftRight sym x amt + -- Miscellaneous --------------------------------------------------------------- {-# SPECIALIZE errorV :: @@ -1860,38 +1739,9 @@ TValue -> String -> SEval sym (GenValue sym) -errorV sym ty0 msg = - do stk <- sGetCallStack sym - loop stk ty0 - where - err stk = sWithCallStack sym stk (cryUserError sym msg) - - loop stk = \case - TVBit -> err stk - TVInteger -> err stk - TVIntMod _ -> err stk - TVRational -> err stk - TVArray{} -> err stk - TVFloat {} -> err stk - - -- sequences - TVSeq w ety - | isTBit ety -> return $ VWord w $ return $ LargeBitsVal w $ IndexSeqMap $ \_ -> err stk - | otherwise -> return $ VSeq w $ IndexSeqMap $ \_ -> loop stk ety - - TVStream ety -> return $ VStream $ IndexSeqMap $ \_ -> loop stk ety - - -- functions - TVFun _ bty -> lam sym (\ _ -> loop stk bty) - - -- tuples - TVTuple tys -> return $ VTuple (map (\t -> loop stk t) tys) - - -- records - TVRec fields -> return $ VRecord $ fmap (\t -> loop stk t) $ fields - - TVAbstract {} -> err stk - TVNewtype {} -> err stk +errorV sym _ty msg = + do stk <- sGetCallStack sym + sWithCallStack sym stk (cryUserError sym msg) {-# INLINE valueToChar #-} @@ -1900,7 +1750,7 @@ -- Otherwise, return a '?' character valueToChar :: Backend sym => sym -> GenValue sym -> SEval sym Char valueToChar sym (VWord 8 wval) = - do w <- asWordVal sym =<< wval + do w <- asWordVal sym wval pure $! fromMaybe '?' (wordAsChar sym w) valueToChar _ _ = evalPanic "valueToChar" ["Not an 8-bit bitvector"] @@ -1910,90 +1760,7 @@ valueToString sym (VSeq n vals) = traverse (valueToChar sym =<<) (enumerateSeqMap n vals) valueToString _ _ = evalPanic "valueToString" ["Not a finite sequence"] --- Merge and if/then/else -{-# INLINE iteValue #-} -iteValue :: Backend sym => - sym -> - SBit sym -> - SEval sym (GenValue sym) -> - SEval sym (GenValue sym) -> - SEval sym (GenValue sym) -iteValue sym b x y - | Just True <- bitAsLit sym b = x - | Just False <- bitAsLit sym b = y - | otherwise = mergeValue' sym b x y - -{-# INLINE mergeWord #-} -mergeWord :: Backend sym => - sym -> - SBit sym -> - WordValue sym -> - WordValue sym -> - SEval sym (WordValue sym) -mergeWord sym c (WordVal w1) (WordVal w2) = - WordVal <$> iteWord sym c w1 w2 -mergeWord sym c w1 w2 = - LargeBitsVal (wordValueSize sym w1) <$> memoMap sym (mergeSeqMap sym c (asBitsMap sym w1) (asBitsMap sym w2)) - -{-# INLINE mergeWord' #-} -mergeWord' :: Backend sym => - sym -> - SBit sym -> - SEval sym (WordValue sym) -> - SEval sym (WordValue sym) -> - SEval sym (WordValue sym) -mergeWord' sym = mergeEval sym (mergeWord sym) - -{-# INLINE mergeValue' #-} -mergeValue' :: Backend sym => - sym -> - SBit sym -> - SEval sym (GenValue sym) -> - SEval sym (GenValue sym) -> - SEval sym (GenValue sym) -mergeValue' sym = mergeEval sym (mergeValue sym) - -mergeValue :: Backend sym => - sym -> - SBit sym -> - GenValue sym -> - GenValue sym -> - SEval sym (GenValue sym) -mergeValue sym c v1 v2 = - case (v1, v2) of - (VRecord fs1 , VRecord fs2 ) -> - do let res = zipRecords (\_lbl -> mergeValue' sym c) fs1 fs2 - case res of - Left f -> panic "Cryptol.Eval.Generic" [ "mergeValue: incompatible record values", show f ] - Right r -> pure (VRecord r) - (VTuple vs1 , VTuple vs2 ) | length vs1 == length vs2 -> - pure $ VTuple $ zipWith (mergeValue' sym c) vs1 vs2 - (VBit b1 , VBit b2 ) -> VBit <$> iteBit sym c b1 b2 - (VInteger i1 , VInteger i2 ) -> VInteger <$> iteInteger sym c i1 i2 - (VRational q1, VRational q2) -> VRational <$> iteRational sym c q1 q2 - (VFloat f1 , VFloat f2) -> VFloat <$> iteFloat sym c f1 f2 - (VWord n1 w1 , VWord n2 w2 ) | n1 == n2 -> pure $ VWord n1 $ mergeWord' sym c w1 w2 - (VSeq n1 vs1 , VSeq n2 vs2 ) | n1 == n2 -> VSeq n1 <$> memoMap sym (mergeSeqMap sym c vs1 vs2) - (VStream vs1 , VStream vs2 ) -> VStream <$> memoMap sym (mergeSeqMap sym c vs1 vs2) - (f1@VFun{} , f2@VFun{} ) -> lam sym $ \x -> mergeValue' sym c (fromVFun sym f1 x) (fromVFun sym f2 x) - (f1@VPoly{} , f2@VPoly{} ) -> tlam sym $ \x -> mergeValue' sym c (fromVPoly sym f1 x) (fromVPoly sym f2 x) - (_ , _ ) -> panic "Cryptol.Eval.Generic" - [ "mergeValue: incompatible values" ] - -{-# INLINE mergeSeqMap #-} -mergeSeqMap :: Backend sym => - sym -> - SBit sym -> - SeqMap sym -> - SeqMap sym -> - SeqMap sym -mergeSeqMap sym c x y = - IndexSeqMap $ \i -> - iteValue sym c (lookupSeqMap x i) (lookupSeqMap y i) - - - foldlV :: Backend sym => sym -> Prim sym foldlV sym = PNumPoly \_n -> @@ -2005,7 +1772,7 @@ PPrim case v of VSeq n m -> go0 f z (enumerateSeqMap n m) - VWord _n wv -> go0 f z . map (pure . VBit) =<< (enumerateWordValue sym =<< wv) + VWord _n wv -> go0 f z . map (pure . VBit) =<< (enumerateWordValue sym wv) _ -> panic "Cryptol.Eval.Generic.foldlV" ["Expected finite sequence"] where go0 _f a [] = a @@ -2029,7 +1796,7 @@ PPrim case v of VSeq n m -> go0 f z (enumerateSeqMap n m) - VWord _n wv -> go0 f z . map (pure . VBit) =<< (enumerateWordValue sym =<< wv) + VWord _n wv -> go0 f z . map (pure . VBit) =<< (enumerateWordValue sym wv) _ -> panic "Cryptol.Eval.Generic.foldlV" ["Expected finite sequence"] where go0 _f a [] = a @@ -2081,9 +1848,9 @@ xs' <- xs case xs' of VWord n w -> - do m <- asBitsMap sym <$> w - m' <- sparkParMap sym f' n m - pure (VWord n (pure (LargeBitsVal n m'))) + do let m = asBitsMap sym w + m' <- sparkParMap sym (\x -> f' (VBit <$> x)) n m + VWord n <$> (bitmapWordVal sym n (fromVBit <$> m')) VSeq n m -> VSeq n <$> sparkParMap sym f' n m @@ -2093,12 +1860,12 @@ sparkParMap :: Backend sym => sym -> - (SEval sym (GenValue sym) -> SEval sym (GenValue sym)) -> + (SEval sym a -> SEval sym (GenValue sym)) -> Integer -> - SeqMap sym -> - SEval sym (SeqMap sym) + SeqMap sym a -> + SEval sym (SeqMap sym (GenValue sym)) sparkParMap sym f n m = - finiteSeqMap <$> mapM (sSpark sym . g) (enumerateSeqMap n m) + finiteSeqMap sym <$> mapM (sSpark sym . g) (enumerateSeqMap n m) where g x = do z <- sDelay sym (f x) @@ -2149,9 +1916,8 @@ , "fpPosInf" ~> fpConst (fpPosInf sym) , "fpFromBits" ~> PFinPoly \e -> PFinPoly \p -> PWordFun \w -> PPrim (VFloat <$> fpFromBits sym e p w) - , "fpToBits" ~> PFinPoly \e -> PFinPoly \p -> PFloatFun \x -> PVal - $ VWord (e+p) - $ WordVal <$> fpToBits sym x + , "fpToBits" ~> PFinPoly \e -> PFinPoly \p -> PFloatFun \x -> PPrim + (VWord (e+p) . wordVal <$> fpToBits sym x) , "=.=" ~> PFinPoly \_ -> PFinPoly \_ -> PFloatFun \x -> PFloatFun \y -> PPrim (VBit <$> fpLogicalEq sym x y) @@ -2272,6 +2038,9 @@ unary (roundToEvenV sym)) -- Bitvector specific operations + , ("toSignedInteger" + , {-# SCC "Prelude::toSignedInteger" #-} + toSignedIntegerV sym) , ("/$" , {-# SCC "Prelude::(/$)" #-} sdivV sym) , ("%$" , {-# SCC "Prelude::(%$)" #-} @@ -2308,6 +2077,20 @@ , {-# SCC "Prelude::fromToLessThan" #-} fromToLessThanV sym) + , ("fromToBy" , {-# SCC "Prelude::fromToBy" #-} + fromToByV sym) + + , ("fromToByLessThan", + {-# SCC "Prelude::fromToByLessThan" #-} + fromToByLessThanV sym) + + , ("fromToDownBy", {-# SCC "Prelude::fromToDownBy" #-} + fromToDownByV sym) + + , ("fromToDownByGreaterThan" + , {-# SCC "Prelude::fromToDownByGreaterThan" #-} + fromToDownByGreaterThanV sym) + -- Sequence manipulations , ("#" , {-# SCC "Prelude::(#)" #-} PFinPoly \front -> @@ -2315,37 +2098,69 @@ PTyPoly \elty -> PFun \l -> PFun \r -> - PPrim (join (ccatV sym (Nat front) back elty <$> l <*> r))) + PPrim $ ccatV sym front back elty l r) , ("join" , {-# SCC "Prelude::join" #-} PNumPoly \parts -> PFinPoly \each -> PTyPoly \a -> - PStrict \x -> + PFun \x -> PPrim $ joinV sym parts each a x) , ("split" , {-# SCC "Prelude::split" #-} - ecSplitV sym) + PNumPoly \parts -> + PFinPoly \each -> + PTyPoly \a -> + PFun \val -> + PPrim $ splitV sym parts each a val) - , ("splitAt" , {-# SCC "Prelude::splitAt" #-} + , ("take" , {-# SCC "Preldue::take" #-} PNumPoly \front -> - PNumPoly \back -> - PTyPoly \a -> - PStrict \x -> - PPrim $ splitAtV sym front back a x) + PNumPoly \back -> + PTyPoly \a -> + PFun \xs -> + PPrim $ takeV sym front back a xs) + , ("drop" , {-# SCC "Preldue::drop" #-} + PFinPoly \front -> + PNumPoly \back -> + PTyPoly \a -> + PFun \xs -> + PPrim $ dropV sym front back a xs) + , ("reverse" , {-# SCC "Prelude::reverse" #-} - PFinPoly \_a -> - PTyPoly \_b -> - PStrict \xs -> - PPrim $ reverseV sym xs) + PFinPoly \a -> + PTyPoly \b -> + PFun \xs -> + PPrim $ reverseV sym a b xs) , ("transpose" , {-# SCC "Prelude::transpose" #-} PNumPoly \a -> PNumPoly \b -> PTyPoly \c -> - PStrict \xs -> - PPrim $ transposeV sym a b c xs) + PFun \xs -> + PPrim $ transposeV sym a b c =<< xs) + + -- Shifts and rotates + , ("<<" , {-# SCC "Prelude::(<<)" #-} + logicShift sym "<<" shiftShrink + (wordShiftLeft sym) (wordShiftRight sym) + shiftLeftReindex shiftRightReindex) + , (">>" , {-# SCC "Prelude::(>>)" #-} + logicShift sym ">>" shiftShrink + (wordShiftRight sym) (wordShiftLeft sym) + shiftRightReindex shiftLeftReindex) + , ("<<<" , {-# SCC "Prelude::(<<<)" #-} + logicShift sym "<<<" rotateShrink + (wordRotateLeft sym) (wordRotateRight sym) + rotateLeftReindex rotateRightReindex) + , (">>>" , {-# SCC "Prelude::(>>>)" #-} + logicShift sym ">>>" rotateShrink + (wordRotateRight sym) (wordRotateLeft sym) + rotateRightReindex rotateLeftReindex) + + , (">>$" , {-# SCC "Prelude::(>>$)" #-} + sshrV sym) -- Misc diff --git a/src/Cryptol/Eval/Reference.lhs b/src/Cryptol/Eval/Reference.lhs --- a/src/Cryptol/Eval/Reference.lhs +++ b/src/Cryptol/Eval/Reference.lhs @@ -251,7 +251,7 @@ > instance Semigroup Env where > l <> r = Env > { envVars = envVars l <> envVars r -> , envTypes = envTypes l <> envTypes r +> , envTypes = envTypes l <> envTypes r > } > > instance Monoid Env where @@ -523,7 +523,7 @@ that consumes and ignores its type arguments. > evalNewtypeDecl :: Env -> Newtype -> Env -> evalNewtypeDecl env nt = bindVar (ntName nt, pure val) env +> evalNewtypeDecl env nt = bindVar (ntName nt, pure val) env > where > val = foldr tabs con (ntParams nt) > con = VFun (\x -> x) @@ -541,7 +541,7 @@ > evalPrim :: Name -> Value > evalPrim n > | Just i <- asPrim n, Just v <- Map.lookup i primTable = v -> | otherwise = evalPanic "evalPrim" ["Unimplemented primitive", show n] +> | otherwise = evalPanic "evalPrim" ["Unimplemented primitive", show (pp n)] Cryptol primitives fall into several groups, mostly delineated by corresponding type classes: @@ -560,13 +560,15 @@ * Comparison: `<`, `>`, `<=`, `>=`, `==`, `!=` -* Sequences: `#`, `join`, `split`, `splitAt`, `reverse`, `transpose` +* Sequences: `#`, `join`, `split`, `take`, `drop`, `reverse`, `transpose` * Shifting: `<<`, `>>`, `<<<`, `>>>` * Indexing: `@`, `@@`, `!`, `!!`, `update`, `updateEnd` -* Enumerations: `fromTo`, `fromThenTo`, `infFrom`, `infFromThen` +* Enumerations: `fromTo`, `fromThenTo`, `fromToLessThan`, `fromToBy`, + `fromToByLessThan`, `fromToDownBy`, `fromToDownByGreaterThan`, + `infFrom`, `infFromThen` * Polynomials: `pmult`, `pdiv`, `pmod` @@ -734,17 +736,21 @@ > do vs <- fromVList <$> val > indexFront (nMul parts (Nat each)) vs (i * each + j) > -> , "splitAt" ~> vFinPoly $ \front -> pure $ +> , "take" ~> VNumPoly $ \front -> pure $ +> VNumPoly $ \back -> pure $ +> VPoly $ \_a -> pure $ +> VFun $ \v -> +> pure $ generateV front $ \i -> +> do vs <- fromVList <$> v +> indexFront (nAdd front back) vs i +> +> , "drop" ~> vFinPoly $ \front -> pure $ > VNumPoly $ \back -> pure $ > VPoly $ \_a -> pure $ > VFun $ \v -> -> let xs = pure $ generateV (Nat front) $ \i -> -> do vs <- fromVList <$> v -> indexFront (nAdd (Nat front) back) vs i -> ys = pure $ generateV back $ \i -> -> do vs <- fromVList <$> v -> indexFront (nAdd (Nat front) back) vs (front+i) -> in pure (VTuple [ xs, ys ]) +> pure $ generateV back $ \i -> +> do vs <- fromVList <$> v +> indexFront (nAdd (Nat front) back) vs (front+i) > > , "reverse" ~> vFinPoly $ \n -> pure $ > VPoly $ \_a -> pure $ @@ -778,18 +784,71 @@ > -- Enumerations > , "fromTo" ~> vFinPoly $ \first -> pure $ > vFinPoly $ \lst -> pure $ -> VPoly $ \ty -> -> let f i = literal i ty -> in pure (VList (Nat (1 + lst - first)) (map f [first .. lst])) +> VPoly $ \ty -> pure $ +> let f i = literal i ty in +> VList (Nat (1 + lst - first)) (map f [first .. lst]) > +> , "fromToLessThan" ~> +> vFinPoly $ \first -> pure $ +> VNumPoly $ \bound -> pure $ +> VPoly $ \ty -> pure $ +> let f i = literal i ty in +> case bound of +> Inf -> VList Inf (map f [first ..]) +> Nat bound' -> +> let len = bound' - first in +> VList (Nat len) (map f (genericTake len [first ..])) +> +> , "fromToBy" ~> vFinPoly $ \first -> pure $ +> vFinPoly $ \lst -> pure $ +> vFinPoly $ \stride -> pure $ +> VPoly $ \ty -> pure $ +> let f i = literal i ty in +> let vs = [ f (first + i*stride) | i <- [0..] ] in +> let len = 1 + ((lst-first) `div` stride) in +> VList (Nat len) (genericTake len vs) +> +> , "fromToByLessThan" ~> +> vFinPoly $ \first -> pure $ +> VNumPoly $ \bound -> pure $ +> vFinPoly $ \stride -> pure $ +> VPoly $ \ty -> pure $ +> let f i = literal i ty in +> let vs = [ f (first + i*stride) | i <- [0..] ] in +> case bound of +> Inf -> VList Inf vs +> Nat bound' -> +> let len = (bound'-first+stride-1) `div` stride in +> VList (Nat len) (genericTake len vs) +> +> , "fromToDownBy" ~> +> vFinPoly $ \first -> pure $ +> vFinPoly $ \lst -> pure $ +> vFinPoly $ \stride -> pure $ +> VPoly $ \ty -> pure $ +> let f i = literal i ty in +> let vs = [ f (first - i*stride) | i <- [0..] ] in +> let len = 1 + ((first-lst) `div` stride) in +> VList (Nat len) (genericTake len vs) +> +> , "fromToDownByGreaterThan" ~> +> vFinPoly $ \first -> pure $ +> vFinPoly $ \lst -> pure $ +> vFinPoly $ \stride -> pure $ +> VPoly $ \ty -> pure $ +> let f i = literal i ty in +> let vs = [ f (first - i*stride) | i <- [0..] ] in +> let len = (first-lst+stride-1) `div` stride in +> VList (Nat len) (genericTake len vs) +> > , "fromThenTo" ~> vFinPoly $ \first -> pure $ > vFinPoly $ \next -> pure $ > vFinPoly $ \_lst -> pure $ > VPoly $ \ty -> pure $ -> vFinPoly $ \len -> -> let f i = literal i ty -> in pure (VList (Nat len) -> (map f (genericTake len [first, next ..]))) +> vFinPoly $ \len -> pure $ +> let f i = literal i ty in +> VList (Nat len) +> (map f (genericTake len [first, next ..])) > > , "infFrom" ~> VPoly $ \ty -> pure $ > VFun $ \first -> @@ -1711,11 +1770,10 @@ > case traverse isBit vs of > Just bs -> ppBV opts (mkBv n (bitsToInteger bs)) > Nothing -> ppList (map (ppEValue opts) vs) -> where ppList docs = brackets (fsep (punctuate comma docs)) -> isBit v = case v of Value (VBit b) -> Just b +> where isBit v = case v of Value (VBit b) -> Just b > _ -> Nothing -> VTuple vs -> parens (sep (punctuate comma (map (ppEValue opts) vs))) -> VRecord fs -> braces (sep (punctuate comma (map ppField fs))) +> VTuple vs -> ppTuple (map (ppEValue opts) vs) +> VRecord fs -> ppRecord (map ppField fs) > where ppField (f,r) = pp f <+> char '=' <+> ppEValue opts r > VFun _ -> text "" > VPoly _ -> text "" @@ -1732,7 +1790,7 @@ > evaluate expr minp = return (Right (val, modEnv), []) > where > modEnv = M.minpModuleEnv minp -> extDgs = concatMap mDecls (M.loadedModules modEnv) +> extDgs = concatMap mDecls (M.loadedModules modEnv) ++ M.deDecls (M.meDynEnv modEnv) > nts = Map.elems (M.loadedNewtypes modEnv) > env = foldl evalDeclGroup (foldl evalNewtypeDecl mempty nts) extDgs > val = evalExpr env expr diff --git a/src/Cryptol/Eval/SBV.hs b/src/Cryptol/Eval/SBV.hs --- a/src/Cryptol/Eval/SBV.hs +++ b/src/Cryptol/Eval/SBV.hs @@ -23,21 +23,22 @@ import qualified Control.Exception as X import Control.Monad.IO.Class (MonadIO(..)) -import Data.Bits (bit, shiftL) import qualified Data.Map as Map import qualified Data.Text as T import Data.SBV.Dynamic as SBV import Cryptol.Backend -import Cryptol.Backend.Monad ( EvalError(..), Unsupported(..) ) +import Cryptol.Backend.Monad (Unsupported(..), EvalError(..) ) import Cryptol.Backend.SBV +import Cryptol.Backend.SeqMap +import Cryptol.Backend.WordValue import Cryptol.Eval.Type (TValue(..)) import Cryptol.Eval.Generic import Cryptol.Eval.Prims import Cryptol.Eval.Value -import Cryptol.TypeCheck.Solver.InfNat (Nat'(..), widthInteger) +import Cryptol.TypeCheck.Solver.InfNat (Nat'(..)) import Cryptol.Utils.Ident -- Values ---------------------------------------------------------------------- @@ -52,36 +53,9 @@ Map.union (genericPrimTable sym getEOpts) $ Map.fromList $ map (\(n, v) -> (prelPrim (T.pack n), v)) - [ (">>$" , sshrV sym) - - -- Shifts and rotates - , ("<<" , logicShift sym "<<" - shiftShrink - (\x y -> pure (shl x y)) - (\x y -> pure (lshr x y)) - shiftLeftReindex shiftRightReindex) - - , (">>" , logicShift sym ">>" - shiftShrink - (\x y -> pure (lshr x y)) - (\x y -> pure (shl x y)) - shiftRightReindex shiftLeftReindex) - - , ("<<<" , logicShift sym "<<<" - rotateShrink - (\x y -> pure (SBV.svRotateLeft x y)) - (\x y -> pure (SBV.svRotateRight x y)) - rotateLeftReindex rotateRightReindex) - - , (">>>" , logicShift sym ">>>" - rotateShrink - (\x y -> pure (SBV.svRotateRight x y)) - (\x y -> pure (SBV.svRotateLeft x y)) - rotateRightReindex rotateLeftReindex) - - -- Indexing and updates - , ("@" , indexPrim sym (indexFront sym) (indexFront_bits sym) (indexFront sym)) - , ("!" , indexPrim sym (indexBack sym) (indexBack_bits sym) (indexBack sym)) + [ -- Indexing and updates + ("@" , indexPrim sym IndexForward (indexFront sym) (indexFront_segs sym)) + , ("!" , indexPrim sym IndexBackward (indexFront sym) (indexFront_segs sym)) , ("update" , updatePrim sym (updateFrontSym_word sym) (updateFrontSym sym)) , ("updateEnd" , updatePrim sym (updateBackSym_word sym) (updateBackSym sym)) @@ -92,7 +66,7 @@ SBV -> Nat' -> TValue -> - SeqMap SBV -> + SeqMap SBV (GenValue SBV) -> TValue -> SVal -> SEval SBV Value @@ -102,125 +76,77 @@ | Nat n <- mblen , TVSeq wlen TVBit <- a - = do wvs <- traverse (fromWordVal "indexFront" =<<) (enumerateSeqMap n xs) - case asWordList wvs of + = do wvs <- traverse (fromWordVal "indexFront" <$>) (enumerateSeqMap n xs) + asWordList sym wvs >>= \case Just ws -> do z <- wordLit sym wlen 0 - return $ VWord wlen $ pure $ WordVal $ SBV.svSelect ws z idx - Nothing -> folded + return $ VWord wlen $ wordVal $ SBV.svSelect ws z idx + Nothing -> folded' - | otherwise - = folded + | otherwise = folded' + where k = SBV.kindOf idx - def = zeroV sym a - f n y = iteValue sym (SBV.svEqual idx (SBV.svInteger k n)) (lookupSeqMap xs n) y + + f n (Just y) = Just $ iteValue sym (SBV.svEqual idx (SBV.svInteger k n)) (lookupSeqMap xs n) y + f n Nothing = Just $ lookupSeqMap xs n + + folded' = + case folded of + Nothing -> raiseError sym (InvalidIndex Nothing) + Just m -> m + folded = case k of KBounded _ w -> case mblen of - Nat n | n < 2^w -> foldr f def [0 .. n-1] - _ -> foldr f def [0 .. 2^w - 1] + Nat n | n < 2^w -> foldr f Nothing [0 .. n-1] + _ -> foldr f Nothing [0 .. 2^w - 1] _ -> case mblen of - Nat n -> foldr f def [0 .. n-1] - Inf -> liftIO (X.throw (UnsupportedSymbolicOp "unbounded integer indexing")) - -indexBack :: - SBV -> - Nat' -> - TValue -> - SeqMap SBV -> - TValue -> - SWord SBV -> - SEval SBV Value -indexBack sym (Nat n) a xs ix idx = indexFront sym (Nat n) a (reverseSeqMap n xs) ix idx -indexBack _ Inf _ _ _ _ = evalPanic "Expected finite sequence" ["indexBack"] - -indexFront_bits :: - SBV -> - Nat' -> - TValue -> - SeqMap SBV -> - TValue -> - [SBit SBV] -> - SEval SBV Value -indexFront_bits sym mblen _a xs _ix bits0 = go 0 (length bits0) bits0 - where - go :: Integer -> Int -> [SBit SBV] -> SEval SBV Value - go i _k [] - -- For indices out of range, fail - | Nat n <- mblen - , i >= n - = raiseError sym (InvalidIndex (Just i)) - - | otherwise - = lookupSeqMap xs i - - go i k (b:bs) - -- Fail early when all possible indices we could compute from here - -- are out of bounds - | Nat n <- mblen - , (i `shiftL` k) >= n - = raiseError sym (InvalidIndex Nothing) - - | otherwise - = iteValue sym b - (go ((i `shiftL` 1) + 1) (k-1) bs) - (go (i `shiftL` 1) (k-1) bs) - + Nat n -> foldr f Nothing [0 .. n-1] + Inf -> Just (liftIO (X.throw (UnsupportedSymbolicOp "unbounded integer indexing"))) -indexBack_bits :: +indexFront_segs :: SBV -> Nat' -> TValue -> - SeqMap SBV -> + SeqMap SBV (GenValue SBV) -> TValue -> - [SBit SBV] -> + Integer -> + [IndexSegment SBV] -> SEval SBV Value -indexBack_bits sym (Nat n) a xs ix idx = indexFront_bits sym (Nat n) a (reverseSeqMap n xs) ix idx -indexBack_bits _ Inf _ _ _ _ = evalPanic "Expected finite sequence" ["indexBack_bits"] - +indexFront_segs sym mblen a xs ix _idx_bits [WordIndexSegment w] = + indexFront sym mblen a xs ix w --- | Compare a symbolic word value with a concrete integer. -wordValueEqualsInteger :: SBV -> WordValue SBV -> Integer -> SEval SBV (SBit SBV) -wordValueEqualsInteger sym wv i - | wordValueSize sym wv < widthInteger i = return SBV.svFalse - | otherwise = - case wv of - WordVal w -> return $ SBV.svEqual w (literalSWord (SBV.intSizeOf w) i) - _ -> bitsAre i <$> enumerateWordValueRev sym wv -- little-endian +indexFront_segs sym mblen _a xs _ix idx_bits segs = + do xs' <- barrelShifter sym (mergeValue sym) shiftOp mblen xs idx_bits segs + lookupSeqMap xs' 0 where - bitsAre :: Integer -> [SBit SBV] -> SBit SBV - bitsAre n [] = SBV.svBool (n == 0) - bitsAre n (b : bs) = SBV.svAnd (bitIs (odd n) b) (bitsAre (n `div` 2) bs) - - bitIs :: Bool -> SBit SBV -> SBit SBV - bitIs b x = if b then x else SBV.svNot x + shiftOp vs amt = pure (indexSeqMap (\i -> lookupSeqMap vs $! amt+i)) updateFrontSym :: SBV -> Nat' -> TValue -> - SeqMap SBV -> + SeqMap SBV (GenValue SBV) -> Either (SInteger SBV) (WordValue SBV) -> SEval SBV (GenValue SBV) -> - SEval SBV (SeqMap SBV) + SEval SBV (SeqMap SBV (GenValue SBV)) updateFrontSym sym _len _eltTy vs (Left idx) val = case SBV.svAsInteger idx of Just i -> return $ updateSeqMap vs i val - Nothing -> return $ IndexSeqMap $ \i -> + Nothing -> return $ indexSeqMap $ \i -> do b <- intEq sym idx =<< integerLit sym i iteValue sym b val (lookupSeqMap vs i) updateFrontSym sym _len _eltTy vs (Right wv) val = - case wv of - WordVal w | Just j <- SBV.svAsInteger w -> - return $ updateSeqMap vs j val - _ -> - return $ IndexSeqMap $ \i -> + wordValAsLit sym wv >>= \case + Just j -> return $ updateSeqMap vs j val + Nothing -> + return $ indexSeqMap $ \i -> do b <- wordValueEqualsInteger sym wv i iteValue sym b val (lookupSeqMap vs i) @@ -234,56 +160,35 @@ SEval SBV (WordValue SBV) updateFrontSym_word _ Inf _ _ _ _ = evalPanic "Expected finite sequence" ["updateFrontSym_bits"] -updateFrontSym_word sym (Nat _) eltTy (LargeBitsVal n bv) idx val = - LargeBitsVal n <$> updateFrontSym sym (Nat n) eltTy bv idx val - -updateFrontSym_word sym (Nat n) eltTy (WordVal bv) (Left idx) val = +updateFrontSym_word sym (Nat n) _eltTy w (Left idx) val = do idx' <- wordFromInt sym n idx - updateFrontSym_word sym (Nat n) eltTy (WordVal bv) (Right (WordVal idx')) val - -updateFrontSym_word sym (Nat n) eltTy bv (Right wv) val = - case wv of - WordVal idx - | Just j <- SBV.svAsInteger idx -> - updateWordValue sym bv j (fromVBit <$> val) - - | WordVal bw <- bv -> - WordVal <$> - do b <- fromVBit <$> val - let sz = SBV.intSizeOf bw - let z = literalSWord sz 0 - let znot = SBV.svNot z - let q = SBV.svSymbolicMerge (SBV.kindOf bw) True b znot z - let msk = SBV.svShiftRight (literalSWord sz (bit (sz-1))) idx - let bw' = SBV.svAnd bw (SBV.svNot msk) - return $! SBV.svXOr bw' (SBV.svAnd q msk) - - _ -> LargeBitsVal n <$> updateFrontSym sym (Nat n) eltTy (asBitsMap sym bv) (Right wv) val + updateWordByWord sym IndexForward w (wordVal idx') (fromVBit <$> val) +updateFrontSym_word sym (Nat _n) _eltTy w (Right idx) val = + updateWordByWord sym IndexForward w idx (fromVBit <$> val) updateBackSym :: SBV -> Nat' -> TValue -> - SeqMap SBV -> + SeqMap SBV (GenValue SBV) -> Either (SInteger SBV) (WordValue SBV) -> SEval SBV (GenValue SBV) -> - SEval SBV (SeqMap SBV) + SEval SBV (SeqMap SBV (GenValue SBV)) updateBackSym _ Inf _ _ _ _ = evalPanic "Expected finite sequence" ["updateBackSym"] updateBackSym sym (Nat n) _eltTy vs (Left idx) val = case SBV.svAsInteger idx of Just i -> return $ updateSeqMap vs (n - 1 - i) val - Nothing -> return $ IndexSeqMap $ \i -> + Nothing -> return $ indexSeqMap $ \i -> do b <- intEq sym idx =<< integerLit sym (n - 1 - i) iteValue sym b val (lookupSeqMap vs i) updateBackSym sym (Nat n) _eltTy vs (Right wv) val = - case wv of - WordVal w | Just j <- SBV.svAsInteger w -> - return $ updateSeqMap vs (n - 1 - j) val - _ -> - return $ IndexSeqMap $ \i -> + wordValAsLit sym wv >>= \case + Just j -> return $ updateSeqMap vs (n - 1 - j) val + Nothing -> + return $ indexSeqMap $ \i -> do b <- wordValueEqualsInteger sym wv (n - 1 - i) iteValue sym b val (lookupSeqMap vs i) @@ -297,56 +202,9 @@ SEval SBV (WordValue SBV) updateBackSym_word _ Inf _ _ _ _ = evalPanic "Expected finite sequence" ["updateBackSym_bits"] -updateBackSym_word sym (Nat _) eltTy (LargeBitsVal n bv) idx val = - LargeBitsVal n <$> updateBackSym sym (Nat n) eltTy bv idx val - -updateBackSym_word sym (Nat n) eltTy (WordVal bv) (Left idx) val = +updateBackSym_word sym (Nat n) _eltTy w (Left idx) val = do idx' <- wordFromInt sym n idx - updateBackSym_word sym (Nat n) eltTy (WordVal bv) (Right (WordVal idx')) val - -updateBackSym_word sym (Nat n) eltTy bv (Right wv) val = do - case wv of - WordVal idx - | Just j <- SBV.svAsInteger idx -> - updateWordValue sym bv (n - 1 - j) (fromVBit <$> val) - - | WordVal bw <- bv -> - WordVal <$> - do b <- fromVBit <$> val - let sz = SBV.intSizeOf bw - let z = literalSWord sz 0 - let znot = SBV.svNot z - let q = SBV.svSymbolicMerge (SBV.kindOf bw) True b znot z - let msk = SBV.svShiftLeft (literalSWord sz 1) idx - let bw' = SBV.svAnd bw (SBV.svNot msk) - return $! SBV.svXOr bw' (SBV.svAnd q msk) - - _ -> LargeBitsVal n <$> updateBackSym sym (Nat n) eltTy (asBitsMap sym bv) (Right wv) val - - -asWordList :: [WordValue SBV] -> Maybe [SWord SBV] -asWordList = go id - where go :: ([SWord SBV] -> [SWord SBV]) -> [WordValue SBV] -> Maybe [SWord SBV] - go f [] = Just (f []) - go f (WordVal x :vs) = go (f . (x:)) vs - go _f (LargeBitsVal _ _ : _) = Nothing - -sshrV :: SBV -> Prim SBV -sshrV sym = - PNumPoly \n -> - PTyPoly \ix -> - PWordFun \x -> - PStrict \y -> - PPrim $ - asIndex sym ">>$" ix y >>= \case - Left idx -> - do let w = toInteger (SBV.intSizeOf x) - let pneg = svLessThan idx (svInteger KUnbounded 0) - zneg <- shl x . svFromInteger w <$> shiftShrink sym n ix (SBV.svUNeg idx) - zpos <- ashr x . svFromInteger w <$> shiftShrink sym n ix idx - let z = svSymbolicMerge (kindOf x) True pneg zneg zpos - return . VWord w . pure . WordVal $ z + updateWordByWord sym IndexBackward w (wordVal idx') (fromVBit <$> val) +updateBackSym_word sym (Nat _n) _eltTy w (Right idx) val = + updateWordByWord sym IndexBackward w idx (fromVBit <$> val) - Right wv -> - do z <- ashr x <$> asWordVal sym wv - return . VWord (toInteger (SBV.intSizeOf x)) . pure . WordVal $ z diff --git a/src/Cryptol/Eval/Value.hs b/src/Cryptol/Eval/Value.hs --- a/src/Cryptol/Eval/Value.hs +++ b/src/Cryptol/Eval/Value.hs @@ -6,6 +6,7 @@ -- Stability : provisional -- Portability : portable +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} @@ -16,7 +17,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PatternGuards #-} -{-# LANGUAGE Safe #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TupleSections #-} @@ -26,7 +26,6 @@ module Cryptol.Eval.Value ( -- * GenericValue GenValue(..) - , forceWordValue , forceValue , Backend(..) , asciiMode @@ -39,9 +38,6 @@ , tlam , nlam , ilam - , toStream - , toFinSeq - , toSeq , mkSeq -- ** Value eliminators , fromVBit @@ -64,59 +60,32 @@ -- ** Pretty printing , defaultPPOpts , ppValue - - -- * Sequence Maps - , SeqMap (..) - , lookupSeqMap - , finiteSeqMap - , infiniteSeqMap - , enumerateSeqMap - , streamSeqMap - , reverseSeqMap - , updateSeqMap - , dropSeqMap - , concatSeqMap - , splitSeqMap - , memoMap - , zipSeqMap - , mapSeqMap - , largeBitSize - -- * WordValue - , WordValue(..) - , asWordVal - , asBitsMap - , enumerateWordValue - , enumerateWordValueRev - , wordValueSize - , indexWordValue - , updateWordValue + -- * Merge and if/then/else + , iteValue + , mergeValue ) where -import Control.Monad.IO.Class -import Data.Bits -import Data.IORef -import Data.Map.Strict (Map) import Data.Ratio -import qualified Data.Map.Strict as Map -import MonadLib import Numeric (showIntAtBase) import Cryptol.Backend +import Cryptol.Backend.SeqMap import qualified Cryptol.Backend.Arch as Arch import Cryptol.Backend.Monad ( evalPanic, wordTooWide, CallStack, combineCallStacks ) import Cryptol.Backend.FloatHelpers (fpPP) +import Cryptol.Backend.WordValue + import Cryptol.Eval.Type import Cryptol.TypeCheck.Solver.InfNat(Nat'(..)) + import Cryptol.Utils.Ident (Ident) import Cryptol.Utils.Logger(Logger) import Cryptol.Utils.Panic(panic) import Cryptol.Utils.PP import Cryptol.Utils.RecordMap -import Data.List(genericIndex) - import GHC.Generics (Generic) -- | Some options for evalutaion @@ -127,186 +96,6 @@ -- Values ---------------------------------------------------------------------- --- | A sequence map represents a mapping from nonnegative integer indices --- to values. These are used to represent both finite and infinite sequences. -data SeqMap sym - = IndexSeqMap !(Integer -> SEval sym (GenValue sym)) - | UpdateSeqMap !(Map Integer (SEval sym (GenValue sym))) - !(Integer -> SEval sym (GenValue sym)) - -lookupSeqMap :: SeqMap sym -> Integer -> SEval sym (GenValue sym) -lookupSeqMap (IndexSeqMap f) i = f i -lookupSeqMap (UpdateSeqMap m f) i = - case Map.lookup i m of - Just x -> x - Nothing -> f i - --- | An arbitrarily-chosen number of elements where we switch from a dense --- sequence representation of bit-level words to 'SeqMap' representation. -largeBitSize :: Integer -largeBitSize = 1 `shiftL` 48 - --- | Generate a finite sequence map from a list of values -finiteSeqMap :: [SEval sym (GenValue sym)] -> SeqMap sym -finiteSeqMap xs = - UpdateSeqMap - (Map.fromList (zip [0..] xs)) - (\i -> panic "finiteSeqMap" ["Out of bounds access of finite seq map", "length: " ++ show (length xs), show i]) - --- | Generate an infinite sequence map from a stream of values -infiniteSeqMap :: Backend sym => sym -> [SEval sym (GenValue sym)] -> SEval sym (SeqMap sym) -infiniteSeqMap sym xs = - -- TODO: use an int-trie? - memoMap sym (IndexSeqMap $ \i -> genericIndex xs i) - --- | Create a finite list of length @n@ of the values from @[0..n-1]@ in --- the given the sequence emap. -enumerateSeqMap :: (Integral n) => n -> SeqMap sym -> [SEval sym (GenValue sym)] -enumerateSeqMap n m = [ lookupSeqMap m i | i <- [0 .. (toInteger n)-1] ] - --- | Create an infinite stream of all the values in a sequence map -streamSeqMap :: SeqMap sym -> [SEval sym (GenValue sym)] -streamSeqMap m = [ lookupSeqMap m i | i <- [0..] ] - --- | Reverse the order of a finite sequence map -reverseSeqMap :: Integer -- ^ Size of the sequence map - -> SeqMap sym - -> SeqMap sym -reverseSeqMap n vals = IndexSeqMap $ \i -> lookupSeqMap vals (n - 1 - i) - -updateSeqMap :: SeqMap sym -> Integer -> SEval sym (GenValue sym) -> SeqMap sym -updateSeqMap (UpdateSeqMap m sm) i x = UpdateSeqMap (Map.insert i x m) sm -updateSeqMap (IndexSeqMap f) i x = UpdateSeqMap (Map.singleton i x) f - --- | Concatenate the first @n@ values of the first sequence map onto the --- beginning of the second sequence map. -concatSeqMap :: Integer -> SeqMap sym -> SeqMap sym -> SeqMap sym -concatSeqMap n x y = - IndexSeqMap $ \i -> - if i < n - then lookupSeqMap x i - else lookupSeqMap y (i-n) - --- | Given a number @n@ and a sequence map, return two new sequence maps: --- the first containing the values from @[0..n-1]@ and the next containing --- the values from @n@ onward. -splitSeqMap :: Integer -> SeqMap sym -> (SeqMap sym, SeqMap sym) -splitSeqMap n xs = (hd,tl) - where - hd = xs - tl = IndexSeqMap $ \i -> lookupSeqMap xs (i+n) - --- | Drop the first @n@ elements of the given 'SeqMap'. -dropSeqMap :: Integer -> SeqMap sym -> SeqMap sym -dropSeqMap 0 xs = xs -dropSeqMap n xs = IndexSeqMap $ \i -> lookupSeqMap xs (i+n) - --- | Given a sequence map, return a new sequence map that is memoized using --- a finite map memo table. -memoMap :: Backend sym => sym -> SeqMap sym -> SEval sym (SeqMap sym) -memoMap sym x = do - stk <- sGetCallStack sym - cache <- liftIO $ newIORef $ Map.empty - return $ IndexSeqMap (memo cache stk) - - where - memo cache stk i = do - mz <- liftIO (Map.lookup i <$> readIORef cache) - case mz of - Just z -> return z - Nothing -> sWithCallStack sym stk (doEval cache i) - - doEval cache i = do - v <- lookupSeqMap x i - liftIO $ atomicModifyIORef' cache (\m -> (Map.insert i v m, ())) - return v - --- | Apply the given evaluation function pointwise to the two given --- sequence maps. -zipSeqMap :: - Backend sym => - sym -> - (GenValue sym -> GenValue sym -> SEval sym (GenValue sym)) -> - SeqMap sym -> - SeqMap sym -> - SEval sym (SeqMap sym) -zipSeqMap sym f x y = - memoMap sym (IndexSeqMap $ \i -> join (f <$> lookupSeqMap x i <*> lookupSeqMap y i)) - --- | Apply the given function to each value in the given sequence map -mapSeqMap :: - Backend sym => - sym -> - (GenValue sym -> SEval sym (GenValue sym)) -> - SeqMap sym -> SEval sym (SeqMap sym) -mapSeqMap sym f x = - memoMap sym (IndexSeqMap $ \i -> f =<< lookupSeqMap x i) - --- | For efficiency reasons, we handle finite sequences of bits as special cases --- in the evaluator. In cases where we know it is safe to do so, we prefer to --- used a "packed word" representation of bit sequences. This allows us to rely --- directly on Integer types (in the concrete evaluator) and SBV's Word types (in --- the symbolic simulator). --- --- However, if we cannot be sure all the bits of the sequence --- will eventually be forced, we must instead rely on an explicit sequence of bits --- representation. -data WordValue sym - = WordVal !(SWord sym) -- ^ Packed word representation for bit sequences. - | LargeBitsVal !Integer !(SeqMap sym) -- ^ A large bitvector sequence, represented as a - -- 'SeqMap' of bits. - deriving (Generic) - --- | Force a word value into packed word form -asWordVal :: Backend sym => sym -> WordValue sym -> SEval sym (SWord sym) -asWordVal _ (WordVal w) = return w -asWordVal sym (LargeBitsVal n xs) = packWord sym =<< traverse (fromVBit <$>) (enumerateSeqMap n xs) - --- | Force a word value into a sequence of bits -asBitsMap :: Backend sym => sym -> WordValue sym -> SeqMap sym -asBitsMap sym (WordVal w) = IndexSeqMap $ \i -> VBit <$> (wordBit sym w i) -asBitsMap _ (LargeBitsVal _ xs) = xs - --- | Turn a word value into a sequence of bits, forcing each bit. --- The sequence is returned in big-endian order. -enumerateWordValue :: Backend sym => sym -> WordValue sym -> SEval sym [SBit sym] -enumerateWordValue sym (WordVal w) = unpackWord sym w -enumerateWordValue _ (LargeBitsVal n xs) = traverse (fromVBit <$>) (enumerateSeqMap n xs) - --- | Turn a word value into a sequence of bits, forcing each bit. --- The sequence is returned in reverse of the usual order, which is little-endian order. -enumerateWordValueRev :: Backend sym => sym -> WordValue sym -> SEval sym [SBit sym] -enumerateWordValueRev sym (WordVal w) = reverse <$> unpackWord sym w -enumerateWordValueRev _ (LargeBitsVal n xs) = traverse (fromVBit <$>) (enumerateSeqMap n (reverseSeqMap n xs)) - --- | Compute the size of a word value -wordValueSize :: Backend sym => sym -> WordValue sym -> Integer -wordValueSize sym (WordVal w) = wordLen sym w -wordValueSize _ (LargeBitsVal n _) = n - --- | Select an individual bit from a word value -indexWordValue :: Backend sym => sym -> WordValue sym -> Integer -> SEval sym (SBit sym) -indexWordValue sym (WordVal w) idx - | 0 <= idx && idx < wordLen sym w = wordBit sym w idx - | otherwise = invalidIndex sym idx -indexWordValue sym (LargeBitsVal n xs) idx - | 0 <= idx && idx < n = fromVBit <$> lookupSeqMap xs idx - | otherwise = invalidIndex sym idx - --- | Produce a new 'WordValue' from the one given by updating the @i@th bit with the --- given bit value. -updateWordValue :: Backend sym => - sym -> WordValue sym -> Integer -> SEval sym (SBit sym) -> SEval sym (WordValue sym) -updateWordValue sym (WordVal w) idx b - | idx < 0 || idx >= wordLen sym w = invalidIndex sym idx - | isReady sym b = WordVal <$> (wordUpdate sym w idx =<< b) - -updateWordValue sym wv idx b - | 0 <= idx && idx < wordValueSize sym wv = - pure $ LargeBitsVal (wordValueSize sym wv) $ updateSeqMap (asBitsMap sym wv) idx (VBit <$> b) - | otherwise = invalidIndex sym idx - - -- | Generic value type, parameterized by bit and word types. -- -- NOTE: we maintain an important invariant regarding sequence types. @@ -320,21 +109,16 @@ | VInteger !(SInteger sym) -- ^ @ Integer @ or @ Z n @ | VRational !(SRational sym) -- ^ @ Rational @ | VFloat !(SFloat sym) - | VSeq !Integer !(SeqMap sym) -- ^ @ [n]a @ + | VSeq !Integer !(SeqMap sym (GenValue sym)) -- ^ @ [n]a @ -- Invariant: VSeq is never a sequence of bits - | VWord !Integer !(SEval sym (WordValue sym)) -- ^ @ [n]Bit @ - | VStream !(SeqMap sym) -- ^ @ [inf]a @ + | VWord !Integer !(WordValue sym) -- ^ @ [n]Bit @ + | VStream !(SeqMap sym (GenValue sym)) -- ^ @ [inf]a @ | VFun CallStack (SEval sym (GenValue sym) -> SEval sym (GenValue sym)) -- ^ functions | VPoly CallStack (TValue -> SEval sym (GenValue sym)) -- ^ polymorphic values (kind *) | VNumPoly CallStack (Nat' -> SEval sym (GenValue sym)) -- ^ polymorphic values (kind #) deriving Generic --- | Force the evaluation of a word value -forceWordValue :: Backend sym => WordValue sym -> SEval sym () -forceWordValue (WordVal w) = seq w (return ()) -forceWordValue (LargeBitsVal n xs) = mapM_ (\x -> const () <$> x) (enumerateSeqMap n xs) - -- | Force the evaluation of a value forceValue :: Backend sym => GenValue sym -> SEval sym () forceValue v = case v of @@ -345,7 +129,7 @@ VInteger i -> seq i (return ()) VRational q -> seq q (return ()) VFloat f -> seq f (return ()) - VWord _ wv -> forceWordValue =<< wv + VWord _ wv -> forceWordValue wv VStream _ -> return () VFun{} -> return () VPoly{} -> return () @@ -353,7 +137,7 @@ -instance Backend sym => Show (GenValue sym) where +instance Show (GenValue sym) where show v = case v of VRecord fs -> "record:" ++ show (displayOrder fs) VTuple xs -> "tuple:" ++ show (length xs) @@ -368,7 +152,6 @@ VPoly{} -> "poly" VNumPoly{} -> "numpoly" - -- Pretty Printing ------------------------------------------------------------- ppValue :: forall sym. @@ -382,30 +165,32 @@ loop :: GenValue sym -> SEval sym Doc loop val = case val of VRecord fs -> do fs' <- traverse (>>= loop) fs - return $ braces (sep (punctuate comma (map ppField (displayFields fs')))) + return $ ppRecord (map ppField (fields fs')) where ppField (f,r) = pp f <+> char '=' <+> r VTuple vals -> do vals' <- traverse (>>=loop) vals - return $ parens (sep (punctuate comma vals')) + return $ ppTuple vals' VBit b -> ppSBit x b VInteger i -> ppSInteger x i VRational q -> ppSRational x q VFloat i -> ppSFloat x opts i VSeq sz vals -> ppWordSeq sz vals - VWord _ wv -> ppWordVal =<< wv + VWord _ wv -> ppWordVal wv VStream vals -> do vals' <- traverse (>>=loop) $ enumerateSeqMap (useInfLength opts) vals - return $ brackets $ fsep - $ punctuate comma - ( vals' ++ [text "..."] - ) + return $ ppList ( vals' ++ [text "..."] ) VFun{} -> return $ text "" VPoly{} -> return $ text "" VNumPoly{} -> return $ text "" + fields :: RecordMap Ident Doc -> [(Ident, Doc)] + fields = case useFieldOrder opts of + DisplayOrder -> displayFields + CanonicalOrder -> canonicalFields + ppWordVal :: WordValue sym -> SEval sym Doc ppWordVal w = ppSWord x opts =<< asWordVal x w - ppWordSeq :: Integer -> SeqMap sym -> SEval sym Doc + ppWordSeq :: Integer -> SeqMap sym (GenValue sym) -> SEval sym Doc ppWordSeq sz vals = do ws <- sequence (enumerateSeqMap sz vals) case ws of @@ -416,9 +201,9 @@ case traverse (wordAsChar x) vs of Just str -> return $ text (show str) _ -> do vs' <- mapM (ppSWord x opts) vs - return $ brackets (fsep (punctuate comma vs')) + return $ ppList vs' _ -> do ws' <- traverse loop ws - return $ brackets (fsep (punctuate comma ws')) + return $ ppList ws' ppSBit :: Backend sym => sym -> SBit sym -> SEval sym Doc ppSBit sym b = @@ -485,7 +270,7 @@ prefix len = case base of 2 -> text "0b" <.> padding 1 len 8 -> text "0o" <.> padding 3 len - 10 -> empty + 10 -> mempty 16 -> text "0x" <.> padding 4 len _ -> text "0" <.> char '<' <.> int base <.> char '>' @@ -514,10 +299,10 @@ -- Value Constructors ---------------------------------------------------------- -- | Create a packed word of n bits. -word :: Backend sym => sym -> Integer -> Integer -> GenValue sym +word :: Backend sym => sym -> Integer -> Integer -> SEval sym (GenValue sym) word sym n i | n >= Arch.maxBigIntWidth = wordTooWide n - | otherwise = VWord n (WordVal <$> wordLit sym n i) + | otherwise = VWord n . wordVal <$> wordLit sym n i -- | Construct a function value @@ -544,36 +329,14 @@ Nat i -> f i Inf -> panic "ilam" [ "Unexpected `inf`" ]) --- | Generate a stream. -toStream :: Backend sym => sym -> [GenValue sym] -> SEval sym (GenValue sym) -toStream sym vs = - VStream <$> infiniteSeqMap sym (map pure vs) - -toFinSeq :: - Backend sym => - sym -> Integer -> TValue -> [GenValue sym] -> GenValue sym -toFinSeq sym len elty vs - | isTBit elty = VWord len (WordVal <$> packWord sym (map fromVBit vs)) - | otherwise = VSeq len $ finiteSeqMap (map pure vs) - -- | Construct either a finite sequence, or a stream. In the finite case, -- record whether or not the elements were bits, to aid pretty-printing. -toSeq :: - Backend sym => - sym -> Nat' -> TValue -> [GenValue sym] -> SEval sym (GenValue sym) -toSeq sym len elty vals = case len of - Nat n -> return $ toFinSeq sym n elty vals - Inf -> toStream sym vals - - --- | Construct either a finite sequence, or a stream. In the finite case, --- record whether or not the elements were bits, to aid pretty-printing. -mkSeq :: Backend sym => Nat' -> TValue -> SeqMap sym -> GenValue sym -mkSeq len elty vals = case len of +mkSeq :: Backend sym => sym -> Nat' -> TValue -> SeqMap sym (GenValue sym) -> SEval sym (GenValue sym) +mkSeq sym len elty vals = case len of Nat n - | isTBit elty -> VWord n $ pure $ LargeBitsVal n vals - | otherwise -> VSeq n vals - Inf -> VStream vals + | isTBit elty -> VWord n <$> bitmapWordVal sym n (fromVBit <$> vals) + | otherwise -> pure $ VSeq n vals + Inf -> pure $ VStream vals -- Value Destructors ----------------------------------------------------------- @@ -582,47 +345,47 @@ fromVBit :: GenValue sym -> SBit sym fromVBit val = case val of VBit b -> b - _ -> evalPanic "fromVBit" ["not a Bit"] + _ -> evalPanic "fromVBit" ["not a Bit", show val] -- | Extract an integer value. fromVInteger :: GenValue sym -> SInteger sym fromVInteger val = case val of VInteger i -> i - _ -> evalPanic "fromVInteger" ["not an Integer"] + _ -> evalPanic "fromVInteger" ["not an Integer", show val] -- | Extract a rational value. fromVRational :: GenValue sym -> SRational sym fromVRational val = case val of VRational q -> q - _ -> evalPanic "fromVRational" ["not a Rational"] + _ -> evalPanic "fromVRational" ["not a Rational", show val] -- | Extract a finite sequence value. -fromVSeq :: GenValue sym -> SeqMap sym +fromVSeq :: GenValue sym -> SeqMap sym (GenValue sym) fromVSeq val = case val of VSeq _ vs -> vs - _ -> evalPanic "fromVSeq" ["not a sequence"] + _ -> evalPanic "fromVSeq" ["not a sequence", show val] -- | Extract a sequence. -fromSeq :: Backend sym => String -> GenValue sym -> SEval sym (SeqMap sym) +fromSeq :: Backend sym => String -> GenValue sym -> SEval sym (SeqMap sym (GenValue sym)) fromSeq msg val = case val of VSeq _ vs -> return vs VStream vs -> return vs - _ -> evalPanic "fromSeq" ["not a sequence", msg] + _ -> evalPanic "fromSeq" ["not a sequence", msg, show val] -fromWordVal :: Backend sym => String -> GenValue sym -> SEval sym (WordValue sym) +fromWordVal :: Backend sym => String -> GenValue sym -> WordValue sym fromWordVal _msg (VWord _ wval) = wval -fromWordVal msg _ = evalPanic "fromWordVal" ["not a word value", msg] +fromWordVal msg val = evalPanic "fromWordVal" ["not a word value", msg, show val] asIndex :: Backend sym => - sym -> String -> TValue -> GenValue sym -> SEval sym (Either (SInteger sym) (WordValue sym)) -asIndex _sym _msg TVInteger (VInteger i) = pure (Left i) -asIndex _sym _msg _ (VWord _ wval) = Right <$> wval -asIndex _sym msg _ _ = evalPanic "asIndex" ["not an index value", msg] + sym -> String -> TValue -> GenValue sym -> Either (SInteger sym) (WordValue sym) +asIndex _sym _msg TVInteger (VInteger i) = Left i +asIndex _sym _msg _ (VWord _ wval) = Right wval +asIndex _sym msg _ val = evalPanic "asIndex" ["not an index value", msg, show val] -- | Extract a packed word. fromVWord :: Backend sym => sym -> String -> GenValue sym -> SEval sym (SWord sym) -fromVWord sym _msg (VWord _ wval) = wval >>= asWordVal sym -fromVWord _ msg _ = evalPanic "fromVWord" ["not a word", msg] +fromVWord sym _msg (VWord _ wval) = asWordVal sym wval +fromVWord _ msg val = evalPanic "fromVWord" ["not a word", msg, show val] vWordLen :: Backend sym => GenValue sym -> Maybe Integer vWordLen val = case val of @@ -632,55 +395,119 @@ -- | If the given list of values are all fully-evaluated thunks -- containing bits, return a packed word built from the same bits. -- However, if any value is not a fully-evaluated bit, return 'Nothing'. -tryFromBits :: Backend sym => sym -> [SEval sym (GenValue sym)] -> Maybe (SEval sym (SWord sym)) +tryFromBits :: Backend sym => sym -> [SEval sym (GenValue sym)] -> SEval sym (Maybe (SWord sym)) tryFromBits sym = go id where - go f [] = Just (packWord sym =<< sequence (f [])) - go f (v : vs) | isReady sym v = go (f . ((fromVBit <$> v):)) vs - go _ (_ : _) = Nothing + go f [] = Just <$> (packWord sym (f [])) + go f (v : vs) = + isReady sym v >>= \case + Just v' -> go (f . ((fromVBit v'):)) vs + Nothing -> pure Nothing -- | Extract a function from a value. fromVFun :: Backend sym => sym -> GenValue sym -> (SEval sym (GenValue sym) -> SEval sym (GenValue sym)) fromVFun sym val = case val of VFun fnstk f -> \x -> sModifyCallStack sym (\stk -> combineCallStacks stk fnstk) (f x) - _ -> evalPanic "fromVFun" ["not a function"] + _ -> evalPanic "fromVFun" ["not a function", show val] -- | Extract a polymorphic function from a value. fromVPoly :: Backend sym => sym -> GenValue sym -> (TValue -> SEval sym (GenValue sym)) fromVPoly sym val = case val of VPoly fnstk f -> \x -> sModifyCallStack sym (\stk -> combineCallStacks stk fnstk) (f x) - _ -> evalPanic "fromVPoly" ["not a polymorphic value"] + _ -> evalPanic "fromVPoly" ["not a polymorphic value", show val] -- | Extract a polymorphic function from a value. fromVNumPoly :: Backend sym => sym -> GenValue sym -> (Nat' -> SEval sym (GenValue sym)) fromVNumPoly sym val = case val of VNumPoly fnstk f -> \x -> sModifyCallStack sym (\stk -> combineCallStacks stk fnstk) (f x) - _ -> evalPanic "fromVNumPoly" ["not a polymorphic value"] + _ -> evalPanic "fromVNumPoly" ["not a polymorphic value", show val] -- | Extract a tuple from a value. fromVTuple :: GenValue sym -> [SEval sym (GenValue sym)] fromVTuple val = case val of VTuple vs -> vs - _ -> evalPanic "fromVTuple" ["not a tuple"] + _ -> evalPanic "fromVTuple" ["not a tuple", show val] -- | Extract a record from a value. fromVRecord :: GenValue sym -> RecordMap Ident (SEval sym (GenValue sym)) fromVRecord val = case val of VRecord fs -> fs - _ -> evalPanic "fromVRecord" ["not a record"] + _ -> evalPanic "fromVRecord" ["not a record", show val] fromVFloat :: GenValue sym -> SFloat sym fromVFloat val = case val of VFloat x -> x - _ -> evalPanic "fromVFloat" ["not a Float"] + _ -> evalPanic "fromVFloat" ["not a Float", show val] -- | Lookup a field in a record. lookupRecord :: Ident -> GenValue sym -> SEval sym (GenValue sym) lookupRecord f val = case lookupField f (fromVRecord val) of Just x -> x - Nothing -> evalPanic "lookupRecord" ["malformed record"] + Nothing -> evalPanic "lookupRecord" ["malformed record", show val] + + +-- Merge and if/then/else + +{-# INLINE iteValue #-} +iteValue :: Backend sym => + sym -> + SBit sym -> + SEval sym (GenValue sym) -> + SEval sym (GenValue sym) -> + SEval sym (GenValue sym) +iteValue sym b x y + | Just True <- bitAsLit sym b = x + | Just False <- bitAsLit sym b = y + | otherwise = mergeValue' sym b x y + +{-# INLINE mergeValue' #-} +mergeValue' :: Backend sym => + sym -> + SBit sym -> + SEval sym (GenValue sym) -> + SEval sym (GenValue sym) -> + SEval sym (GenValue sym) +mergeValue' sym = mergeEval sym (mergeValue sym) + +mergeValue :: Backend sym => + sym -> + SBit sym -> + GenValue sym -> + GenValue sym -> + SEval sym (GenValue sym) +mergeValue sym c v1 v2 = + case (v1, v2) of + (VRecord fs1 , VRecord fs2 ) -> + do let res = zipRecords (\_lbl -> mergeValue' sym c) fs1 fs2 + case res of + Left f -> panic "Cryptol.Eval.Value" [ "mergeValue: incompatible record values", show f ] + Right r -> pure (VRecord r) + (VTuple vs1 , VTuple vs2 ) | length vs1 == length vs2 -> + pure $ VTuple $ zipWith (mergeValue' sym c) vs1 vs2 + (VBit b1 , VBit b2 ) -> VBit <$> iteBit sym c b1 b2 + (VInteger i1 , VInteger i2 ) -> VInteger <$> iteInteger sym c i1 i2 + (VRational q1, VRational q2) -> VRational <$> iteRational sym c q1 q2 + (VFloat f1 , VFloat f2) -> VFloat <$> iteFloat sym c f1 f2 + (VWord n1 w1 , VWord n2 w2 ) | n1 == n2 -> VWord n1 <$> mergeWord sym c w1 w2 + (VSeq n1 vs1 , VSeq n2 vs2 ) | n1 == n2 -> VSeq n1 <$> memoMap sym (Nat n1) (mergeSeqMapVal sym c vs1 vs2) + (VStream vs1 , VStream vs2 ) -> VStream <$> memoMap sym Inf (mergeSeqMapVal sym c vs1 vs2) + (f1@VFun{} , f2@VFun{} ) -> lam sym $ \x -> mergeValue' sym c (fromVFun sym f1 x) (fromVFun sym f2 x) + (f1@VPoly{} , f2@VPoly{} ) -> tlam sym $ \x -> mergeValue' sym c (fromVPoly sym f1 x) (fromVPoly sym f2 x) + (_ , _ ) -> panic "Cryptol.Eval.Value" + [ "mergeValue: incompatible values", show v1, show v2 ] + +{-# INLINE mergeSeqMapVal #-} +mergeSeqMapVal :: Backend sym => + sym -> + SBit sym -> + SeqMap sym (GenValue sym)-> + SeqMap sym (GenValue sym)-> + SeqMap sym (GenValue sym) +mergeSeqMapVal sym c x y = + indexSeqMap $ \i -> + iteValue sym c (lookupSeqMap x i) (lookupSeqMap y i) diff --git a/src/Cryptol/Eval/What4.hs b/src/Cryptol/Eval/What4.hs --- a/src/Cryptol/Eval/What4.hs +++ b/src/Cryptol/Eval/What4.hs @@ -24,7 +24,7 @@ import Control.Concurrent.MVar import Control.Monad (foldM) import Control.Monad.IO.Class -import Data.Bits + import qualified Data.Map as Map import qualified Data.Set as Set import Data.Text (Text) @@ -40,6 +40,8 @@ import Cryptol.Backend import Cryptol.Backend.Monad ( EvalError(..), Unsupported(..) ) +import Cryptol.Backend.SeqMap +import Cryptol.Backend.WordValue import Cryptol.Backend.What4 import Cryptol.Eval.Generic @@ -47,9 +49,10 @@ import Cryptol.Eval.Type (TValue(..)) import Cryptol.Eval.Value + import qualified Cryptol.SHA as SHA -import Cryptol.TypeCheck.Solver.InfNat( Nat'(..), widthInteger ) +import Cryptol.TypeCheck.Solver.InfNat( Nat'(..) ) import Cryptol.Utils.Ident import Cryptol.Utils.Panic @@ -60,7 +63,6 @@ -- See also Cryptol.Prims.Eval.primTable primTable :: W4.IsSymExprBuilder sym => What4 sym -> IO EvalOpts -> Map.Map PrimIdent (Prim (What4 sym)) primTable sym getEOpts = - let w4sym = w4 sym in Map.union (suiteBPrims sym) $ Map.union (primeECPrims sym) $ Map.union (genericFloatTable sym) $ @@ -68,25 +70,9 @@ Map.fromList $ map (\(n, v) -> (prelPrim n, v)) - [ (">>$" , sshrV sym) - - -- Shifts and rotates - , ("<<" , logicShift sym "<<" shiftShrink - (w4bvShl w4sym) (w4bvLshr w4sym) - shiftLeftReindex shiftRightReindex) - , (">>" , logicShift sym ">>" shiftShrink - (w4bvLshr w4sym) (w4bvShl w4sym) - shiftRightReindex shiftLeftReindex) - , ("<<<" , logicShift sym "<<<" rotateShrink - (w4bvRol w4sym) (w4bvRor w4sym) - rotateLeftReindex rotateRightReindex) - , (">>>" , logicShift sym ">>>" rotateShrink - (w4bvRor w4sym) (w4bvRol w4sym) - rotateRightReindex rotateLeftReindex) - - -- Indexing and updates - , ("@" , indexPrim sym (indexFront_int sym) (indexFront_bits sym) (indexFront_word sym)) - , ("!" , indexPrim sym (indexBack_int sym) (indexBack_bits sym) (indexBack_word sym)) + [ -- Indexing and updates + ("@" , indexPrim sym IndexForward (indexFront_int sym) (indexFront_segs sym)) + , ("!" , indexPrim sym IndexBackward (indexFront_int sym) (indexFront_segs sym)) , ("update" , updatePrim sym (updateFrontSym_word sym) (updateFrontSym sym)) , ("updateEnd" , updatePrim sym (updateBackSym_word sym) (updateBackSym sym)) @@ -235,7 +221,7 @@ fn <- liftIO $ getUninterpFn sym ("AESKeyExpand" <> Text.pack (show k)) args (W4.BaseStructRepr ret) z <- liftIO $ W4.applySymFn (w4 sym) fn ws -- compute a sequence that projects the relevant fields from the outout tuple - pure $ VSeq (4*(k+7)) $ IndexSeqMap $ \i -> + pure $ VSeq (4*(k+7)) $ indexSeqMap $ \i -> case intIndex (fromInteger i) (size ret) of Just (Some idx) | Just W4.Refl <- W4.testEquality (ret!idx) (W4.BaseBVRepr (W4.knownNat @32)) -> fromWord32 =<< liftIO (W4.structField (w4 sym) z idx) @@ -250,7 +236,7 @@ addUninterpWarning sym "SHA-224" initSt <- liftIO (mkSHA256InitialState sym SHA.initialSHA224State) finalSt <- foldM (\st blk -> processSHA256Block sym st =<< blk) initSt blks - pure $ VSeq 7 $ IndexSeqMap \i -> + pure $ VSeq 7 $ indexSeqMap \i -> case intIndex (fromInteger i) (knownSize :: Size SHA256State) of Just (Some idx) -> do z <- liftIO $ W4.structField (w4 sym) finalSt idx @@ -268,7 +254,7 @@ addUninterpWarning sym "SHA-256" initSt <- liftIO (mkSHA256InitialState sym SHA.initialSHA256State) finalSt <- foldM (\st blk -> processSHA256Block sym st =<< blk) initSt blks - pure $ VSeq 8 $ IndexSeqMap \i -> + pure $ VSeq 8 $ indexSeqMap \i -> case intIndex (fromInteger i) (knownSize :: Size SHA256State) of Just (Some idx) -> do z <- liftIO $ W4.structField (w4 sym) finalSt idx @@ -286,7 +272,7 @@ addUninterpWarning sym "SHA-384" initSt <- liftIO (mkSHA512InitialState sym SHA.initialSHA384State) finalSt <- foldM (\st blk -> processSHA512Block sym st =<< blk) initSt blks - pure $ VSeq 6 $ IndexSeqMap \i -> + pure $ VSeq 6 $ indexSeqMap \i -> case intIndex (fromInteger i) (knownSize :: Size SHA512State) of Just (Some idx) -> do z <- liftIO $ W4.structField (w4 sym) finalSt idx @@ -304,7 +290,7 @@ addUninterpWarning sym "SHA-512" initSt <- liftIO (mkSHA512InitialState sym SHA.initialSHA512State) finalSt <- foldM (\st blk -> processSHA512Block sym st =<< blk) initSt blks - pure $ VSeq 8 $ IndexSeqMap \i -> + pure $ VSeq 8 $ indexSeqMap \i -> case intIndex (fromInteger i) (knownSize :: Size SHA512State) of Just (Some idx) -> do z <- liftIO $ W4.structField (w4 sym) finalSt idx @@ -459,7 +445,7 @@ ] toWord32 :: W4.IsSymExprBuilder sym => - What4 sym -> String -> SeqMap (What4 sym) -> Integer -> SEval (What4 sym) (W4.SymBV sym 32) + What4 sym -> String -> SeqMap (What4 sym) (GenValue (What4 sym)) -> Integer -> SEval (What4 sym) (W4.SymBV sym 32) toWord32 sym nm ss i = do x <- fromVWord sym nm =<< lookupSeqMap ss i case x of @@ -467,11 +453,10 @@ _ -> panic nm ["Unexpected word size", show (SW.bvWidth x)] fromWord32 :: W4.IsSymExprBuilder sym => W4.SymBV sym 32 -> SEval (What4 sym) (Value sym) -fromWord32 = pure . VWord 32 . pure . WordVal . SW.DBV - +fromWord32 = pure . VWord 32 . wordVal . SW.DBV toWord64 :: W4.IsSymExprBuilder sym => - What4 sym -> String -> SeqMap (What4 sym) -> Integer -> SEval (What4 sym) (W4.SymBV sym 64) + What4 sym -> String -> SeqMap (What4 sym) (GenValue (What4 sym)) -> Integer -> SEval (What4 sym) (W4.SymBV sym 64) toWord64 sym nm ss i = do x <- fromVWord sym nm =<< lookupSeqMap ss i case x of @@ -479,7 +464,7 @@ _ -> panic nm ["Unexpected word size", show (SW.bvWidth x)] fromWord64 :: W4.IsSymExprBuilder sym => W4.SymBV sym 64 -> SEval (What4 sym) (Value sym) -fromWord64 = pure . VWord 64 . pure . WordVal . SW.DBV +fromWord64 = pure . VWord 64 . wordVal . SW.DBV @@ -496,7 +481,7 @@ w3 <- toWord32 sym nm ss 3 fn <- liftIO $ getUninterpFn sym funNm argCtx (W4.BaseStructRepr argCtx) z <- liftIO $ W4.applySymFn (w4 sym) fn (Empty :> w0 :> w1 :> w2 :> w3) - pure $ VSeq 4 $ IndexSeqMap \i -> + pure $ VSeq 4 $ indexSeqMap \i -> if | i == 0 -> fromWord32 =<< liftIO (W4.structField (w4 sym) z (natIndex @0)) | i == 1 -> fromWord32 =<< liftIO (W4.structField (w4 sym) z (natIndex @1)) | i == 2 -> fromWord32 =<< liftIO (W4.structField (w4 sym) z (natIndex @2)) @@ -511,34 +496,12 @@ argCtx = W4.knownRepr -sshrV :: W4.IsSymExprBuilder sym => What4 sym -> Prim (What4 sym) -sshrV sym = - PFinPoly \n -> - PTyPoly \ix -> - PWordFun \x -> - PStrict \y -> - PPrim $ - asIndex sym ">>$" ix y >>= \case - Left i -> - do pneg <- intLessThan sym i =<< integerLit sym 0 - zneg <- do i' <- shiftShrink sym (Nat n) ix =<< intNegate sym i - amt <- wordFromInt sym n i' - w4bvShl (w4 sym) x amt - zpos <- do i' <- shiftShrink sym (Nat n) ix i - amt <- wordFromInt sym n i' - w4bvAshr (w4 sym) x amt - return (VWord (SW.bvWidth x) (WordVal <$> iteWord sym pneg zneg zpos)) - - Right wv -> - do amt <- asWordVal sym wv - return (VWord (SW.bvWidth x) (WordVal <$> w4bvAshr (w4 sym) x amt)) - indexFront_int :: W4.IsSymExprBuilder sym => What4 sym -> Nat' -> TValue -> - SeqMap (What4 sym) -> + SeqMap (What4 sym) (GenValue (What4 sym)) -> TValue -> SInteger (What4 sym) -> SEval (What4 sym) (Value sym) @@ -547,7 +510,9 @@ = lookupSeqMap xs i | (lo, Just hi) <- bounds - = foldr f def [lo .. hi] + = case foldr f Nothing [lo .. hi] of + Nothing -> raiseError sym (InvalidIndex Nothing) + Just m -> m | otherwise = liftIO (X.throw (UnsupportedSymbolicOp "unbounded integer indexing")) @@ -555,11 +520,10 @@ where w4sym = w4 sym - def = raiseError sym (InvalidIndex Nothing) - - f n y = + f n (Just y) = Just $ do p <- liftIO (W4.intEq w4sym idx =<< W4.intLit w4sym n) iteValue sym p (lookupSeqMap xs n) y + f n Nothing = Just $ lookupSeqMap xs n bounds = (case W4.rangeLowBound (W4.integerBounds idx) of @@ -581,44 +545,34 @@ (Nat n, _) -> Just n (_ , TVIntMod m) -> Just m _ -> Nothing - -indexBack_int :: - W4.IsSymExprBuilder sym => - What4 sym -> - Nat' -> - TValue -> - SeqMap (What4 sym) -> - TValue -> - SInteger (What4 sym) -> - SEval (What4 sym) (Value sym) -indexBack_int sym (Nat n) a xs ix idx = indexFront_int sym (Nat n) a (reverseSeqMap n xs) ix idx -indexBack_int _ Inf _ _ _ _ = evalPanic "Expected finite sequence" ["indexBack_int"] - -indexFront_word :: +indexFront_segs :: W4.IsSymExprBuilder sym => What4 sym -> Nat' -> TValue -> - SeqMap (What4 sym) -> + SeqMap (What4 sym) (GenValue (What4 sym)) -> TValue -> - SWord (What4 sym) -> + Integer -> + [IndexSegment (What4 sym)] -> SEval (What4 sym) (Value sym) -indexFront_word sym mblen _a xs _ix idx +indexFront_segs sym mblen _a xs _ix _idx_bits [WordIndexSegment idx] | Just i <- SW.bvAsUnsignedInteger idx = lookupSeqMap xs i | otherwise - = foldr f def idxs + = case foldr f Nothing idxs of + Nothing -> raiseError sym (InvalidIndex Nothing) + Just m -> m where w4sym = w4 sym w = SW.bvWidth idx - def = raiseError sym (InvalidIndex Nothing) - f n y = + f n (Just y) = Just $ do p <- liftIO (SW.bvEq w4sym idx =<< SW.bvLit w4sym w n) iteValue sym p (lookupSeqMap xs n) y + f n Nothing = Just $ lookupSeqMap xs n -- maximum possible in-bounds index given the bitwidth -- of the index value and the length of the sequence @@ -635,112 +589,34 @@ Just (lo, hi) -> [lo .. min hi maxIdx] _ -> [0 .. maxIdx] -indexBack_word :: - W4.IsSymExprBuilder sym => - What4 sym -> - Nat' -> - TValue -> - SeqMap (What4 sym) -> - TValue -> - SWord (What4 sym) -> - SEval (What4 sym) (Value sym) -indexBack_word sym (Nat n) a xs ix idx = indexFront_word sym (Nat n) a (reverseSeqMap n xs) ix idx -indexBack_word _ Inf _ _ _ _ = evalPanic "Expected finite sequence" ["indexBack_word"] - -indexFront_bits :: forall sym. - W4.IsSymExprBuilder sym => - What4 sym -> - Nat' -> - TValue -> - SeqMap (What4 sym) -> - TValue -> - [SBit (What4 sym)] -> - SEval (What4 sym) (Value sym) -indexFront_bits sym mblen _a xs _ix bits0 = go 0 (length bits0) bits0 - where - go :: Integer -> Int -> [W4.Pred sym] -> W4Eval sym (Value sym) - go i _k [] - -- For indices out of range, fail - | Nat n <- mblen - , i >= n - = raiseError sym (InvalidIndex (Just i)) - - | otherwise - = lookupSeqMap xs i - - go i k (b:bs) - -- Fail early when all possible indices we could compute from here - -- are out of bounds - | Nat n <- mblen - , (i `shiftL` k) >= n - = raiseError sym (InvalidIndex Nothing) - - | otherwise - = iteValue sym b - (go ((i `shiftL` 1) + 1) (k-1) bs) - (go (i `shiftL` 1) (k-1) bs) - -indexBack_bits :: - W4.IsSymExprBuilder sym => - What4 sym -> - Nat' -> - TValue -> - SeqMap (What4 sym) -> - TValue -> - [SBit (What4 sym)] -> - SEval (What4 sym) (Value sym) -indexBack_bits sym (Nat n) a xs ix idx = indexFront_bits sym (Nat n) a (reverseSeqMap n xs) ix idx -indexBack_bits _ Inf _ _ _ _ = evalPanic "Expected finite sequence" ["indexBack_bits"] - - --- | Compare a symbolic word value with a concrete integer. -wordValueEqualsInteger :: forall sym. - W4.IsSymExprBuilder sym => - What4 sym -> - WordValue (What4 sym) -> - Integer -> - W4Eval sym (W4.Pred sym) -wordValueEqualsInteger sym wv i - | wordValueSize sym wv < widthInteger i = return (W4.falsePred w4sym) - | otherwise = - case wv of - WordVal w -> liftIO (SW.bvEq w4sym w =<< SW.bvLit w4sym (SW.bvWidth w) i) - _ -> liftIO . bitsAre i =<< enumerateWordValueRev sym wv -- little-endian +indexFront_segs sym mblen _a xs _ix idx_bits segs = + do xs' <- barrelShifter sym (mergeValue sym) shiftOp mblen xs idx_bits segs + lookupSeqMap xs' 0 where - w4sym = w4 sym + shiftOp vs amt = pure (indexSeqMap (\i -> lookupSeqMap vs $! amt+i)) - bitsAre :: Integer -> [W4.Pred sym] -> IO (W4.Pred sym) - bitsAre n [] = pure (W4.backendPred w4sym (n == 0)) - bitsAre n (b : bs) = - do pb <- bitIs (testBit n 0) b - pbs <- bitsAre (n `shiftR` 1) bs - W4.andPred w4sym pb pbs - bitIs :: Bool -> W4.Pred sym -> IO (W4.Pred sym) - bitIs b x = if b then pure x else W4.notPred w4sym x - updateFrontSym :: W4.IsSymExprBuilder sym => What4 sym -> Nat' -> TValue -> - SeqMap (What4 sym) -> + SeqMap (What4 sym) (GenValue (What4 sym)) -> Either (SInteger (What4 sym)) (WordValue (What4 sym)) -> SEval (What4 sym) (Value sym) -> - SEval (What4 sym) (SeqMap (What4 sym)) + SEval (What4 sym) (SeqMap (What4 sym) (GenValue (What4 sym))) updateFrontSym sym _len _eltTy vs (Left idx) val = case W4.asInteger idx of Just i -> return $ updateSeqMap vs i val - Nothing -> return $ IndexSeqMap $ \i -> + Nothing -> return $ indexSeqMap $ \i -> do b <- intEq sym idx =<< integerLit sym i iteValue sym b val (lookupSeqMap vs i) -updateFrontSym sym _len _eltTy vs (Right wv) val = - case wv of - WordVal w | Just j <- SW.bvAsUnsignedInteger w -> - return $ updateSeqMap vs j val - _ -> - memoMap sym $ IndexSeqMap $ \i -> +updateFrontSym sym len _eltTy vs (Right wv) val = + wordValAsLit sym wv >>= \case + Just j -> return $ updateSeqMap vs j val + Nothing -> + memoMap sym len $ indexSeqMap $ \i -> do b <- wordValueEqualsInteger sym wv i iteValue sym b val (lookupSeqMap vs i) @@ -749,25 +625,25 @@ What4 sym -> Nat' -> TValue -> - SeqMap (What4 sym) -> + SeqMap (What4 sym) (GenValue (What4 sym)) -> Either (SInteger (What4 sym)) (WordValue (What4 sym)) -> SEval (What4 sym) (Value sym) -> - SEval (What4 sym) (SeqMap (What4 sym)) + SEval (What4 sym) (SeqMap (What4 sym) (GenValue (What4 sym))) updateBackSym _ Inf _ _ _ _ = evalPanic "Expected finite sequence" ["updateBackSym"] updateBackSym sym (Nat n) _eltTy vs (Left idx) val = case W4.asInteger idx of Just i -> return $ updateSeqMap vs (n - 1 - i) val - Nothing -> return $ IndexSeqMap $ \i -> + Nothing -> return $ indexSeqMap $ \i -> do b <- intEq sym idx =<< integerLit sym (n - 1 - i) iteValue sym b val (lookupSeqMap vs i) updateBackSym sym (Nat n) _eltTy vs (Right wv) val = - case wv of - WordVal w | Just j <- SW.bvAsUnsignedInteger w -> + wordValAsLit sym wv >>= \case + Just j -> return $ updateSeqMap vs (n - 1 - j) val - _ -> - memoMap sym $ IndexSeqMap $ \i -> + Nothing -> + memoMap sym (Nat n) $ indexSeqMap $ \i -> do b <- wordValueEqualsInteger sym wv (n - 1 - i) iteValue sym b val (lookupSeqMap vs i) @@ -783,36 +659,11 @@ SEval (What4 sym) (WordValue (What4 sym)) updateFrontSym_word _ Inf _ _ _ _ = evalPanic "Expected finite sequence" ["updateFrontSym_word"] -updateFrontSym_word sym (Nat _) eltTy (LargeBitsVal n bv) idx val = - LargeBitsVal n <$> updateFrontSym sym (Nat n) eltTy bv idx val - -updateFrontSym_word sym (Nat n) eltTy (WordVal bv) (Left idx) val = +updateFrontSym_word sym (Nat n) _eltTy w (Left idx) val = do idx' <- wordFromInt sym n idx - updateFrontSym_word sym (Nat n) eltTy (WordVal bv) (Right (WordVal idx')) val - -updateFrontSym_word sym (Nat n) eltTy bv (Right wv) val = - case wv of - WordVal idx - | Just j <- SW.bvAsUnsignedInteger idx -> - updateWordValue sym bv j (fromVBit <$> val) - - | WordVal bw <- bv -> - WordVal <$> - do b <- fromVBit <$> val - let sz = SW.bvWidth bw - highbit <- liftIO (SW.bvLit (w4 sym) sz (bit (fromInteger (sz-1)))) - msk <- w4bvLshr (w4 sym) highbit idx - liftIO $ - case W4.asConstantPred b of - Just True -> SW.bvOr (w4 sym) bw msk - Just False -> SW.bvAnd (w4 sym) bw =<< SW.bvNot (w4 sym) msk - Nothing -> - do q <- SW.bvFill (w4 sym) sz b - bw' <- SW.bvAnd (w4 sym) bw =<< SW.bvNot (w4 sym) msk - SW.bvXor (w4 sym) bw' =<< SW.bvAnd (w4 sym) q msk - - _ -> LargeBitsVal (wordValueSize sym wv) <$> - updateFrontSym sym (Nat n) eltTy (asBitsMap sym bv) (Right wv) val + updateWordByWord sym IndexForward w (wordVal idx') (fromVBit <$> val) +updateFrontSym_word sym (Nat _n) _eltTy w (Right idx) val = + updateWordByWord sym IndexForward w idx (fromVBit <$> val) updateBackSym_word :: @@ -824,35 +675,10 @@ Either (SInteger (What4 sym)) (WordValue (What4 sym)) -> SEval (What4 sym) (GenValue (What4 sym)) -> SEval (What4 sym) (WordValue (What4 sym)) -updateBackSym_word _ Inf _ _ _ _ = evalPanic "Expected finite sequence" ["updateBackSym_word"] - -updateBackSym_word sym (Nat _) eltTy (LargeBitsVal n bv) idx val = - LargeBitsVal n <$> updateBackSym sym (Nat n) eltTy bv idx val +updateBackSym_word _ Inf _ _ _ _ = evalPanic "Expected finite sequence" ["updateFrontSym_word"] -updateBackSym_word sym (Nat n) eltTy (WordVal bv) (Left idx) val = +updateBackSym_word sym (Nat n) _eltTy w (Left idx) val = do idx' <- wordFromInt sym n idx - updateBackSym_word sym (Nat n) eltTy (WordVal bv) (Right (WordVal idx')) val - -updateBackSym_word sym (Nat n) eltTy bv (Right wv) val = - case wv of - WordVal idx - | Just j <- SW.bvAsUnsignedInteger idx -> - updateWordValue sym bv (n - 1 - j) (fromVBit <$> val) - - | WordVal bw <- bv -> - WordVal <$> - do b <- fromVBit <$> val - let sz = SW.bvWidth bw - lowbit <- liftIO (SW.bvLit (w4 sym) sz 1) - msk <- w4bvShl (w4 sym) lowbit idx - liftIO $ - case W4.asConstantPred b of - Just True -> SW.bvOr (w4 sym) bw msk - Just False -> SW.bvAnd (w4 sym) bw =<< SW.bvNot (w4 sym) msk - Nothing -> - do q <- SW.bvFill (w4 sym) sz b - bw' <- SW.bvAnd (w4 sym) bw =<< SW.bvNot (w4 sym) msk - SW.bvXor (w4 sym) bw' =<< SW.bvAnd (w4 sym) q msk - - _ -> LargeBitsVal (wordValueSize sym wv) <$> - updateBackSym sym (Nat n) eltTy (asBitsMap sym bv) (Right wv) val + updateWordByWord sym IndexBackward w (wordVal idx') (fromVBit <$> val) +updateBackSym_word sym (Nat _n) _eltTy w (Right idx) val = + updateWordByWord sym IndexBackward w idx (fromVBit <$> val) diff --git a/src/Cryptol/F2.hs b/src/Cryptol/F2.hs --- a/src/Cryptol/F2.hs +++ b/src/Cryptol/F2.hs @@ -32,7 +32,7 @@ pmod :: Int -> Integer -> Integer -> Integer -pmod w x m = mask .&. go 0 0 (reduce 1) +pmod w x m = go degree (x .&. mask) (clearBit m degree) where degree :: Int degree = fromInteger (widthInteger m - 1) @@ -43,6 +43,7 @@ mask = bit degree - 1 + -- invariant: z and p are in the range [0..mask] go !i !z !p | i < w = go (i+1) (if testBit x i then z `xor` p else z) (reduce (p `shiftL` 1)) | otherwise = z diff --git a/src/Cryptol/ModuleSystem.hs b/src/Cryptol/ModuleSystem.hs --- a/src/Cryptol/ModuleSystem.hs +++ b/src/Cryptol/ModuleSystem.hs @@ -29,10 +29,12 @@ , renameType -- * Interfaces - , Iface(..), IfaceParams(..), IfaceDecls(..), genIface + , Iface, IfaceG(..), IfaceParams(..), IfaceDecls(..), T.genIface , IfaceTySyn, IfaceDecl(..) ) where +import Data.Map (Map) + import qualified Cryptol.Eval.Concrete as Concrete import Cryptol.ModuleSystem.Env import Cryptol.ModuleSystem.Interface @@ -44,6 +46,7 @@ import Cryptol.Parser.Name (PName) import Cryptol.Parser.NoPat (RemovePatterns) import qualified Cryptol.TypeCheck.AST as T +import qualified Cryptol.TypeCheck.Interface as T import qualified Cryptol.Utils.Ident as M -- Public Interface ------------------------------------------------------------ @@ -93,7 +96,7 @@ evalExpr e env = runModuleM env (interactive (Base.evalExpr e)) -- | Typecheck top-level declarations. -checkDecls :: [P.TopDecl PName] -> ModuleCmd (R.NamingEnv,[T.DeclGroup]) +checkDecls :: [P.TopDecl PName] -> ModuleCmd (R.NamingEnv,[T.DeclGroup], Map Name T.TySyn) checkDecls ds env = runModuleM env $ interactive $ Base.checkDecls ds @@ -105,10 +108,14 @@ noPat :: RemovePatterns a => a -> ModuleCmd a noPat a env = runModuleM env (interactive (Base.noPat a)) +-- | Rename a *use* of a value name. The distinction between uses and +-- binding is used to keep track of dependencies. renameVar :: R.NamingEnv -> PName -> ModuleCmd Name renameVar names n env = runModuleM env $ interactive $ - Base.rename M.interactiveName names (R.renameVar n) + Base.rename M.interactiveName names (R.renameVar R.NameUse n) +-- | Rename a *use* of a type name. The distinction between uses and +-- binding is used to keep track of dependencies. renameType :: R.NamingEnv -> PName -> ModuleCmd Name renameType names n env = runModuleM env $ interactive $ - Base.rename M.interactiveName names (R.renameType n) + Base.rename M.interactiveName names (R.renameType R.NameUse n) 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 @@ -12,14 +12,38 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} module Cryptol.ModuleSystem.Base where +import qualified Control.Exception as X +import Control.Monad (unless,when) +import Data.Maybe (fromMaybe) +import Data.Monoid ((<>)) +import Data.Text.Encoding (decodeUtf8') +import Data.IORef(newIORef,readIORef) +import System.Directory (doesFileExist, canonicalizePath) +import System.FilePath ( addExtension + , isAbsolute + , joinPath + , () + , normalise + , takeDirectory + , takeFileName + ) +import qualified System.IO.Error as IOE +import qualified Data.Map as Map + +import Prelude () +import Prelude.Compat hiding ( (<>) ) + + + import Cryptol.ModuleSystem.Env (DynamicEnv(..)) import Cryptol.ModuleSystem.Fingerprint import Cryptol.ModuleSystem.Interface import Cryptol.ModuleSystem.Monad -import Cryptol.ModuleSystem.Name (Name,liftSupply,PrimMap) +import Cryptol.ModuleSystem.Name (Name,liftSupply,PrimMap,ModPath(..)) import Cryptol.ModuleSystem.Env (lookupModule , LoadedModule(..) , meCoreLint, CoreLint(..) @@ -53,33 +77,21 @@ , suiteBContents, primeECContents, preludeReferenceContents ) import Cryptol.Transform.MonoValues (rewModule) -import qualified Control.Exception as X -import Control.Monad (unless,when) -import Data.Maybe (fromMaybe) -import Data.Monoid ((<>)) -import Data.Text.Encoding (decodeUtf8') -import System.Directory (doesFileExist, canonicalizePath) -import System.FilePath ( addExtension - , isAbsolute - , joinPath - , () - , normalise - , takeDirectory - , takeFileName - ) -import qualified System.IO.Error as IOE -import qualified Data.Map as Map -import Prelude () -import Prelude.Compat hiding ( (<>) ) - - -- Renaming -------------------------------------------------------------------- rename :: ModName -> R.NamingEnv -> R.RenameM a -> ModuleM a rename modName env m = do + ifaces <- getIfaces (res,ws) <- liftSupply $ \ supply -> - case R.runRenamer supply modName env m of + let info = R.RenamerInfo + { renSupply = supply + , renContext = TopModule modName + , renEnv = env + , renIfaces = ifaces + } + in + case R.runRenamer info m of (Right (a,supply'),ws) -> ((Right a,ws),supply') (Left errs,ws) -> ((Left errs,ws),supply) @@ -89,12 +101,8 @@ Left errs -> renamerErrors errs -- | Rename a module in the context of its imported modules. -renameModule :: P.Module PName - -> ModuleM (IfaceDecls,R.NamingEnv,P.Module Name) -renameModule m = do - (decls,menv) <- importIfaces (map thing (P.mImports m)) - (declsEnv,rm) <- rename (thing (mName m)) menv (R.renameModule m) - return (decls,declsEnv,rm) +renameModule :: P.Module PName -> ModuleM R.RenamedModule +renameModule m = rename (thing (mName m)) mempty (R.renameModule m) -- NoPat ----------------------------------------------------------------------- @@ -200,15 +208,18 @@ unless quiet $ withLogger logPutStrLn ("Loading module " ++ pretty (P.thing (P.mName pm))) - tcm <- optionalInstantiate =<< checkModule isrc path pm + + (nameEnv,tcmod) <- checkModule isrc path pm + tcm <- optionalInstantiate tcmod + -- extend the eval env, unless a functor. tbl <- Concrete.primTable <$> getEvalOptsAction let ?evalPrim = \i -> Right <$> Map.lookup i tbl callStacks <- getCallStacks let ?callStacks = callStacks unless (T.isParametrizedModule tcm) $ modifyEvalEnv (E.moduleEnv Concrete tcm) - loadedModule path fp tcm + loadedModule path fp nameEnv tcm return tcm where @@ -231,17 +242,6 @@ fullyQualified :: P.Import -> P.Import fullyQualified i = i { iAs = Just (iModule i) } --- | Find the interface referenced by an import, and generate the naming --- environment that it describes. -importIface :: P.Import -> ModuleM (IfaceDecls,R.NamingEnv) -importIface imp = - do Iface { .. } <- getIface (T.iModule imp) - return (ifPublic, R.interpImport imp ifPublic) - --- | Load a series of interfaces, merging their public interfaces. -importIfaces :: [P.Import] -> ModuleM (IfaceDecls,R.NamingEnv) -importIfaces is = mconcat `fmap` mapM importIface is - moduleFile :: ModName -> String -> FilePath moduleFile n = addExtension (joinPath (modNameChunks n)) @@ -299,13 +299,13 @@ addPrelude m | preludeName == P.thing (P.mName m) = m | preludeName `elem` importedMods = m - | otherwise = m { mImports = importPrelude : mImports m } + | otherwise = m { mDecls = importPrelude : mDecls m } where importedMods = map (P.iModule . P.thing) (P.mImports m) - importPrelude = P.Located + importPrelude = P.DImport P.Located { P.srcRange = emptyRange , P.thing = P.Import - { iModule = preludeName + { iModule = P.ImpTop preludeName , iAs = Nothing , iSpec = Nothing } @@ -353,23 +353,20 @@ -- | Typecheck a group of declarations. -- -- INVARIANT: This assumes that NoPat has already been run on the declarations. -checkDecls :: [P.TopDecl PName] -> ModuleM (R.NamingEnv,[T.DeclGroup]) +checkDecls :: [P.TopDecl PName] -> ModuleM (R.NamingEnv,[T.DeclGroup], Map.Map Name T.TySyn) checkDecls ds = do fe <- getFocusedEnv let params = mctxParams fe decls = mctxDecls fe names = mctxNames fe - -- introduce names for the declarations before renaming them - declsEnv <- liftSupply (R.namingEnv' (map (R.InModule interactiveName) ds)) - rds <- rename interactiveName (declsEnv `R.shadowing` names) - (traverse R.rename ds) - + (declsEnv,rds) <- rename interactiveName names + $ R.renameTopDecls interactiveName ds prims <- getPrimMap let act = TCAction { tcAction = T.tcDecls, tcLinter = declsLinter , tcPrims = prims } - ds' <- typecheck act rds params decls - return (declsEnv,ds') + (ds',tyMap) <- typecheck act rds params decls + return (declsEnv,ds',tyMap) -- | Generate the primitive map. If the prelude is currently being loaded, this -- should be generated directly from the naming environment given to the renamer @@ -390,12 +387,23 @@ [ "Unable to find the prelude" ] -- | Load a module, be it a normal module or a functor instantiation. -checkModule :: ImportSource -> ModulePath -> P.Module PName -> ModuleM T.Module +checkModule :: + ImportSource -> ModulePath -> P.Module PName -> + ModuleM (R.NamingEnv, T.Module) checkModule isrc path m = case P.mInstance m of Nothing -> checkSingleModule T.tcModule isrc path m - Just fmName -> do tf <- getLoaded (thing fmName) - checkSingleModule (T.tcModuleInst tf) isrc path m + Just fmName -> + do mbtf <- getLoadedMaybe (thing fmName) + case mbtf of + Just tf -> + do renThis <- io $ newIORef (lmNamingEnv tf) + let how = T.tcModuleInst renThis (lmModule tf) + (_,m') <- checkSingleModule how isrc path m + newEnv <- io $ readIORef renThis + pure (newEnv,m') + Nothing -> panic "checkModule" + [ "Functor of module instantiation not loaded" ] -- | Typecheck a single module. If the module is an instantiation @@ -406,7 +414,7 @@ ImportSource {- ^ why are we loading this -} -> ModulePath {- path -} -> P.Module PName {- ^ module to check -} -> - ModuleM T.Module + ModuleM (R.NamingEnv,T.Module) checkSingleModule how isrc path m = do -- check that the name of the module matches expectations @@ -432,13 +440,13 @@ npm <- noPat nim -- rename everything - (tcEnv,declsEnv,scm) <- renameModule npm + renMod <- renameModule npm -- when generating the prim map for the typechecker, if we're checking the -- prelude, we have to generate the map from the renaming environment, as we -- don't have the interface yet. prims <- if thing (mName m) == preludeName - then return (R.toPrimMap declsEnv) + then return (R.toPrimMap (R.rmDefines renMod)) else getPrimMap -- typecheck @@ -447,11 +455,12 @@ , tcPrims = prims } - tcm0 <- typecheck act scm noIfaceParams tcEnv + tcm0 <- typecheck act (R.rmModule renMod) noIfaceParams (R.rmImported renMod) let tcm = tcm0 -- fromMaybe tcm0 (addModParams tcm0) - liftSupply (`rewModule` tcm) + rewMod <- liftSupply (`rewModule` tcm) + pure (R.rmInScope renMod,rewMod) data TCLinter o = TCLinter { lintCheck :: @@ -473,11 +482,11 @@ , lintModule = Nothing } -declsLinter :: TCLinter [ T.DeclGroup ] +declsLinter :: TCLinter ([ T.DeclGroup ], a) declsLinter = TCLinter - { lintCheck = \ds' i -> case TcSanity.tcDecls i ds' of - Left err -> Left err - Right os -> Right os + { lintCheck = \(ds',_) i -> case TcSanity.tcDecls i ds' of + Left err -> Left err + Right os -> Right os , lintModule = Nothing } @@ -529,16 +538,17 @@ -- | Generate input for the typechecker. genInferInput :: Range -> PrimMap -> IfaceParams -> IfaceDecls -> ModuleM T.InferInput -genInferInput r prims params env = do +genInferInput r prims params env' = do seeds <- getNameSeeds monoBinds <- getMonoBinds - cfg <- getSolverConfig solver <- getTCSolver supply <- getSupply searchPath <- getSearchPath callStacks <- getCallStacks -- TODO: include the environment needed by the module + let env = flatPublicDecls env' + -- XXX: we should really just pass this directly return T.InferInput { T.inpRange = r , T.inpVars = Map.map ifDeclSig (ifDecls env) @@ -548,7 +558,6 @@ , T.inpNameSeeds = seeds , T.inpMonoBinds = monoBinds , T.inpCallStacks = callStacks - , T.inpSolverConfig = cfg , T.inpSearchPath = searchPath , T.inpSupply = supply , T.inpPrimNames = prims 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 @@ -11,6 +11,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} module Cryptol.ModuleSystem.Env where #ifndef RELOCATABLE @@ -24,6 +25,7 @@ import qualified Cryptol.ModuleSystem.NamingEnv as R import Cryptol.Parser.AST import qualified Cryptol.TypeCheck as T +import qualified Cryptol.TypeCheck.Interface as T import qualified Cryptol.TypeCheck.AST as T import Cryptol.Utils.PP (PP(..),text,parens,NameDisp) @@ -31,6 +33,7 @@ import Control.Monad (guard,mplus) import qualified Control.Exception as X import Data.Function (on) +import Data.Set(Set) import Data.Map (Map) import qualified Data.Map as Map import Data.Semigroup @@ -60,9 +63,6 @@ , meNameSeeds :: T.NameSeeds -- ^ A source of new names for the type checker. - , meSolverConfig :: T.SolverConfig - -- ^ Configuration settings for the SMT solver used for type-checking. - , meEvalEnv :: EvalEnv -- ^ The evaluation environment. Contains the values for all loaded -- modules, both public and private. @@ -150,12 +150,6 @@ , meSearchPath = searchPath , meDynEnv = mempty , meMonoBinds = True - , meSolverConfig = T.SolverConfig - { T.solverPath = "z3" - , T.solverArgs = [ "-smt2", "-in" ] - , T.solverVerbose = 0 - , T.solverPreludePath = searchPath - } , meCoreLint = NoCoreLint , meSupply = emptySupply } @@ -194,91 +188,79 @@ -- or type check new expressions. data ModContext = ModContext { mctxParams :: IfaceParams + , mctxExported :: Set Name , mctxDecls :: IfaceDecls + -- ^ Should contain at least names in NamingEnv, but may have more , mctxNames :: R.NamingEnv + -- ^ What's in scope inside the module , mctxNameDisp :: NameDisp - , mctxTypeProvenace :: Map Name DeclProvenance - , mctxValueProvenance :: Map Name DeclProvenance } --- | Specifies how a declared name came to be in scope. -data DeclProvenance = - NameIsImportedFrom ModName - | NameIsLocalPublic - | NameIsLocalPrivate - | NameIsParameter - | NameIsDynamicDecl - deriving (Eq,Ord) +-- 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. +instance Semigroup ModContext where + x <> y = ModContext { mctxParams = jnParams (mctxParams x) (mctxParams y) + , mctxExported = mctxExported x <> mctxExported y + , mctxDecls = mctxDecls x <> mctxDecls y + , mctxNames = names + , mctxNameDisp = R.toNameDisp names + } + where + names = mctxNames x `R.shadowing` mctxNames y + jnParams a b + | isEmptyIfaceParams a = b + | isEmptyIfaceParams b = a + | otherwise = + panic "ModContext" [ "Cannot combined 2 parameterized contexts" ] --- | 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 :: ModuleEnv -> ModContext -focusedEnv me = - ModContext - { mctxParams = parameters - , mctxDecls = mconcat (dynDecls : localDecls : importedDecls) - , mctxNames = namingEnv - , mctxNameDisp = R.toNameDisp namingEnv - , mctxTypeProvenace = fst provenance - , mctxValueProvenance = snd provenance - } +instance Monoid ModContext where + mempty = ModContext { mctxParams = noIfaceParams + , mctxDecls = mempty + , mctxExported = mempty + , mctxNames = mempty + , mctxNameDisp = R.toNameDisp mempty + } - where - (importedNames,importedDecls,importedProvs) = unzip3 (map loadImport imports) - localDecls = publicDecls `mappend` privateDecls - localNames = R.unqualifiedEnv localDecls `mappend` - R.modParamsNamingEnv parameters - dynDecls = deIfaceDecls (meDynEnv me) - dynNames = deNames (meDynEnv me) - namingEnv = dynNames `R.shadowing` - localNames `R.shadowing` - mconcat importedNames - provenance = shadowProvs - $ declsProv NameIsDynamicDecl dynDecls - : declsProv NameIsLocalPublic publicDecls - : declsProv NameIsLocalPrivate privateDecls - : paramProv parameters - : importedProvs +modContextOf :: ModName -> ModuleEnv -> Maybe ModContext +modContextOf mname me = + do lm <- lookupModule mname me + let localIface = lmInterface lm + localNames = lmNamingEnv lm + loadedDecls = map (ifPublic . lmInterface) + $ getLoadedModules (meLoadedModules me) + pure ModContext + { mctxParams = ifParams localIface + , mctxExported = ifaceDeclsNames (ifPublic localIface) + , mctxDecls = mconcat (ifPrivate localIface : loadedDecls) + , mctxNames = localNames + , mctxNameDisp = R.toNameDisp localNames + } - (imports, parameters, publicDecls, privateDecls) = - case meFocusedModule me of - Nothing -> (mempty, noIfaceParams, mempty, mempty) - Just fm -> - case lookupModule fm me of - Just lm -> - let Iface { .. } = lmInterface lm - in (T.mImports (lmModule lm), ifParams, ifPublic, ifPrivate) - Nothing -> panic "focusedEnv" ["Focused module is not loaded."] +dynModContext :: ModuleEnv -> ModContext +dynModContext me = mempty { mctxNames = dynNames + , mctxNameDisp = R.toNameDisp dynNames + , mctxDecls = deIfaceDecls (meDynEnv me) + } + where dynNames = deNames (meDynEnv me) - loadImport imp = - case lookupModule (iModule imp) me of - Just lm -> - let decls = ifPublic (lmInterface lm) - in ( R.interpImport imp decls - , decls - , declsProv (NameIsImportedFrom (iModule imp)) decls - ) - Nothing -> panic "focusedEnv" - [ "Missing imported module: " ++ show (pp (iModule imp)) ] - -- earlier ones shadow - shadowProvs ps = let (tss,vss) = unzip ps - in (Map.unions tss, Map.unions vss) - paramProv IfaceParams { .. } = (doMap ifParamTypes, doMap ifParamFuns) - where doMap mp = const NameIsParameter <$> mp - - declsProv prov IfaceDecls { .. } = - ( Map.unions [ doMap ifTySyns, doMap ifNewtypes, doMap ifAbstractTypes ] - , doMap ifDecls - ) - where doMap mp = const prov <$> mp - +-- | 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 :: ModuleEnv -> ModContext +focusedEnv me = + case meFocusedModule me 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) ] + -- Loaded Modules -------------------------------------------------------------- @@ -350,9 +332,11 @@ -- For files we just use the cononical path, for in memory things we -- use their label. + , lmNamingEnv :: !R.NamingEnv + -- ^ What's in scope in this module + , lmInterface :: Iface - -- ^ The module's interface. This is for convenient. At the moment - -- we have the whole module in 'lmModule', so this could be computer. + -- ^ The module's interface. , lmModule :: T.Module -- ^ The actual type-checked module @@ -378,8 +362,9 @@ -- | Add a freshly loaded module. If it was previously loaded, then -- the new version is ignored. addLoadedModule :: - ModulePath -> String -> Fingerprint -> T.Module -> LoadedModules -> LoadedModules -addLoadedModule path ident fp tm lm + ModulePath -> String -> Fingerprint -> R.NamingEnv -> T.Module -> + LoadedModules -> LoadedModules +addLoadedModule path ident fp nameEnv tm lm | isLoaded (T.mName tm) lm = lm | T.isParametrizedModule tm = lm { lmLoadedParamModules = loaded : lmLoadedParamModules lm } @@ -390,7 +375,8 @@ { lmName = T.mName tm , lmFilePath = path , lmModuleId = ident - , lmInterface = genIface tm + , lmNamingEnv = nameEnv + , lmInterface = T.genIface tm , lmModule = tm , lmFingerprint = fp } @@ -414,37 +400,43 @@ data DynamicEnv = DEnv { deNames :: R.NamingEnv , deDecls :: [T.DeclGroup] + , deTySyns :: Map Name T.TySyn , deEnv :: EvalEnv } deriving Generic instance Semigroup DynamicEnv where de1 <> de2 = DEnv - { deNames = deNames de1 <> deNames de2 - , deDecls = deDecls de1 <> deDecls de2 - , deEnv = deEnv de1 <> deEnv de2 + { deNames = deNames de1 <> deNames de2 + , deDecls = deDecls de1 <> deDecls de2 + , deTySyns = deTySyns de1 <> deTySyns de2 + , deEnv = deEnv de1 <> deEnv de2 } instance Monoid DynamicEnv where mempty = DEnv - { deNames = mempty - , deDecls = mempty - , deEnv = mempty + { deNames = mempty + , deDecls = mempty + , deTySyns = mempty + , deEnv = mempty } mappend de1 de2 = de1 <> de2 -- | Build 'IfaceDecls' that correspond to all of the bindings in the -- dynamic environment. -- --- XXX: if we ever add type synonyms or newtypes at the REPL, revisit +-- XXX: if we add newtypes, etc. at the REPL, revisit -- this. deIfaceDecls :: DynamicEnv -> IfaceDecls -deIfaceDecls DEnv { deDecls = dgs } = - mconcat [ IfaceDecls - { ifTySyns = Map.empty - , ifNewtypes = Map.empty - , ifAbstractTypes = Map.empty - , ifDecls = Map.singleton (ifDeclName ifd) ifd - } - | decl <- concatMap T.groupDecls dgs - , let ifd = mkIfaceDecl decl - ] +deIfaceDecls DEnv { deDecls = dgs, deTySyns = tySyns } = + IfaceDecls { ifTySyns = tySyns + , ifNewtypes = Map.empty + , ifAbstractTypes = Map.empty + , ifDecls = decls + , ifModules = Map.empty + } + where + decls = mconcat + [ Map.singleton (ifDeclName ifd) ifd + | decl <- concatMap T.groupDecls dgs + , let ifd = T.mkIfaceDecl decl + ] diff --git a/src/Cryptol/ModuleSystem/Exports.hs b/src/Cryptol/ModuleSystem/Exports.hs --- a/src/Cryptol/ModuleSystem/Exports.hs +++ b/src/Cryptol/ModuleSystem/Exports.hs @@ -3,63 +3,80 @@ import Data.Set(Set) import qualified Data.Set as Set +import Data.Map(Map) +import qualified Data.Map as Map import Data.Foldable(fold) import Control.DeepSeq(NFData) import GHC.Generics (Generic) import Cryptol.Parser.AST -import Cryptol.Parser.Names +import Cryptol.Parser.Names(namesD,tnamesD,tnamesNT) +import Cryptol.ModuleSystem.Name -modExports :: Ord name => Module name -> ExportSpec name +modExports :: Ord name => ModuleG mname name -> ExportSpec name modExports m = fold (concat [ exportedNames d | d <- mDecls m ]) - where - names by td = [ td { tlValue = thing n } | n <- fst (by (tlValue td)) ] - exportedNames (Decl td) = map exportBind (names namesD td) - ++ map exportType (names tnamesD td) - exportedNames (DPrimType t) = [ exportType (thing . primTName <$> t) ] - exportedNames (TDNewtype nt) = map exportType (names tnamesNT nt) - exportedNames (Include {}) = [] - exportedNames (DParameterFun {}) = [] - exportedNames (DParameterType {}) = [] - exportedNames (DParameterConstraint {}) = [] +exportedNames :: Ord name => TopDecl name -> [ExportSpec name] +exportedNames (Decl td) = map exportBind (names namesD td) + ++ map exportType (names tnamesD td) +exportedNames (DPrimType t) = [ exportType (thing . primTName <$> t) ] +exportedNames (TDNewtype nt) = map exportType (names tnamesNT nt) +exportedNames (Include {}) = [] +exportedNames (DImport {}) = [] +exportedNames (DParameterFun {}) = [] +exportedNames (DParameterType {}) = [] +exportedNames (DParameterConstraint {}) = [] +exportedNames (DModule nested) = + case tlValue nested of + NestedModule x -> + [exportName NSModule nested { tlValue = thing (mName x) }] +names :: (a -> ([Located a'], b)) -> TopLevel a -> [TopLevel a'] +names by td = [ td { tlValue = thing n } | n <- fst (by (tlValue td)) ] -data ExportSpec name = ExportSpec { eTypes :: Set name - , eBinds :: Set name - } deriving (Show, Generic) +newtype ExportSpec name = ExportSpec (Map Namespace (Set name)) + deriving (Show, Generic) + instance NFData name => NFData (ExportSpec name) instance Ord name => Semigroup (ExportSpec name) where - l <> r = ExportSpec { eTypes = eTypes l <> eTypes r - , eBinds = eBinds l <> eBinds r - } + ExportSpec l <> ExportSpec r = ExportSpec (Map.unionWith Set.union l r) instance Ord name => Monoid (ExportSpec name) where - mempty = ExportSpec { eTypes = mempty, eBinds = mempty } - mappend = (<>) + mempty = ExportSpec Map.empty +exportName :: Ord name => Namespace -> TopLevel name -> ExportSpec name +exportName ns n + | tlExport n == Public = ExportSpec + $ Map.singleton ns + $ Set.singleton (tlValue n) + | otherwise = mempty + +exported :: Namespace -> ExportSpec name -> Set name +exported ns (ExportSpec mp) = Map.findWithDefault Set.empty ns mp + -- | Add a binding name to the export list, if it should be exported. exportBind :: Ord name => TopLevel name -> ExportSpec name -exportBind n - | tlExport n == Public = mempty { eBinds = Set.singleton (tlValue n) } - | otherwise = mempty +exportBind = exportName NSValue -- | Add a type synonym name to the export list, if it should be exported. exportType :: Ord name => TopLevel name -> ExportSpec name -exportType n - | tlExport n == Public = mempty { eTypes = Set.singleton (tlValue n) } - | otherwise = mempty +exportType = exportName NSType + + +isExported :: Ord name => Namespace -> name -> ExportSpec name -> Bool +isExported ns x (ExportSpec s) = + case Map.lookup ns s of + Nothing -> False + Just mp -> Set.member x mp + -- | Check to see if a binding is exported. isExportedBind :: Ord name => name -> ExportSpec name -> Bool -isExportedBind n = Set.member n . eBinds +isExportedBind = isExported NSValue -- | Check to see if a type synonym is exported. isExportedType :: Ord name => name -> ExportSpec name -> Bool -isExportedType n = Set.member n . eTypes - - - +isExportedType = isExported NSType diff --git a/src/Cryptol/ModuleSystem/InstantiateModule.hs b/src/Cryptol/ModuleSystem/InstantiateModule.hs --- a/src/Cryptol/ModuleSystem/InstantiateModule.hs +++ b/src/Cryptol/ModuleSystem/InstantiateModule.hs @@ -1,4 +1,5 @@ {-# Language FlexibleInstances, PatternGuards #-} +{-# Language BlockArguments #-} -- | Assumes that local names do not shadow top level names. module Cryptol.ModuleSystem.InstantiateModule ( instantiateModule @@ -10,12 +11,13 @@ import qualified Data.Map as Map import MonadLib(ReaderT,runReaderT,ask) +import Cryptol.Utils.Panic(panic) +import Cryptol.Utils.Ident(ModName,modParamIdent) import Cryptol.Parser.Position(Located(..)) import Cryptol.ModuleSystem.Name import Cryptol.TypeCheck.AST import Cryptol.TypeCheck.Subst(listParamSubst, apSubst) import Cryptol.TypeCheck.SimpType(tRebuild) -import Cryptol.Utils.Ident(ModName,modParamIdent) {- XXX: Should we simplify constraints in the instantiated modules? @@ -33,15 +35,23 @@ ModName {- ^ Name of the new module -} -> Map TParam Type {- ^ Type params -} -> Map Name Expr {- ^ Value parameters -} -> - m ([Located Prop], Module) - -- ^ Instantiated constraints, fresh module, new supply -instantiateModule func newName tpMap vpMap = - runReaderT newName $ + m (Name -> Name, [Located Prop], Module) + -- ^ Renaming, instantiated constraints, fresh module, new supply +instantiateModule func newName tpMap vpMap + | not (null (mSubModules func)) = + panic "instantiateModule" + [ "XXX: we don't support functors with nested moduels yet." ] + | otherwise = + runReaderT (TopModule newName) $ do let oldVpNames = Map.keys vpMap newVpNames <- mapM freshParamName (Map.keys vpMap) let vpNames = Map.fromList (zip oldVpNames newVpNames) env <- computeEnv func tpMap vpNames + let ren x = case nameNamespace x of + NSValue -> Map.findWithDefault x x (funNameMap env) + NSType -> Map.findWithDefault x x (tyNameMap env) + NSModule -> x let rnMp :: Inst a => (a -> Name) -> Map Name a -> Map Name a rnMp f m = Map.fromList [ (f x, x) | a <- Map.elems m @@ -60,7 +70,8 @@ let renamedDecls = inst env (mDecls func) paramDecls = map (mkParamDecl su vpNames) (Map.toList vpMap) - return ( goals + return ( ren + , goals , Module { mName = newName , mExports = renamedExports @@ -72,6 +83,9 @@ , mParamConstraints = [] , mParamFuns = Map.empty , mDecls = paramDecls ++ renamedDecls + + , mSubModules = mempty + , mFunctors = mempty } ) where @@ -110,7 +124,7 @@ -------------------------------------------------------------------------------- -type InstM = ReaderT ModName +type InstM = ReaderT ModPath -- | Generate a new instance of a declared name. freshenName :: FreshM m => Name -> InstM m Name @@ -119,13 +133,15 @@ let sys = case nameInfo x of Declared _ s -> s _ -> UserName - liftSupply (mkDeclared m sys (nameIdent x) (nameFixity x) (nameLoc x)) + liftSupply (mkDeclared (nameNamespace x) + m sys (nameIdent x) (nameFixity x) (nameLoc x)) freshParamName :: FreshM m => Name -> InstM m Name freshParamName x = do m <- ask let newName = modParamIdent (nameIdent x) - liftSupply (mkDeclared m UserName newName (nameFixity x) (nameLoc x)) + liftSupply (mkDeclared (nameNamespace x) + m UserName newName (nameFixity x) (nameLoc x)) @@ -263,11 +279,14 @@ where y = Map.findWithDefault x x (tyNameMap env) instance Inst (ExportSpec Name) where - inst env es = ExportSpec { eTypes = Set.map instT (eTypes es) - , eBinds = Set.map instV (eBinds es) - } - where instT x = Map.findWithDefault x x (tyNameMap env) - instV x = Map.findWithDefault x x (funNameMap env) + inst env (ExportSpec spec) = ExportSpec (Map.mapWithKey doNS spec) + where + doNS ns = + case ns of + NSType -> Set.map \x -> Map.findWithDefault x x (tyNameMap env) + NSValue -> Set.map \x -> Map.findWithDefault x x (funNameMap env) + NSModule -> id + instance Inst TySyn where inst env ts = TySyn { tsName = instTyName env x 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 @@ -12,24 +12,27 @@ {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RecordWildCards #-} module Cryptol.ModuleSystem.Interface ( - Iface(..) + Iface + , IfaceG(..) , IfaceDecls(..) , IfaceTySyn, ifTySynName , IfaceNewtype - , IfaceDecl(..), mkIfaceDecl + , IfaceDecl(..) , IfaceParams(..) - , genIface + , emptyIface , ifacePrimMap , noIfaceParams + , isEmptyIfaceParams + , ifaceIsFunctor + , flatPublicIface + , flatPublicDecls + , filterIfaceDecls + , ifaceDeclsNames ) where -import Cryptol.ModuleSystem.Name -import Cryptol.TypeCheck.AST -import Cryptol.Utils.Ident (ModName) -import Cryptol.Utils.Panic(panic) -import Cryptol.Parser.Position(Located) - +import Data.Set(Set) +import qualified Data.Set as Set import qualified Data.Map as Map import Data.Semigroup import Data.Text (Text) @@ -40,15 +43,52 @@ import Prelude () import Prelude.Compat +import Cryptol.ModuleSystem.Name +import Cryptol.Utils.Ident (ModName) +import Cryptol.Utils.Panic(panic) +import Cryptol.Utils.Fixity(Fixity) +import Cryptol.Parser.AST(Pragma) +import Cryptol.Parser.Position(Located) +import Cryptol.TypeCheck.Type + -- | The resulting interface generated by a module that has been typechecked. -data Iface = Iface - { ifModName :: !ModName -- ^ Module name +data IfaceG mname = Iface + { ifModName :: !mname -- ^ Module name , ifPublic :: IfaceDecls -- ^ Exported definitions , ifPrivate :: IfaceDecls -- ^ Private defintiions , ifParams :: IfaceParams -- ^ Uninterpreted constants (aka module params) } deriving (Show, Generic, NFData) +ifaceIsFunctor :: IfaceG mname -> Bool +ifaceIsFunctor = not . isEmptyIfaceParams . ifParams + +-- | The public declarations in all modules, including nested +-- The modules field contains public functors +-- Assumes that we are not a functor. +flatPublicIface :: IfaceG mname -> IfaceDecls +flatPublicIface iface = flatPublicDecls (ifPublic iface) + + +flatPublicDecls :: IfaceDecls -> IfaceDecls +flatPublicDecls ifs = mconcat ( ifs { ifModules = fun } + : map flatPublicIface (Map.elems nofun) + ) + + where + (fun,nofun) = Map.partition ifaceIsFunctor (ifModules ifs) + + +type Iface = IfaceG ModName + +emptyIface :: mname -> IfaceG mname +emptyIface nm = Iface + { ifModName = nm + , ifPublic = mempty + , ifPrivate = mempty + , ifParams = noIfaceParams + } + data IfaceParams = IfaceParams { ifParamTypes :: Map.Map Name ModTParam , ifParamConstraints :: [Located Prop] -- ^ Constraints on param. types @@ -62,29 +102,57 @@ , ifParamFuns = Map.empty } +isEmptyIfaceParams :: IfaceParams -> Bool +isEmptyIfaceParams IfaceParams { .. } = + Map.null ifParamTypes && null ifParamConstraints && Map.null ifParamFuns + data IfaceDecls = IfaceDecls { ifTySyns :: Map.Map Name IfaceTySyn , ifNewtypes :: Map.Map Name IfaceNewtype , ifAbstractTypes :: Map.Map Name IfaceAbstractType , ifDecls :: Map.Map Name IfaceDecl + , ifModules :: !(Map.Map Name (IfaceG Name)) } deriving (Show, Generic, NFData) +filterIfaceDecls :: (Name -> Bool) -> IfaceDecls -> IfaceDecls +filterIfaceDecls p ifs = IfaceDecls + { ifTySyns = filterMap (ifTySyns ifs) + , ifNewtypes = filterMap (ifNewtypes ifs) + , ifAbstractTypes = filterMap (ifAbstractTypes ifs) + , ifDecls = filterMap (ifDecls ifs) + , ifModules = filterMap (ifModules ifs) + } + where + filterMap :: Map.Map Name a -> Map.Map Name a + filterMap = Map.filterWithKey (\k _ -> p k) + +ifaceDeclsNames :: IfaceDecls -> Set Name +ifaceDeclsNames i = Set.unions [ Map.keysSet (ifTySyns i) + , Map.keysSet (ifNewtypes i) + , Map.keysSet (ifAbstractTypes i) + , Map.keysSet (ifDecls i) + , Map.keysSet (ifModules i) + ] + + instance Semigroup IfaceDecls where l <> r = IfaceDecls { ifTySyns = Map.union (ifTySyns l) (ifTySyns r) , ifNewtypes = Map.union (ifNewtypes l) (ifNewtypes r) , ifAbstractTypes = Map.union (ifAbstractTypes l) (ifAbstractTypes r) , ifDecls = Map.union (ifDecls l) (ifDecls r) + , ifModules = Map.union (ifModules l) (ifModules r) } instance Monoid IfaceDecls where - mempty = IfaceDecls Map.empty Map.empty Map.empty Map.empty + mempty = IfaceDecls Map.empty Map.empty Map.empty Map.empty Map.empty mappend l r = l <> r mconcat ds = IfaceDecls { ifTySyns = Map.unions (map ifTySyns ds) , ifNewtypes = Map.unions (map ifNewtypes ds) , ifAbstractTypes = Map.unions (map ifAbstractTypes ds) , ifDecls = Map.unions (map ifDecls ds) + , ifModules = Map.unions (map ifModules ds) } type IfaceTySyn = TySyn @@ -103,61 +171,6 @@ , ifDeclFixity :: Maybe Fixity -- ^ Fixity information , ifDeclDoc :: Maybe Text -- ^ Documentation } deriving (Show, Generic, NFData) - -mkIfaceDecl :: Decl -> IfaceDecl -mkIfaceDecl d = IfaceDecl - { ifDeclName = dName d - , ifDeclSig = dSignature d - , ifDeclPragmas = dPragmas d - , ifDeclInfix = dInfix d - , ifDeclFixity = dFixity d - , ifDeclDoc = dDoc d - } - --- | Generate an Iface from a typechecked module. -genIface :: Module -> Iface -genIface m = Iface - { ifModName = mName m - - , ifPublic = IfaceDecls - { ifTySyns = tsPub - , ifNewtypes = ntPub - , ifAbstractTypes = atPub - , ifDecls = dPub - } - - , ifPrivate = IfaceDecls - { ifTySyns = tsPriv - , ifNewtypes = ntPriv - , ifAbstractTypes = atPriv - , ifDecls = dPriv - } - - , ifParams = IfaceParams - { ifParamTypes = mParamTypes m - , ifParamConstraints = mParamConstraints m - , ifParamFuns = mParamFuns m - } - } - where - - (tsPub,tsPriv) = - Map.partitionWithKey (\ qn _ -> qn `isExportedType` mExports m ) - (mTySyns m) - (ntPub,ntPriv) = - Map.partitionWithKey (\ qn _ -> qn `isExportedType` mExports m ) - (mNewtypes m) - - (atPub,atPriv) = - Map.partitionWithKey (\qn _ -> qn `isExportedType` mExports m) - (mPrimTypes m) - - (dPub,dPriv) = - Map.partitionWithKey (\ qn _ -> qn `isExportedBind` mExports m) - $ Map.fromList [ (qn,mkIfaceDecl d) | dg <- mDecls m - , d <- groupDecls dg - , let qn = dName d - ] -- | Produce a PrimMap from an interface. 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 @@ -21,6 +21,7 @@ import Cryptol.ModuleSystem.Interface import Cryptol.ModuleSystem.Name (FreshM(..),Supply) import Cryptol.ModuleSystem.Renamer (RenamerError(),RenamerWarning()) +import Cryptol.ModuleSystem.NamingEnv(NamingEnv) import qualified Cryptol.Parser as Parser import qualified Cryptol.Parser.AST as P import Cryptol.Parser.Position (Located) @@ -201,7 +202,7 @@ FailedToParameterizeModDefs x xs -> hang (text "[error] Parameterized module" <+> pp x <+> text "has polymorphic parameters:") - 4 (hsep $ punctuate comma $ map pp xs) + 4 (commaSep (map pp xs)) NotAParameterizedModule x -> text "[error] Module" <+> pp x <+> text "does not have parameters." @@ -463,12 +464,16 @@ _ -> return (FromModule noModuleName) getIface :: P.ModName -> ModuleM Iface -getIface mn = - do env <- ModuleT get - case lookupModule mn env of - Just lm -> return (lmInterface lm) - Nothing -> panic "ModuleSystem" ["Interface not available", show (pp mn)] +getIface mn = ($ mn) <$> getIfaces +getIfaces :: ModuleM (P.ModName -> Iface) +getIfaces = doLookup <$> ModuleT get + where + doLookup env mn = + case lookupModule mn env of + Just lm -> lmInterface lm + Nothing -> panic "ModuleSystem" ["Interface not available", show (pp mn)] + getLoaded :: P.ModName -> ModuleM T.Module getLoaded mn = ModuleT $ do env <- get @@ -505,14 +510,16 @@ env <- get set $! env { meLoadedModules = removeLoadedModule rm (meLoadedModules env) } -loadedModule :: ModulePath -> Fingerprint -> T.Module -> ModuleM () -loadedModule path fp m = ModuleT $ do +loadedModule :: + ModulePath -> Fingerprint -> NamingEnv -> T.Module -> ModuleM () +loadedModule path fp nameEnv m = ModuleT $ do env <- get ident <- case path of InFile p -> unModuleT $ io (canonicalizePath p) InMem l _ -> pure l - set $! env { meLoadedModules = addLoadedModule path ident fp m (meLoadedModules env) } + set $! env { meLoadedModules = addLoadedModule path ident fp nameEnv m + (meLoadedModules env) } modifyEvalEnv :: (EvalEnv -> E.Eval EvalEnv) -> ModuleM () modifyEvalEnv f = ModuleT $ do @@ -569,16 +576,6 @@ setDynEnv denv = ModuleT $ do me <- get set $! me { meDynEnv = denv } - -setSolver :: T.SolverConfig -> ModuleM () -setSolver cfg = ModuleT $ do - me <- get - set $! me { meSolverConfig = cfg } - -getSolverConfig :: ModuleM T.SolverConfig -getSolverConfig = ModuleT $ do - me <- get - return (meSolverConfig me) -- | Usefule for logging. For example: @withLogger logPutStrLn "Hello"@ withLogger :: (Logger -> a -> IO b) -> a -> ModuleM b 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 @@ -14,6 +14,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} -- for the instances of RunM and BaseM {-# LANGUAGE UndecidableInstances #-} @@ -26,10 +27,13 @@ , nameInfo , nameLoc , nameFixity + , nameNamespace , asPrim - , cmpNameLexical - , cmpNameDisplay + , asOrigName , ppLocName + , Namespace(..) + , ModPath(..) + , cmpNameDisplay -- ** Creation , mkDeclared @@ -49,33 +53,35 @@ , lookupPrimType ) where -import Cryptol.Parser.Position (Range,Located(..),emptyRange) -import Cryptol.Utils.Fixity -import Cryptol.Utils.Ident -import Cryptol.Utils.Panic -import Cryptol.Utils.PP - - import Control.DeepSeq import qualified Data.Map as Map import qualified Data.Monoid as M -import Data.Ord (comparing) -import qualified Data.Text as Text -import Data.Char(isAlpha,toUpper) import GHC.Generics (Generic) import MonadLib import Prelude () import Prelude.Compat +import qualified Data.Text as Text +import Data.Char(isAlpha,toUpper) + +import Cryptol.Parser.Position (Range,Located(..),emptyRange) +import Cryptol.Utils.Fixity +import Cryptol.Utils.Ident +import Cryptol.Utils.Panic +import Cryptol.Utils.PP + + + -- Names ----------------------------------------------------------------------- -- | Information about the binding site of the name. -data NameInfo = Declared !ModName !NameSource +data NameInfo = Declared !ModPath !NameSource -- ^ This name refers to a declaration from this module | Parameter -- ^ This name is a parameter (function or type) deriving (Eq, Show, Generic, NFData) + data Name = Name { nUnique :: {-# UNPACK #-} !Int -- ^ INVARIANT: this field uniquely identifies a name for one -- session with the Cryptol library. Names are unique to @@ -84,6 +90,8 @@ , nInfo :: !NameInfo -- ^ Information about the origin of this name. + , nNamespace :: !Namespace + , nIdent :: !Ident -- ^ The name of the identifier @@ -100,6 +108,7 @@ data NameSource = SystemName | UserName deriving (Generic, NFData, Show, Eq) + instance Eq Name where a == b = compare a b == EQ a /= b = compare a b /= EQ @@ -107,54 +116,41 @@ instance Ord Name where compare a b = compare (nUnique a) (nUnique b) --- | Compare two names lexically. -cmpNameLexical :: Name -> Name -> Ordering -cmpNameLexical l r = - case (nameInfo l, nameInfo r) of - (Declared nsl _,Declared nsr _) -> - case compare nsl nsr of - EQ -> comparing nameIdent l r - cmp -> cmp - (Parameter,Parameter) -> comparing nameIdent l r - - (Declared nsl _,Parameter) -> compare (modNameToText nsl) - (identText (nameIdent r)) - (Parameter,Declared nsr _) -> compare (identText (nameIdent l)) - (modNameToText nsr) - - -- | Compare two names by the way they would be displayed. +-- This is used to order names nicely when showing what's in scope cmpNameDisplay :: NameDisp -> Name -> Name -> Ordering cmpNameDisplay disp l r = - case (nameInfo l, nameInfo r) of + case (asOrigName l, asOrigName r) of - (Declared nsl _, Declared nsr _) -> -- XXX: uses system name info? - let pfxl = fmtModName nsl (getNameFormat nsl (nameIdent l) disp) - pfxr = fmtModName nsr (getNameFormat nsr (nameIdent r) disp) - in case cmpText pfxl pfxr of - EQ -> cmpName l r - cmp -> cmp + (Just ogl, Just ogr) -> -- XXX: uses system name info? + case cmpText (fmtPref ogl) (fmtPref ogr) of + EQ -> cmpName l r + cmp -> cmp - (Parameter,Parameter) -> cmpName l r + (Nothing,Nothing) -> cmpName l r - (Declared nsl _,Parameter) -> - let pfxl = fmtModName nsl (getNameFormat nsl (nameIdent l) disp) - in case cmpText pfxl (identText (nameIdent r)) of - EQ -> GT - cmp -> cmp + (Just ogl,Nothing) -> + case cmpText (fmtPref ogl) (identText (nameIdent r)) of + EQ -> GT + cmp -> cmp - (Parameter,Declared nsr _) -> - let pfxr = fmtModName nsr (getNameFormat nsr (nameIdent r) disp) - in case cmpText (identText (nameIdent l)) pfxr of - EQ -> LT - cmp -> cmp + (Nothing,Just ogr) -> + case cmpText (identText (nameIdent l)) (fmtPref ogr) of + EQ -> LT + cmp -> cmp where cmpName xs ys = cmpIdent (nameIdent xs) (nameIdent ys) cmpIdent xs ys = cmpText (identText xs) (identText ys) + --- let pfxl = fmtModName nsl (getNameFormat nsl (nameIdent l) disp) + fmtPref og = case getNameFormat og disp of + UnQualified -> "" + Qualified q -> modNameToText q + NotInScope -> Text.pack $ show $ pp (ogModule og) + -- Note that this assumes that `xs` is `l` and `ys` is `r` cmpText xs ys = case (Text.null xs, Text.null ys) of @@ -169,23 +165,18 @@ | a == '_' = 1 | otherwise = 0 + + -- | Figure out how the name should be displayed, by referencing the display -- function in the environment. NOTE: this function doesn't take into account -- the need for parentheses. ppName :: Name -> Doc -ppName Name { .. } = - case nInfo of +ppName nm = + case asOrigName nm of + Just og -> pp og + Nothing -> pp (nameIdent nm) - Declared m _ -> withNameDisp $ \disp -> - case getNameFormat m nIdent disp of - Qualified m' -> ppQual m' <.> pp nIdent - UnQualified -> pp nIdent - NotInScope -> ppQual m <.> pp nIdent -- XXX: only when not in scope? - where - ppQual mo = if mo == exprModName then empty else pp mo <.> text "::" - Parameter -> pp nIdent - instance PP Name where ppPrec _ = ppPrefixName @@ -199,6 +190,7 @@ ppPrefixName n @ Name { .. } = optParens (isInfixIdent nIdent) (ppName n) + -- | Pretty-print a name with its source location information. ppLocName :: Name -> Doc ppLocName n = pp Located { srcRange = nameLoc n, thing = n } @@ -209,6 +201,9 @@ nameIdent :: Name -> Ident nameIdent = nIdent +nameNamespace :: Name -> Namespace +nameNamespace = nNamespace + nameInfo :: Name -> NameInfo nameInfo = nInfo @@ -218,23 +213,33 @@ nameFixity :: Name -> Maybe Fixity nameFixity = nFixity - +-- | Primtiives must be in a top level module, at least for now. asPrim :: Name -> Maybe PrimIdent asPrim Name { .. } = case nInfo of - Declared p _ -> Just $ PrimIdent p $ identText nIdent - _ -> Nothing + Declared (TopModule m) _ -> Just $ PrimIdent m $ identText nIdent + _ -> Nothing toParamInstName :: Name -> Name toParamInstName n = case nInfo n of - Declared m s -> n { nInfo = Declared (paramInstModName m) s } + Declared m s -> n { nInfo = Declared (apPathRoot paramInstModName m) s } Parameter -> n asParamName :: Name -> Name asParamName n = n { nInfo = Parameter } +asOrigName :: Name -> Maybe OrigName +asOrigName nm = + case nInfo nm of + Declared p _ -> + Just OrigName { ogModule = apPathRoot notParamInstModName p + , ogNamespace = nNamespace nm + , ogName = nIdent nm + } + Parameter -> Nothing + -- Name Supply ----------------------------------------------------------------- class Monad m => FreshM m where @@ -321,15 +326,17 @@ -- Name Construction ----------------------------------------------------------- -- | Make a new name for a declaration. -mkDeclared :: ModName -> NameSource -> Ident -> Maybe Fixity -> Range -> Supply -> (Name,Supply) -mkDeclared m sys nIdent nFixity nLoc s = +mkDeclared :: + Namespace -> ModPath -> NameSource -> Ident -> Maybe Fixity -> Range -> + Supply -> (Name,Supply) +mkDeclared nNamespace m sys nIdent nFixity nLoc s = let (nUnique,s') = nextUnique s nInfo = Declared m sys in (Name { .. }, s') -- | Make a new parameter name. -mkParameter :: Ident -> Range -> Supply -> (Name,Supply) -mkParameter nIdent nLoc s = +mkParameter :: Namespace -> Ident -> Range -> Supply -> (Name,Supply) +mkParameter nNamespace nIdent nLoc s = let (nUnique,s') = nextUnique s nFixity = Nothing in (Name { nInfo = Parameter, .. }, s') @@ -340,6 +347,7 @@ , nIdent = packIdent "$modParams" , nLoc = emptyRange , nUnique = 0x01 + , nNamespace = NSValue } -- Prim Maps ------------------------------------------------------------------- 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 @@ -15,23 +15,18 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE OverloadedStrings #-} module Cryptol.ModuleSystem.NamingEnv where -import Cryptol.ModuleSystem.Interface -import Cryptol.ModuleSystem.Name -import Cryptol.Parser.AST -import Cryptol.Parser.Name(isGeneratedName) -import Cryptol.Parser.Position -import qualified Cryptol.TypeCheck.AST as T -import Cryptol.Utils.PP -import Cryptol.Utils.Panic (panic) - import Data.List (nub) -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe,mapMaybe,maybeToList) +import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map +import Data.Set (Set) import qualified Data.Set as Set import Data.Semigroup -import MonadLib (runId,Id) +import MonadLib (runId,Id,StateT,runStateT,lift,sets_,forM_) import GHC.Generics (Generic) import Control.DeepSeq @@ -39,46 +34,71 @@ import Prelude () import Prelude.Compat +import Cryptol.Utils.PP +import Cryptol.Utils.Panic (panic) +import Cryptol.Parser.AST +import Cryptol.Parser.Name(isGeneratedName) +import Cryptol.Parser.Position +import qualified Cryptol.TypeCheck.AST as T +import Cryptol.ModuleSystem.Interface +import Cryptol.ModuleSystem.Name + -- Naming Environment ---------------------------------------------------------- -- | The 'NamingEnv' is used by the renamer to determine what -- identifiers refer to. -data NamingEnv = NamingEnv { neExprs :: !(Map.Map PName [Name]) - -- ^ Expr renaming environment - , neTypes :: !(Map.Map PName [Name]) - -- ^ Type renaming environment - } deriving (Show, Generic, NFData) +newtype NamingEnv = NamingEnv (Map Namespace (Map PName [Name])) + deriving (Show,Generic,NFData) +-- | All names mentioned in the environment +namingEnvNames :: NamingEnv -> Set Name +namingEnvNames (NamingEnv xs) = + Set.fromList $ concatMap (concat . Map.elems) $ Map.elems xs + + +-- | Get the names in a given namespace +namespaceMap :: Namespace -> NamingEnv -> Map PName [Name] +namespaceMap ns (NamingEnv env) = Map.findWithDefault Map.empty ns env + +-- | Resolve a name in the given namespace. +lookupNS :: Namespace -> PName -> NamingEnv -> [Name] +lookupNS ns x = Map.findWithDefault [] x . namespaceMap ns + -- | Return a list of value-level names to which this parsed name may refer. lookupValNames :: PName -> NamingEnv -> [Name] -lookupValNames qn ro = Map.findWithDefault [] qn (neExprs ro) +lookupValNames = lookupNS NSValue -- | Return a list of type-level names to which this parsed name may refer. lookupTypeNames :: PName -> NamingEnv -> [Name] -lookupTypeNames qn ro = Map.findWithDefault [] qn (neTypes ro) +lookupTypeNames = lookupNS NSType +-- | Singleton renaming environment for the given namespace. +singletonNS :: Namespace -> PName -> Name -> NamingEnv +singletonNS ns pn n = NamingEnv (Map.singleton ns (Map.singleton pn [n])) +-- | Singleton expression renaming environment. +singletonE :: PName -> Name -> NamingEnv +singletonE = singletonNS NSValue -instance Semigroup NamingEnv where - l <> r = - NamingEnv { neExprs = Map.unionWith merge (neExprs l) (neExprs r) - , neTypes = Map.unionWith merge (neTypes l) (neTypes r) } +-- | Singleton type renaming environment. +singletonT :: PName -> Name -> NamingEnv +singletonT = singletonNS NSType -instance Monoid NamingEnv where - mempty = - NamingEnv { neExprs = Map.empty - , neTypes = Map.empty } - mappend l r = l <> r +namingEnvRename :: (Name -> Name) -> NamingEnv -> NamingEnv +namingEnvRename f (NamingEnv mp) = NamingEnv (ren <$> mp) + where + ren nsm = map f <$> nsm - mconcat envs = - NamingEnv { neExprs = Map.unionsWith merge (map neExprs envs) - , neTypes = Map.unionsWith merge (map neTypes envs) } +instance Semigroup NamingEnv where + NamingEnv l <> NamingEnv r = + NamingEnv (Map.unionWith (Map.unionWith merge) l r) + +instance Monoid NamingEnv where + mempty = NamingEnv Map.empty {-# INLINE mempty #-} - {-# INLINE mappend #-} - {-# INLINE mconcat #-} -- | Merge two name maps, collapsing cases where the entries are the same, and @@ -87,62 +107,61 @@ merge xs ys | xs == ys = xs | otherwise = nub (xs ++ ys) +instance PP NamingEnv where + ppPrec _ (NamingEnv mps) = vcat $ map ppNS $ Map.toList mps + where ppNS (ns,xs) = pp ns $$ nest 2 (vcat (map ppNm (Map.toList xs))) + ppNm (x,as) = pp x <+> "->" <+> commaSep (map pp as) + -- | Generate a mapping from 'PrimIdent' to 'Name' for a -- given naming environment. toPrimMap :: NamingEnv -> PrimMap -toPrimMap NamingEnv { .. } = PrimMap { .. } +toPrimMap env = + PrimMap + { primDecls = fromNS NSValue + , primTypes = fromNS NSType + } where + fromNS ns = Map.fromList + [ entry x | xs <- Map.elems (namespaceMap ns env), x <- xs ] + entry n = case asPrim n of Just p -> (p,n) Nothing -> panic "toPrimMap" [ "Not a declared name?" , show n ] - primDecls = Map.fromList [ entry n | ns <- Map.elems neExprs, n <- ns ] - primTypes = Map.fromList [ entry n | ns <- Map.elems neTypes, n <- ns ] -- | Generate a display format based on a naming environment. toNameDisp :: NamingEnv -> NameDisp -toNameDisp NamingEnv { .. } = NameDisp display +toNameDisp env = NameDisp (`Map.lookup` names) where - display mn ident = Map.lookup (mn,ident) names - - -- only format declared names, as parameters don't need any special - -- formatting. names = Map.fromList - $ [ mkEntry (mn, nameIdent n) pn | (pn,ns) <- Map.toList neExprs - , n <- ns - , Declared mn _ <- [nameInfo n] ] - - ++ [ mkEntry (mn, nameIdent n) pn | (pn,ns) <- Map.toList neTypes - , n <- ns - , Declared mn _ <- [nameInfo n] ] - - mkEntry key pn = (key,fmt) - where fmt = case getModName pn of - Just ns -> Qualified ns - Nothing -> UnQualified + [ (og, qn) + | ns <- [ NSValue, NSType, NSModule ] + , (pn,xs) <- Map.toList (namespaceMap ns env) + , x <- xs + , og <- maybeToList (asOrigName x) + , let qn = case getModName pn of + Just q -> Qualified q + Nothing -> UnQualified + ] -- | Produce sets of visible names for types and declarations. -- --- NOTE: if entries in the NamingEnv would have produced a name clash, they will --- be omitted from the resulting sets. -visibleNames :: NamingEnv -> ({- types -} Set.Set Name - ,{- decls -} Set.Set Name) - -visibleNames NamingEnv { .. } = (types,decls) +-- NOTE: if entries in the NamingEnv would have produced a name clash, +-- they will be omitted from the resulting sets. +visibleNames :: NamingEnv -> Map Namespace (Set Name) +visibleNames (NamingEnv env) = Set.fromList . mapMaybe check . Map.elems <$> env where - types = Set.fromList [ n | [n] <- Map.elems neTypes ] - decls = Set.fromList [ n | [n] <- Map.elems neExprs ] + check names = + case names of + [name] -> Just name + _ -> Nothing -- | Qualify all symbols in a 'NamingEnv' with the given prefix. qualify :: ModName -> NamingEnv -> NamingEnv -qualify pfx NamingEnv { .. } = - NamingEnv { neExprs = Map.mapKeys toQual neExprs - , neTypes = Map.mapKeys toQual neTypes - } - +qualify pfx (NamingEnv env) = NamingEnv (Map.mapKeys toQual <$> env) where -- XXX we don't currently qualify fresh names toQual (Qual _ n) = Qual pfx n @@ -150,53 +169,87 @@ toQual n@NewName{} = n filterNames :: (PName -> Bool) -> NamingEnv -> NamingEnv -filterNames p NamingEnv { .. } = - NamingEnv { neExprs = Map.filterWithKey check neExprs - , neTypes = Map.filterWithKey check neTypes - } - where - check :: PName -> a -> Bool - check n _ = p n +filterNames p (NamingEnv env) = NamingEnv (Map.filterWithKey check <$> env) + where check n _ = p n --- | Singleton type renaming environment. -singletonT :: PName -> Name -> NamingEnv -singletonT qn tn = mempty { neTypes = Map.singleton qn [tn] } - --- | Singleton expression renaming environment. -singletonE :: PName -> Name -> NamingEnv -singletonE qn en = mempty { neExprs = Map.singleton qn [en] } - -- | Like mappend, but when merging, prefer values on the lhs. shadowing :: NamingEnv -> NamingEnv -> NamingEnv -shadowing l r = NamingEnv - { neExprs = Map.union (neExprs l) (neExprs r) - , neTypes = Map.union (neTypes l) (neTypes r) } +shadowing (NamingEnv l) (NamingEnv r) = NamingEnv (Map.unionWith Map.union l r) travNamingEnv :: Applicative f => (Name -> f Name) -> NamingEnv -> f NamingEnv -travNamingEnv f ne = NamingEnv <$> neExprs' <*> neTypes' - where - neExprs' = traverse (traverse f) (neExprs ne) - neTypes' = traverse (traverse f) (neTypes ne) +travNamingEnv f (NamingEnv mp) = + NamingEnv <$> traverse (traverse (traverse f)) mp -data InModule a = InModule !ModName a +{- | Do somethign in context. If `Nothing` than we are working with +a local declaration. Otherwise we are at the top-level of the +given module. -} +data InModule a = InModule (Maybe ModPath) a deriving (Functor,Traversable,Foldable,Show) --- | Generate a 'NamingEnv' using an explicit supply. -namingEnv' :: BindsNames a => a -> Supply -> (NamingEnv,Supply) -namingEnv' a supply = runId (runSupplyT supply (runBuild (namingEnv a))) - -newTop :: FreshM m => ModName -> PName -> Maybe Fixity -> Range -> m Name -newTop ns thing fx rng = liftSupply (mkDeclared ns src (getIdent thing) fx rng) +newTop :: + FreshM m => Namespace -> ModPath -> PName -> Maybe Fixity -> Range -> m Name +newTop ns m thing fx rng = + liftSupply (mkDeclared ns m src (getIdent thing) fx rng) where src = if isGeneratedName thing then SystemName else UserName -newLocal :: FreshM m => PName -> Range -> m Name -newLocal thing rng = liftSupply (mkParameter (getIdent thing) rng) +newLocal :: FreshM m => Namespace -> PName -> Range -> m Name +newLocal ns thing rng = liftSupply (mkParameter ns (getIdent thing) rng) newtype BuildNamingEnv = BuildNamingEnv { runBuild :: SupplyT Id NamingEnv } + +buildNamingEnv :: BuildNamingEnv -> Supply -> (NamingEnv,Supply) +buildNamingEnv b supply = runId $ runSupplyT supply $ runBuild b + +-- | Generate a 'NamingEnv' using an explicit supply. +defsOf :: BindsNames a => a -> Supply -> (NamingEnv,Supply) +defsOf = buildNamingEnv . namingEnv + + +-------------------------------------------------------------------------------- +-- Collect definitions of nested modules + +type NestedMods = Map Name NamingEnv +type CollectM = StateT NestedMods (SupplyT Id) + +collectNestedModules :: + NamingEnv -> Module PName -> Supply -> (NestedMods, Supply) +collectNestedModules env m = + collectNestedModulesDecls env (thing (mName m)) (mDecls m) + +collectNestedModulesDecls :: + NamingEnv -> ModName -> [TopDecl PName] -> Supply -> (NestedMods, Supply) +collectNestedModulesDecls env m ds sup = (mp,newS) + where + s0 = Map.empty + mpath = TopModule m + ((_,mp),newS) = runId $ runSupplyT sup $ runStateT s0 $ + collectNestedModulesDs mpath env ds + +collectNestedModulesDs :: ModPath -> NamingEnv -> [TopDecl PName] -> CollectM () +collectNestedModulesDs mpath env ds = + forM_ [ tlValue nm | DModule nm <- ds ] \(NestedModule nested) -> + do let pname = thing (mName nested) + name = case lookupNS NSModule pname env of + n : _ -> n -- if a name is ambiguous we may get + -- multiple answers, but we just pick one. + -- This should be OK, as the error should be + -- caught during actual renaming. + _ -> panic "collectedNestedModulesDs" + [ "Missing definition for " ++ show pname ] + newEnv <- lift (runBuild (moduleDefs (Nested mpath (nameIdent name)) nested)) + sets_ (Map.insert name newEnv) + let newMPath = Nested mpath (nameIdent name) + collectNestedModulesDs newMPath newEnv (mDecls nested) + +-------------------------------------------------------------------------------- + + + + instance Semigroup BuildNamingEnv where BuildNamingEnv a <> BuildNamingEnv b = BuildNamingEnv $ do x <- a @@ -212,6 +265,10 @@ do ns <- sequence (map runBuild bs) return (mconcat ns) +-------------------------------------------------------------------------------- + + + -- | Things that define exported names. class BindsNames a where namingEnv :: a -> BuildNamingEnv @@ -235,12 +292,12 @@ {-# INLINE namingEnv #-} --- | Interpret an import in the context of an interface, to produce a name --- environment for the renamer, and a 'NameDisp' for pretty-printing. -interpImport :: Import {- ^ The import declarations -} -> - IfaceDecls {- ^ Declarations of imported module -} -> + +-- | Adapt the things exported by something to the specific import/open. +interpImportEnv :: ImportG name {- ^ The import declarations -} -> + NamingEnv {- ^ All public things coming in -} -> NamingEnv -interpImport imp publicDecls = qualified +interpImportEnv imp public = qualified where -- optionally qualify names based on the import @@ -257,16 +314,21 @@ | otherwise = public - -- generate the initial environment from the public interface, where no names - -- are qualified - public = unqualifiedEnv publicDecls +-- | Interpret an import in the context of an interface, to produce a name +-- environment for the renamer, and a 'NameDisp' for pretty-printing. +interpImportIface :: Import {- ^ The import declarations -} -> + IfaceDecls {- ^ Declarations of imported module -} -> + NamingEnv +interpImportIface imp = interpImportEnv imp . unqualifiedEnv + + -- | Generate a naming environment from a declaration interface, where none of -- the names are qualified. unqualifiedEnv :: IfaceDecls -> NamingEnv unqualifiedEnv IfaceDecls { .. } = - mconcat [ exprs, tySyns, ntTypes, absTys, ntExprs ] + mconcat [ exprs, tySyns, ntTypes, absTys, ntExprs, mods ] where toPName n = mkUnqual (nameIdent n) @@ -275,16 +337,17 @@ ntTypes = mconcat [ singletonT (toPName n) n | n <- Map.keys ifNewtypes ] absTys = mconcat [ singletonT (toPName n) n | n <- Map.keys ifAbstractTypes ] ntExprs = mconcat [ singletonE (toPName n) n | n <- Map.keys ifNewtypes ] - + mods = mconcat [ singletonNS NSModule (toPName n) n + | n <- Map.keys ifModules ] -- | Compute an unqualified naming environment, containing the various module -- parameters. modParamsNamingEnv :: IfaceParams -> NamingEnv modParamsNamingEnv IfaceParams { .. } = - NamingEnv { neExprs = Map.fromList $ map fromFu $ Map.keys ifParamFuns - , neTypes = Map.fromList $ map fromTy $ Map.elems ifParamTypes - } - + NamingEnv $ Map.fromList + [ (NSValue, Map.fromList $ map fromFu $ Map.keys ifParamFuns) + , (NSType, Map.fromList $ map fromTy $ Map.elems ifParamTypes) + ] where toPName n = mkUnqual (nameIdent n) @@ -301,14 +364,16 @@ -- mapping only from unqualified names to qualified ones. instance BindsNames ImportIface where namingEnv (ImportIface imp Iface { .. }) = BuildNamingEnv $ - return (interpImport imp ifPublic) + return (interpImportIface imp ifPublic) {-# INLINE namingEnv #-} -- | Introduce the name instance BindsNames (InModule (Bind PName)) where - namingEnv (InModule ns b) = BuildNamingEnv $ + namingEnv (InModule mb b) = BuildNamingEnv $ do let Located { .. } = bName b - n <- newTop ns thing (bFixity b) srcRange + n <- case mb of + Just m -> newTop NSValue m thing (bFixity b) srcRange + Nothing -> newLocal NSValue thing srcRange -- local fixitiies? return (singletonE thing n) @@ -316,16 +381,19 @@ instance BindsNames (TParam PName) where namingEnv TParam { .. } = BuildNamingEnv $ do let range = fromMaybe emptyRange tpRange - n <- newLocal tpName range + n <- newLocal NSType tpName range return (singletonT tpName n) -- | The naming environment for a single module. This is the mapping from -- unqualified names to fully qualified names with uniques. instance BindsNames (Module PName) where - namingEnv Module { .. } = foldMap (namingEnv . InModule ns) mDecls - where - ns = thing mName + namingEnv m = moduleDefs (TopModule (thing (mName m))) m + +moduleDefs :: ModPath -> ModuleG mname PName -> BuildNamingEnv +moduleDefs m Module { .. } = foldMap (namingEnv . InModule (Just m)) mDecls + + instance BindsNames (InModule (TopDecl PName)) where namingEnv (InModule ns td) = case td of @@ -335,60 +403,70 @@ DParameterType d -> namingEnv (InModule ns d) DParameterConstraint {} -> mempty DParameterFun d -> namingEnv (InModule ns d) - Include _ -> mempty + Include _ -> mempty + DImport {} -> mempty -- see 'openLoop' in the renamer + DModule m -> namingEnv (InModule ns (tlValue m)) + +instance BindsNames (InModule (NestedModule PName)) where + namingEnv (InModule ~(Just m) (NestedModule mdef)) = BuildNamingEnv $ + do let pnmame = mName mdef + nm <- newTop NSModule m (thing pnmame) Nothing (srcRange pnmame) + pure (singletonNS NSModule (thing pnmame) nm) + instance BindsNames (InModule (PrimType PName)) where - namingEnv (InModule ns PrimType { .. }) = + namingEnv (InModule ~(Just m) PrimType { .. }) = BuildNamingEnv $ do let Located { .. } = primTName - nm <- newTop ns thing primTFixity srcRange + nm <- newTop NSType m thing primTFixity srcRange pure (singletonT thing nm) instance BindsNames (InModule (ParameterFun PName)) where - namingEnv (InModule ns ParameterFun { .. }) = BuildNamingEnv $ + namingEnv (InModule ~(Just ns) ParameterFun { .. }) = BuildNamingEnv $ do let Located { .. } = pfName - ntName <- newTop ns thing pfFixity srcRange + ntName <- newTop NSValue ns thing pfFixity srcRange return (singletonE thing ntName) instance BindsNames (InModule (ParameterType PName)) where - namingEnv (InModule ns ParameterType { .. }) = BuildNamingEnv $ + namingEnv (InModule ~(Just ns) ParameterType { .. }) = BuildNamingEnv $ -- XXX: we don't seem to have a fixity environment at the type level do let Located { .. } = ptName - ntName <- newTop ns thing Nothing srcRange + ntName <- newTop NSType ns thing Nothing srcRange return (singletonT thing ntName) -- NOTE: we use the same name at the type and expression level, as there's only -- ever one name introduced in the declaration. The names are only ever used in -- different namespaces, so there's no ambiguity. instance BindsNames (InModule (Newtype PName)) where - namingEnv (InModule ns Newtype { .. }) = BuildNamingEnv $ + namingEnv (InModule ~(Just ns) Newtype { .. }) = BuildNamingEnv $ do let Located { .. } = nName - ntName <- newTop ns thing Nothing srcRange + ntName <- newTop NSType ns thing Nothing srcRange + -- XXX: the name reuse here is sketchy return (singletonT thing ntName `mappend` singletonE thing ntName) -- | The naming environment for a single declaration. instance BindsNames (InModule (Decl PName)) where namingEnv (InModule pfx d) = case d of - DBind b -> BuildNamingEnv $ - do n <- mkName (bName b) (bFixity b) - return (singletonE (thing (bName b)) n) - + DBind b -> namingEnv (InModule pfx b) DSignature ns _sig -> foldMap qualBind ns DPragma ns _p -> foldMap qualBind ns DType syn -> qualType (tsName syn) (tsFixity syn) DProp syn -> qualType (psName syn) (psFixity syn) DLocated d' _ -> namingEnv (InModule pfx d') - DPatBind _pat _e -> panic "ModuleSystem" ["Unexpected pattern binding"] - DFixity{} -> panic "ModuleSystem" ["Unexpected fixity declaration"] + DRec {} -> panic "namingEnv" [ "DRec" ] + DPatBind _pat _e -> panic "namingEnv" ["Unexpected pattern binding"] + DFixity{} -> panic "namingEnv" ["Unexpected fixity declaration"] where - mkName ln fx = newTop pfx (thing ln) fx (srcRange ln) + mkName ns ln fx = case pfx of + Just m -> newTop ns m (thing ln) fx (srcRange ln) + Nothing -> newLocal ns (thing ln) (srcRange ln) qualBind ln = BuildNamingEnv $ - do n <- mkName ln Nothing + do n <- mkName NSValue ln Nothing return (singletonE (thing ln) n) qualType ln f = BuildNamingEnv $ - do n <- mkName ln f + do n <- mkName NSType ln f return (singletonT (thing ln) n) 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 @@ -6,19 +6,13 @@ -- Stability : provisional -- Portability : portable -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE OverloadedStrings #-} +{-# Language RecordWildCards #-} +{-# Language FlexibleInstances #-} +{-# Language FlexibleContexts #-} +{-# Language BlockArguments #-} module Cryptol.ModuleSystem.Renamer ( NamingEnv(), shadowing - , BindsNames(..), InModule(..), namingEnv' - , checkNamingEnv + , BindsNames(..), InModule(..) , shadowNames , Rename(..), runRenamer, RenameM() , RenamerError(..) @@ -26,429 +20,449 @@ , renameVar , renameType , renameModule + , renameTopDecls + , RenamerInfo(..) + , NameType(..) + , RenamedModule(..) ) where +import Prelude () +import Prelude.Compat + +import Data.Either(partitionEithers) +import Data.Maybe(fromJust) +import Data.List(find,foldl') +import Data.Foldable(toList) +import Data.Map.Strict(Map) +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import Data.Graph(SCC(..)) +import Data.Graph.SCC(stronglyConnComp) +import MonadLib hiding (mapM, mapM_) + + import Cryptol.ModuleSystem.Name import Cryptol.ModuleSystem.NamingEnv import Cryptol.ModuleSystem.Exports +import Cryptol.Parser.Position(getLoc) import Cryptol.Parser.AST -import Cryptol.Parser.Position -import Cryptol.Parser.Selector(ppNestedSels,selName) +import Cryptol.Parser.Selector(selName) import Cryptol.Utils.Panic (panic) -import Cryptol.Utils.PP import Cryptol.Utils.RecordMap +import Cryptol.Utils.Ident(allNamespaces,packModName) -import Data.List(find) -import qualified Data.Foldable as F -import Data.Map.Strict ( Map ) -import qualified Data.Map.Strict as Map -import qualified Data.Sequence as Seq -import qualified Data.Semigroup as S -import Data.Set (Set) -import qualified Data.Set as Set -import MonadLib hiding (mapM, mapM_) +import Cryptol.ModuleSystem.Interface +import Cryptol.ModuleSystem.Renamer.Error +import Cryptol.ModuleSystem.Renamer.Monad -import GHC.Generics (Generic) -import Control.DeepSeq -import Prelude () -import Prelude.Compat +data RenamedModule = RenamedModule + { rmModule :: Module Name -- ^ The renamed module + , rmDefines :: NamingEnv -- ^ What this module defines + , rmInScope :: NamingEnv -- ^ What's in scope in this module + , rmImported :: IfaceDecls -- ^ Imported declarations + } --- Errors ---------------------------------------------------------------------- +renameModule :: Module PName -> RenameM RenamedModule +renameModule m0 = + do let m = m0 { mDecls = snd (addImplicitNestedImports (mDecls m0)) } + env <- liftSupply (defsOf m) + nested <- liftSupply (collectNestedModules env m) + setNestedModule (nestedModuleNames nested) + do (ifs,(inScope,m1)) <- collectIfaceDeps + $ renameModule' nested env (TopModule (thing (mName m))) m + pure RenamedModule + { rmModule = m1 + , rmDefines = env + , rmInScope = inScope + , rmImported = ifs + -- XXX: maybe we should keep the nested defines too? + } -data RenamerError - = MultipleSyms (Located PName) [Name] NameDisp - -- ^ Multiple imported symbols contain this name +renameTopDecls :: + ModName -> [TopDecl PName] -> RenameM (NamingEnv,[TopDecl Name]) +renameTopDecls m ds0 = + do let ds = snd (addImplicitNestedImports ds0) + let mpath = TopModule m + env <- liftSupply (defsOf (map (InModule (Just mpath)) ds)) + nested <- liftSupply (collectNestedModulesDecls env m ds) - | UnboundExpr (Located PName) NameDisp - -- ^ Expression name is not bound to any definition + setNestedModule (nestedModuleNames nested) + do ds1 <- shadowNames' CheckOverlap env + (renameTopDecls' (nested,mpath) ds) + -- record a use of top-level names to avoid + -- unused name warnings + let exports = concatMap exportedNames ds1 + mapM_ recordUse (foldMap (exported NSType) exports) - | UnboundType (Located PName) NameDisp - -- ^ Type name is not bound to any definition + pure (env,ds1) - | OverlappingSyms [Name] NameDisp - -- ^ An environment has produced multiple overlapping symbols +-- | Returns declarations with additional imports and the public module names +-- of this module and its children +addImplicitNestedImports :: + [TopDecl PName] -> ([[Ident]], [TopDecl PName]) +addImplicitNestedImports decls = (concat exportedMods, concat newDecls ++ other) + where + (mods,other) = foldr classify ([], []) decls + (newDecls,exportedMods) = unzip (map processModule mods) + processModule m = + let NestedModule m1 = tlValue m + (childExs, ds1) = addImplicitNestedImports (mDecls m1) + mname = getIdent (thing (mName m1)) + imps = map (mname :) ([] : childExs) + isToName is = case is of + [i] -> mkUnqual i + _ -> mkQual (isToQual (init is)) (last is) + isToQual is = packModName (map identText is) + mkImp xs = DImport + Located + { srcRange = srcRange (mName m1) + , thing = Import + { iModule = ImpNested (isToName xs) + , iAs = Just (isToQual xs) + , iSpec = Nothing + } + } + in ( DModule m { tlValue = NestedModule m1 { mDecls = ds1 } } + : map mkImp imps + , case tlExport m of + Public -> imps + Private -> [] + ) - | ExpectedValue (Located PName) NameDisp - -- ^ When a value is expected from the naming environment, but one or more - -- types exist instead. - | ExpectedType (Located PName) NameDisp - -- ^ When a type is missing from the naming environment, but one or more - -- values exist with the same name. + classify d (ms,ds) = + case d of + DModule tl -> (tl : ms, ds) + _ -> (ms, d : ds) - | FixityError (Located Name) Fixity (Located Name) Fixity NameDisp - -- ^ When the fixity of two operators conflict - | InvalidConstraint (Type PName) NameDisp - -- ^ When it's not possible to produce a Prop from a Type. +nestedModuleNames :: NestedMods -> Map ModPath Name +nestedModuleNames mp = Map.fromList (map entry (Map.keys mp)) + where + entry n = case nameInfo n of + Declared p _ -> (Nested p (nameIdent n),n) + _ -> panic "nestedModuleName" [ "Not a top-level name" ] - | MalformedBuiltin (Type PName) PName NameDisp - -- ^ When a builtin type/type-function is used incorrectly. - | BoundReservedType PName (Maybe Range) Doc NameDisp - -- ^ When a builtin type is named in a binder. +class Rename f where + rename :: f PName -> RenameM (f Name) - | OverlappingRecordUpdate (Located [Selector]) (Located [Selector]) NameDisp - -- ^ When record updates overlap (e.g., @{ r | x = e1, x.y = e2 }@) - deriving (Show, Generic, NFData) -instance PP RenamerError where - ppPrec _ e = case e of +-- | Returns: +-- +-- * Interfaces for imported things, +-- * Things defines in the module +-- * Renamed module +renameModule' :: + NestedMods -> NamingEnv -> ModPath -> ModuleG mname PName -> + RenameM (NamingEnv, ModuleG mname Name) +renameModule' thisNested env mpath m = + setCurMod mpath + do (moreNested,imps) <- mconcat <$> mapM doImport (mImports m) + let allNested = Map.union moreNested thisNested + openDs = map thing (mSubmoduleImports m) + allImps = openLoop allNested env openDs imps - MultipleSyms lqn qns disp -> fixNameDisp disp $ - hang (text "[error] at" <+> pp (srcRange lqn)) - 4 $ (text "Multiple definitions for symbol:" <+> pp (thing lqn)) - $$ vcat (map ppLocName qns) + (inScope,decls') <- + shadowNames' CheckNone allImps $ + shadowNames' CheckOverlap env $ + -- maybe we should allow for a warning + -- if a local name shadows an imported one? + do inScope <- getNamingEnv + ds <- renameTopDecls' (allNested,mpath) (mDecls m) + pure (inScope, ds) + let m1 = m { mDecls = decls' } + exports = modExports m1 + mapM_ recordUse (exported NSType exports) + return (inScope, m1) - UnboundExpr lqn disp -> fixNameDisp disp $ - hang (text "[error] at" <+> pp (srcRange lqn)) - 4 (text "Value not in scope:" <+> pp (thing lqn)) - UnboundType lqn disp -> fixNameDisp disp $ - hang (text "[error] at" <+> pp (srcRange lqn)) - 4 (text "Type not in scope:" <+> pp (thing lqn)) +renameDecls :: [Decl PName] -> RenameM [Decl Name] +renameDecls ds = + do (ds1,deps) <- depGroup (traverse rename ds) + let toNode d = let x = NamedThing (declName d) + in ((d,x), x, map NamedThing + $ Set.toList + $ Map.findWithDefault Set.empty x deps) + ordered = toList (stronglyConnComp (map toNode ds1)) + fromSCC x = + case x of + AcyclicSCC (d,_) -> pure [d] + CyclicSCC ds_xs -> + let (rds,xs) = unzip ds_xs + in case mapM validRecursiveD rds of + Nothing -> do record (InvalidDependency xs) + pure rds + Just bs -> + do checkSameModule xs + pure [DRec bs] + concat <$> mapM fromSCC ordered - OverlappingSyms qns disp -> fixNameDisp disp $ - hang (text "[error]") - 4 $ text "Overlapping symbols defined:" - $$ vcat (map ppLocName qns) - ExpectedValue lqn disp -> fixNameDisp disp $ - hang (text "[error] at" <+> pp (srcRange lqn)) - 4 (fsep [ text "Expected a value named", quotes (pp (thing lqn)) - , text "but found a type instead" - , text "Did you mean `(" <.> pp (thing lqn) <.> text")?" ]) +validRecursiveD :: Decl name -> Maybe (Bind name) +validRecursiveD d = + case d of + DBind b -> Just b + DLocated d' _ -> validRecursiveD d' + _ -> Nothing - ExpectedType lqn disp -> fixNameDisp disp $ - hang (text "[error] at" <+> pp (srcRange lqn)) - 4 (fsep [ text "Expected a type named", quotes (pp (thing lqn)) - , text "but found a value instead" ]) +checkSameModule :: [DepName] -> RenameM () +checkSameModule xs = + case ms of + a : as | let bad = [ fst b | b <- as, snd a /= snd b ] + , not (null bad) -> + record $ InvalidDependency $ map NamedThing $ fst a : bad + _ -> pure () + where + ms = [ (x,p) | NamedThing x <- xs, Declared p _ <- [ nameInfo x ] ] - FixityError o1 f1 o2 f2 disp -> fixNameDisp disp $ - hang (text "[error] at" <+> pp (srcRange o1) <+> text "and" <+> pp (srcRange o2)) - 4 (fsep [ text "The fixities of" - , nest 2 $ vcat - [ "•" <+> pp (thing o1) <+> parens (pp f1) - , "•" <+> pp (thing o2) <+> parens (pp f2) ] - , text "are not compatible." - , text "You may use explicit parentheses to disambiguate." ]) - InvalidConstraint ty disp -> fixNameDisp disp $ - hang (text "[error]" <+> maybe empty (\r -> text "at" <+> pp r) (getLoc ty)) - 4 (fsep [ pp ty, text "is not a valid constraint" ]) - - MalformedBuiltin ty pn disp -> fixNameDisp disp $ - hang (text "[error]" <+> maybe empty (\r -> text "at" <+> pp r) (getLoc ty)) - 4 (fsep [ text "invalid use of built-in type", pp pn - , text "in type", pp ty ]) - - BoundReservedType n loc src disp -> fixNameDisp disp $ - hang (text "[error]" <+> maybe empty (\r -> text "at" <+> pp r) loc) - 4 (fsep [ text "built-in type", quotes (pp n), text "shadowed in", src ]) - - OverlappingRecordUpdate xs ys disp -> fixNameDisp disp $ - hang "[error] Overlapping record updates:" - 4 (vcat [ ppLab xs, ppLab ys ]) - where - ppLab as = ppNestedSels (thing as) <+> "at" <+> pp (srcRange as) - --- Warnings -------------------------------------------------------------------- - -data RenamerWarning - = SymbolShadowed Name [Name] NameDisp - - | UnusedName Name NameDisp - deriving (Show, Generic, NFData) - -instance PP RenamerWarning where - ppPrec _ (SymbolShadowed new originals disp) = fixNameDisp disp $ - hang (text "[warning] at" <+> loc) - 4 $ fsep [ text "This binding for" <+> backticks sym - , text "shadows the existing binding" <.> plural <+> - text "at" ] - $$ vcat (map (pp . nameLoc) originals) - - where - plural | length originals > 1 = char 's' - | otherwise = empty - - loc = pp (nameLoc new) - sym = pp new - - ppPrec _ (UnusedName x disp) = fixNameDisp disp $ - hang (text "[warning] at" <+> pp (nameLoc x)) - 4 (text "Unused name:" <+> pp x) +renameTopDecls' :: + (NestedMods,ModPath) -> [TopDecl PName] -> RenameM [TopDecl Name] +renameTopDecls' info ds = + do (ds1,deps) <- depGroup (traverse (renameWithMods info) ds) -data RenamerWarnings = RenamerWarnings - { renWarnNameDisp :: !NameDisp - , renWarnShadow :: Map Name (Set Name) - , renWarnUnused :: Set Name - } - -noRenamerWarnings :: RenamerWarnings -noRenamerWarnings = RenamerWarnings - { renWarnNameDisp = mempty - , renWarnShadow = Map.empty - , renWarnUnused = Set.empty - } - -addRenamerWarning :: RenamerWarning -> RenamerWarnings -> RenamerWarnings -addRenamerWarning w ws = - case w of - SymbolShadowed x xs d -> - ws { renWarnNameDisp = renWarnNameDisp ws <> d - , renWarnShadow = Map.insertWith Set.union x (Set.fromList xs) - (renWarnShadow ws) - } - UnusedName x d -> - ws { renWarnNameDisp = renWarnNameDisp ws <> d - , renWarnUnused = Set.insert x (renWarnUnused ws) - } - -listRenamerWarnings :: RenamerWarnings -> [RenamerWarning] -listRenamerWarnings ws = - [ mk (UnusedName x) | x <- Set.toList (renWarnUnused ws) ] ++ - [ mk (SymbolShadowed x (Set.toList xs)) - | (x,xs) <- Map.toList (renWarnShadow ws) ] + let (noNameDs,nameDs) = partitionEithers (map topDeclName ds1) + ctrs = [ nm | (_,nm@(ConstratintAt {})) <- nameDs ] + toNode (d,x) = ((d,x),x, (if usesCtrs d then ctrs else []) ++ + map NamedThing + ( Set.toList + ( Map.findWithDefault Set.empty x deps) )) + ordered = stronglyConnComp (map toNode nameDs) + fromSCC x = + case x of + AcyclicSCC (d,_) -> pure [d] + CyclicSCC ds_xs -> + let (rds,xs) = unzip ds_xs + in case mapM valid rds of + Nothing -> do record (InvalidDependency xs) + pure rds + Just bs -> + do checkSameModule xs + pure [Decl TopLevel + { tlDoc = Nothing + , tlExport = Public + , tlValue = DRec bs + }] + where + valid d = case d of + Decl tl -> validRecursiveD (tlValue tl) + _ -> Nothing + rds <- mapM fromSCC ordered + pure (concat (noNameDs:rds)) where - mk f = f (renWarnNameDisp ws) + usesCtrs td = + case td of + Decl tl -> isValDecl (tlValue tl) + DPrimType {} -> False + TDNewtype {} -> False + DParameterType {} -> False + DParameterConstraint {} -> False + DParameterFun {} -> True + -- Here we may need the constraints to validate the type + -- (e.g., if the parameter is of type `Z a`) --- Renaming Monad -------------------------------------------------------------- -data RO = RO - { roLoc :: Range - , roMod :: !ModName - , roNames :: NamingEnv - , roDisp :: !NameDisp - } + DModule tl -> any usesCtrs (mDecls m) + where NestedModule m = tlValue tl + DImport {} -> False + Include {} -> bad "Include" -data RW = RW - { rwWarnings :: !RenamerWarnings - , rwErrors :: !(Seq.Seq RenamerError) - , rwSupply :: !Supply - , rwNameUseCount :: !(Map Name Int) - -- ^ How many times did we refer to each name. - -- Used to generate warnings for unused definitions. - } + isValDecl d = + case d of + DLocated d' _ -> isValDecl d' + DBind {} -> True + DType {} -> False + DProp {} -> False + DRec {} -> True + DSignature {} -> bad "DSignature" + DFixity {} -> bad "DFixity" + DPragma {} -> bad "DPragma" + DPatBind {} -> bad "DPatBind" + bad msg = panic "renameTopDecls'" [msg] -newtype RenameM a = RenameM - { unRenameM :: ReaderT RO (StateT RW Lift) a } - -instance S.Semigroup a => S.Semigroup (RenameM a) where - {-# INLINE (<>) #-} - a <> b = - do x <- a - y <- b - return (x S.<> y) - -instance (S.Semigroup a, Monoid a) => Monoid (RenameM a) where - {-# INLINE mempty #-} - mempty = return mempty - - {-# INLINE mappend #-} - mappend = (S.<>) - -instance Functor RenameM where - {-# INLINE fmap #-} - fmap f m = RenameM (fmap f (unRenameM m)) - -instance Applicative RenameM where - {-# INLINE pure #-} - pure x = RenameM (pure x) - - {-# INLINE (<*>) #-} - l <*> r = RenameM (unRenameM l <*> unRenameM r) +declName :: Decl Name -> Name +declName decl = + case decl of + DLocated d _ -> declName d + DBind b -> thing (bName b) + DType (TySyn x _ _ _) -> thing x + DProp (PropSyn x _ _ _) -> thing x -instance Monad RenameM where - {-# INLINE return #-} - return x = RenameM (return x) + DSignature {} -> bad "DSignature" + DFixity {} -> bad "DFixity" + DPragma {} -> bad "DPragma" + DPatBind {} -> bad "DPatBind" + DRec {} -> bad "DRec" + where + bad x = panic "declName" [x] - {-# INLINE (>>=) #-} - m >>= k = RenameM (unRenameM m >>= unRenameM . k) +topDeclName :: TopDecl Name -> Either (TopDecl Name) (TopDecl Name, DepName) +topDeclName topDecl = + case topDecl of + Decl d -> hasName (declName (tlValue d)) + DPrimType d -> hasName (thing (primTName (tlValue d))) + TDNewtype d -> hasName (thing (nName (tlValue d))) + DParameterType d -> hasName (thing (ptName d)) + DParameterFun d -> hasName (thing (pfName d)) + DModule d -> hasName (thing (mName m)) + where NestedModule m = tlValue d -instance FreshM RenameM where - liftSupply f = RenameM $ sets $ \ RW { .. } -> - let (a,s') = f rwSupply - rw' = RW { rwSupply = s', .. } - in a `seq` rw' `seq` (a, rw') + DParameterConstraint ds -> + case ds of + [] -> noName + _ -> Right (topDecl, ConstratintAt (fromJust (getLoc ds))) + DImport {} -> noName -runRenamer :: Supply -> ModName -> NamingEnv -> RenameM a - -> (Either [RenamerError] (a,Supply),[RenamerWarning]) -runRenamer s ns env m = (res, listRenamerWarnings warns) + Include {} -> bad "Include" where - warns = foldr addRenamerWarning (rwWarnings rw) - (warnUnused ns env ro rw) + noName = Left topDecl + hasName n = Right (topDecl, NamedThing n) + bad x = panic "topDeclName" [x] - (a,rw) = runM (unRenameM m) ro - RW { rwErrors = Seq.empty - , rwWarnings = noRenamerWarnings - , rwSupply = s - , rwNameUseCount = Map.empty - } - ro = RO { roLoc = emptyRange - , roNames = env - , roMod = ns - , roDisp = neverQualifyMod ns `mappend` toNameDisp env - } +-- | Returns: +-- * The public interface of the imported module +-- * Infromation about nested modules in this module +-- * New names introduced through this import +doImport :: Located Import -> RenameM (NestedMods, NamingEnv) +doImport li = + do let i = thing li + decls <- lookupImport i + let declsOf = unqualifiedEnv . ifPublic + nested = declsOf <$> ifModules decls + pure (nested, interpImportIface i decls) - res | Seq.null (rwErrors rw) = Right (a,rwSupply rw) - | otherwise = Left (F.toList (rwErrors rw)) --- | Record an error. XXX: use a better name -record :: (NameDisp -> RenamerError) -> RenameM () -record f = RenameM $ - do RO { .. } <- ask - RW { .. } <- get - set RW { rwErrors = rwErrors Seq.|> f roDisp, .. } --- | Get the source range for wahtever we are currently renaming. -curLoc :: RenameM Range -curLoc = RenameM (roLoc `fmap` ask) - --- | Annotate something with the current range. -located :: a -> RenameM (Located a) -located thing = - do srcRange <- curLoc - return Located { .. } - --- | Do the given computation using the source code range from `loc` if any. -withLoc :: HasLoc loc => loc -> RenameM a -> RenameM a -withLoc loc m = RenameM $ case getLoc loc of - - Just range -> do - ro <- ask - local ro { roLoc = range } (unRenameM m) - - Nothing -> unRenameM m - --- | Retrieve the name of the current module. -getNS :: RenameM ModName -getNS = RenameM (roMod `fmap` ask) - --- | Shadow the current naming environment with some more names. -shadowNames :: BindsNames env => env -> RenameM a -> RenameM a -shadowNames = shadowNames' CheckAll - -data EnvCheck = CheckAll -- ^ Check for overlap and shadowing - | CheckOverlap -- ^ Only check for overlap - | CheckNone -- ^ Don't check the environment - deriving (Eq,Show) - --- | Shadow the current naming environment with some more names. -shadowNames' :: BindsNames env => EnvCheck -> env -> RenameM a -> RenameM a -shadowNames' check names m = do - do env <- liftSupply (namingEnv' names) - RenameM $ - do ro <- ask - env' <- sets (checkEnv (roDisp ro) check env (roNames ro)) - let ro' = ro { roNames = env' `shadowing` roNames ro } - local ro' (unRenameM m) - -shadowNamesNS :: BindsNames (InModule env) => env -> RenameM a -> RenameM a -shadowNamesNS names m = - do ns <- getNS - shadowNames (InModule ns names) m +-------------------------------------------------------------------------------- +-- Compute names coming through `open` statements. +data OpenLoopState = OpenLoopState + { unresolvedOpen :: [ImportG PName] + , scopeImports :: NamingEnv -- names from open/impot + , scopeDefs :: NamingEnv -- names defined in this module + , scopingRel :: NamingEnv -- defs + imports with shadowing + -- (just a cache) + , openLoopChange :: Bool + } --- | Generate warnings when the left environment shadows things defined in --- the right. Additionally, generate errors when two names overlap in the --- left environment. -checkEnv :: NameDisp -> EnvCheck -> NamingEnv -> NamingEnv -> RW -> (NamingEnv,RW) -checkEnv disp check l r rw - | check == CheckNone = (l',rw) - | otherwise = (l',rw'') +-- | Processing of a single @open@ declaration +processOpen :: NestedMods -> OpenLoopState -> ImportG PName -> OpenLoopState +processOpen modEnvs s o = + case lookupNS NSModule (iModule o) (scopingRel s) of + [] -> s { unresolvedOpen = o : unresolvedOpen s } + [n] -> + case Map.lookup n modEnvs of + Nothing -> panic "openLoop" [ "Missing defintion for module", show n ] + Just def -> + let new = interpImportEnv o def + newImps = new <> scopeImports s + in s { scopeImports = newImps + , scopingRel = scopeDefs s `shadowing` newImps + , openLoopChange = True + } + _ -> s + {- Notes: + * ambiguity will be reported later when we do the renaming + * assumes scoping only grows, which should be true + * we are not adding the names from *either* of the imports + so this may give rise to undefined names, so we may want to + suppress reporing undefined names if there ambiguities for + module names. Alternatively we could add the defitions from + *all* options, but that might lead to spurious ambiguity errors. + -} +{- | Complete the set of import using @open@ declarations. +This should terminate because on each iteration either @unresolvedOpen@ +decreases or @openLoopChange@ remians @False@. We don't report errors +here, as they will be reported during renaming anyway. -} +openLoop :: + NestedMods {- ^ Definitions of all known nested modules -} -> + NamingEnv {- ^ Definitions of the module (these shadow) -} -> + [ImportG PName] {- ^ Open declarations -} -> + NamingEnv {- ^ Imported declarations -} -> + NamingEnv {- ^ Completed imports -} +openLoop modEnvs defs os imps = + scopingRel $ loop OpenLoopState + { unresolvedOpen = os + , scopeImports = imps + , scopeDefs = defs + , scopingRel = defs `shadowing` imps + , openLoopChange = True + } where + loop s + | openLoopChange s = + loop $ foldl' (processOpen modEnvs) + s { unresolvedOpen = [], openLoopChange = False } + (unresolvedOpen s) + | otherwise = s - l' = l { neExprs = es, neTypes = ts } - (rw',es) = Map.mapAccumWithKey (step neExprs) rw (neExprs l) - (rw'',ts) = Map.mapAccumWithKey (step neTypes) rw' (neTypes l) +-------------------------------------------------------------------------------- - step prj acc k ns = (acc', [head ns]) - where - acc' = acc - { rwWarnings = - if check == CheckAll - then case Map.lookup k (prj r) of - Nothing -> rwWarnings acc - Just os -> addRenamerWarning - (SymbolShadowed (head ns) os disp) - (rwWarnings acc) - else rwWarnings acc - , rwErrors = rwErrors acc Seq.>< containsOverlap disp ns - } +data WithMods f n = WithMods (NestedMods,ModPath) (f n) --- | Check the RHS of a single name rewrite for conflicting sources. -containsOverlap :: NameDisp -> [Name] -> Seq.Seq RenamerError -containsOverlap _ [_] = Seq.empty -containsOverlap _ [] = panic "Renamer" ["Invalid naming environment"] -containsOverlap disp ns = Seq.singleton (OverlappingSyms ns disp) +forgetMods :: WithMods f n -> f n +forgetMods (WithMods _ td) = td --- | Throw errors for any names that overlap in a rewrite environment. -checkNamingEnv :: NamingEnv -> ([RenamerError],[RenamerWarning]) -checkNamingEnv env = (F.toList out, []) - where - out = Map.foldr check outTys (neExprs env) - outTys = Map.foldr check mempty (neTypes env) +renameWithMods :: + Rename (WithMods f) => (NestedMods,ModPath) -> f PName -> RenameM (f Name) +renameWithMods info m = forgetMods <$> rename (WithMods info m) - disp = toNameDisp env - check ns acc = containsOverlap disp ns Seq.>< acc +instance Rename (WithMods TopDecl) where + rename (WithMods info td) = WithMods info <$> + case td of + Decl d -> Decl <$> traverse rename d + DPrimType d -> DPrimType <$> traverse rename d + TDNewtype n -> TDNewtype <$> traverse rename n + Include n -> return (Include n) + DParameterFun f -> DParameterFun <$> rename f + DParameterType f -> DParameterType <$> rename f -recordUse :: Name -> RenameM () -recordUse x = RenameM $ sets_ $ \rw -> - rw { rwNameUseCount = Map.insertWith (+) x 1 (rwNameUseCount rw) } + DParameterConstraint ds -> + case ds of + [] -> pure (DParameterConstraint []) + _ -> depsOf (ConstratintAt (fromJust (getLoc ds))) + $ DParameterConstraint <$> mapM renameLocated ds + DModule m -> DModule <$> traverse (renameWithMods info) m + DImport li -> DImport <$> traverse renI li + where + renI i = do m <- rename (iModule i) + pure i { iModule = m } +instance Rename ImpName where + rename i = + case i of + ImpTop m -> pure (ImpTop m) + ImpNested m -> ImpNested <$> resolveName NameUse NSModule m -warnUnused :: ModName -> NamingEnv -> RO -> RW -> [RenamerWarning] -warnUnused m0 env ro rw = - map warn - $ Map.keys - $ Map.filterWithKey keep - $ rwNameUseCount rw - where - warn x = UnusedName x (roDisp ro) - keep k n = n == 1 && isLocal k - oldNames = fst (visibleNames env) - isLocal nm = case nameInfo nm of - Declared m sys -> sys == UserName && - m == m0 && nm `Set.notMember` oldNames - Parameter -> True +instance Rename (WithMods NestedModule) where + rename (WithMods info (NestedModule m)) = WithMods info <$> + do let (nested,mpath) = info + lnm = mName m + nm = thing lnm + newMPath = Nested mpath (getIdent nm) + n <- resolveName NameBind NSModule nm + depsOf (NamedThing n) + do let env = case Map.lookup n (fst info) of + Just defs -> defs + Nothing -> panic "rename" + [ "Missing environment for nested module", show n ] + -- XXX: we should store in scope somehwere if we want to browse + -- nested modules properly + (_inScope,m1) <- renameModule' nested env newMPath m + pure (NestedModule m1 { mName = lnm { thing = n } }) --- Renaming -------------------------------------------------------------------- -class Rename f where - rename :: f PName -> RenameM (f Name) - -renameModule :: Module PName -> RenameM (NamingEnv,Module Name) -renameModule m = - do env <- liftSupply (namingEnv' m) - -- NOTE: we explicitly hide shadowing errors here, by using shadowNames' - decls' <- shadowNames' CheckOverlap env (traverse rename (mDecls m)) - let m1 = m { mDecls = decls' } - exports = modExports m1 - mapM_ recordUse (eTypes exports) - return (env,m1) - -instance Rename TopDecl where - rename td = case td of - Decl d -> Decl <$> traverse rename d - DPrimType d -> DPrimType <$> traverse rename d - TDNewtype n -> TDNewtype <$> traverse rename n - Include n -> return (Include n) - DParameterFun f -> DParameterFun <$> rename f - DParameterType f -> DParameterType <$> rename f - - DParameterConstraint d -> DParameterConstraint <$> mapM renameLocated d - renameLocated :: Rename f => Located (f PName) -> RenameM (Located (f Name)) renameLocated x = do y <- rename (thing x) @@ -456,21 +470,30 @@ instance Rename PrimType where rename pt = - do x <- rnLocated renameType (primTName pt) - let (as,ps) = primTCts pt - (_,cts) <- renameQual as ps $ \as' ps' -> pure (as',ps') - pure pt { primTCts = cts, primTName = x } + do x <- rnLocated (renameType NameBind) (primTName pt) + depsOf (NamedThing (thing x)) + do let (as,ps) = primTCts pt + (_,cts) <- renameQual as ps $ \as' ps' -> pure (as',ps') + -- Record an additional use for each parameter since we checked + -- earlier that all the parameters are used exactly once in the + -- body of the signature. This prevents incorret warnings + -- about unused names. + mapM_ (recordUse . tpName) (fst cts) + + pure pt { primTCts = cts, primTName = x } + instance Rename ParameterType where rename a = - do n' <- rnLocated renameType (ptName a) + do n' <- rnLocated (renameType NameBind) (ptName a) return a { ptName = n' } instance Rename ParameterFun where rename a = - do n' <- rnLocated renameVar (pfName a) - sig' <- renameSchema (pfSchema a) - return a { pfName = n', pfSchema = snd sig' } + do n' <- rnLocated (renameVar NameBind) (pfName a) + depsOf (NamedThing (thing n')) + do sig' <- renameSchema (pfSchema a) + return a { pfName = n', pfSchema = snd sig' } rnLocated :: (a -> RenameM b) -> Located a -> RenameM (Located b) rnLocated f loc = withLoc loc $ @@ -479,101 +502,95 @@ instance Rename Decl where rename d = case d of - DSignature ns sig -> DSignature <$> traverse (rnLocated renameVar) ns - <*> rename sig - DPragma ns p -> DPragma <$> traverse (rnLocated renameVar) ns - <*> pure p - DBind b -> DBind <$> rename b - - -- XXX we probably shouldn't see these at this point... - DPatBind pat e -> do (pe,pat') <- renamePat pat - shadowNames pe (DPatBind pat' <$> rename e) + DBind b -> DBind <$> rename b DType syn -> DType <$> rename syn DProp syn -> DProp <$> rename syn DLocated d' r -> withLoc r $ DLocated <$> rename d' <*> pure r - DFixity{} -> panic "Renamer" ["Unexpected fixity declaration" - , show d] -instance Rename Newtype where - rename n = do - name' <- rnLocated renameType (nName n) - shadowNames (nParams n) $ - do ps' <- traverse rename (nParams n) - body' <- traverse (traverse rename) (nBody n) - return Newtype { nName = name' - , nParams = ps' - , nBody = body' } + DFixity{} -> panic "renaem" [ "DFixity" ] + DSignature {} -> panic "rename" [ "DSignature" ] + DPragma {} -> panic "rename" [ "DPragma" ] + DPatBind {} -> panic "rename" [ "DPatBind " ] + DRec {} -> panic "rename" [ "DRec" ] -renameVar :: PName -> RenameM Name -renameVar qn = do - ro <- RenameM ask - case Map.lookup qn (neExprs (roNames ro)) of - Just [n] -> return n - Just [] -> panic "Renamer" ["Invalid expression renaming environment"] - Just syms -> - do n <- located qn - record (MultipleSyms n syms) - return (head syms) - -- This is an unbound value. Record an error and invent a bogus real name - -- for it. - Nothing -> - do n <- located qn - case Map.lookup qn (neTypes (roNames ro)) of - -- types existed with the name of the value expected - Just _ -> record (ExpectedValue n) +instance Rename Newtype where + rename n = + shadowNames (nParams n) $ + do name' <- rnLocated (renameType NameBind) (nName n) + depsOf (NamedThing (thing name')) $ + do ps' <- traverse rename (nParams n) + body' <- traverse (traverse rename) (nBody n) + return Newtype { nName = name' + , nParams = ps' + , nBody = body' } - -- the value is just missing - Nothing -> record (UnboundExpr n) - mkFakeName qn --- | Produce a name if one exists. Note that this includes situations where --- overlap exists, as it's just a query about anything being in scope. In the --- event that overlap does exist, an error will be recorded. -typeExists :: PName -> RenameM (Maybe Name) -typeExists pn = +-- | Try to resolve a name +resolveNameMaybe :: NameType -> Namespace -> PName -> RenameM (Maybe Name) +resolveNameMaybe nt expected qn = do ro <- RenameM ask - case Map.lookup pn (neTypes (roNames ro)) of - Just [n] -> recordUse n >> return (Just n) - Just [] -> panic "Renamer" ["Invalid type renaming environment"] - Just syms -> do n <- located pn - mapM_ recordUse syms - record (MultipleSyms n syms) - return (Just (head syms)) - Nothing -> return Nothing + let lkpIn here = Map.lookup qn (namespaceMap here (roNames ro)) + use = case expected of + NSType -> recordUse + _ -> const (pure ()) + case lkpIn expected of + Just [n] -> + do case nt of + NameBind -> pure () + NameUse -> addDep n + use n -- for warning + return (Just n) + Just [] -> panic "Renamer" ["Invalid expression renaming environment"] + Just syms -> + do mapM_ use syms -- mark as used to avoid unused warnings + n <- located qn + record (MultipleSyms n syms) + return (Just (head syms)) -renameType :: PName -> RenameM Name -renameType pn = - do mb <- typeExists pn - case mb of - Just n -> return n + Nothing -> pure Nothing - -- This is an unbound value. Record an error and invent a bogus real name - -- for it. +-- | Resolve a name, and report error on failure +resolveName :: NameType -> Namespace -> PName -> RenameM Name +resolveName nt expected qn = + do mb <- resolveNameMaybe nt expected qn + case mb of + Just n -> pure n Nothing -> do ro <- RenameM ask - let n = Located { srcRange = roLoc ro, thing = pn } + let lkpIn here = Map.lookup qn (namespaceMap here (roNames ro)) + others = [ ns | ns <- allNamespaces + , ns /= expected + , Just _ <- [lkpIn ns] ] + nm <- located qn + case others of + -- name exists in a different namespace + actual : _ -> record (WrongNamespace expected actual nm) - case Map.lookup pn (neExprs (roNames ro)) of + -- the value is just missing + [] -> record (UnboundName expected nm) - -- values exist with the same name, so throw a different error - Just _ -> record (ExpectedType n) + mkFakeName expected qn - -- no terms with the same name, so the type is just unbound - Nothing -> record (UnboundType n) - mkFakeName pn +renameVar :: NameType -> PName -> RenameM Name +renameVar nt = resolveName nt NSValue +renameType :: NameType -> PName -> RenameM Name +renameType nt = resolveName nt NSType + + + -- | Assuming an error has been recorded already, construct a fake name that's -- not expected to make it out of the renamer. -mkFakeName :: PName -> RenameM Name -mkFakeName pn = +mkFakeName :: Namespace -> PName -> RenameM Name +mkFakeName ns pn = do ro <- RenameM ask - liftSupply (mkParameter (getIdent pn) (roLoc ro)) + liftSupply (mkParameter ns (getIdent pn) (roLoc ro)) -- | Rename a schema, assuming that none of its type variables are already in -- scope. @@ -593,7 +610,7 @@ ([TParam Name] -> [Prop Name] -> RenameM a) -> RenameM (NamingEnv, a) renameQual as ps k = - do env <- liftSupply (namingEnv' as) + do env <- liftSupply (defsOf as) res <- shadowNames env $ do as' <- traverse rename as ps' <- traverse rename ps k as' ps' @@ -601,7 +618,7 @@ instance Rename TParam where rename TParam { .. } = - do n <- renameType tpName + do n <- renameType NameBind tpName return TParam { tpName = n, .. } instance Rename Prop where @@ -616,7 +633,7 @@ TBit -> return TBit TNum c -> return (TNum c) TChar c -> return (TChar c) - TUser qn ps -> TUser <$> renameType qn <*> traverse rename ps + TUser qn ps -> TUser <$> 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 @@ -628,7 +645,8 @@ b' <- rename b mkTInfix a' o' b' -mkTInfix :: Type Name -> (Located Name, Fixity) -> Type Name -> RenameM (Type Name) +mkTInfix :: + Type Name -> (Located Name, Fixity) -> Type Name -> RenameM (Type Name) mkTInfix t@(TInfix x o1 f1 y) op@(o2,f2) z = case compareFixity f1 f2 of @@ -647,20 +665,21 @@ -- | Rename a binding. instance Rename Bind where - rename b = do - n' <- rnLocated renameVar (bName b) - mbSig <- traverse renameSchema (bSignature b) - shadowNames (fst `fmap` mbSig) $ - do (patEnv,pats') <- renamePats (bParams b) - -- NOTE: renamePats will generate warnings, so we don't need to trigger - -- them again here. - e' <- shadowNames' CheckNone patEnv (rnLocated rename (bDef b)) - return b { bName = n' - , bParams = pats' - , bDef = e' - , bSignature = snd `fmap` mbSig - , bPragmas = bPragmas b - } + rename b = + do n' <- rnLocated (renameVar NameBind) (bName b) + depsOf (NamedThing (thing n')) + do mbSig <- traverse renameSchema (bSignature b) + shadowNames (fst `fmap` mbSig) $ + do (patEnv,pats') <- renamePats (bParams b) + -- NOTE: renamePats will generate warnings, + -- so we don't need to trigger them again here. + e' <- shadowNames' CheckNone patEnv (rnLocated rename (bDef b)) + return b { bName = n' + , bParams = pats' + , bDef = e' + , bSignature = snd `fmap` mbSig + , bPragmas = bPragmas b + } instance Rename BindDef where rename DPrim = return DPrim @@ -669,7 +688,7 @@ -- NOTE: this only renames types within the pattern. instance Rename Pattern where rename p = case p of - PVar lv -> PVar <$> rnLocated renameVar lv + PVar lv -> PVar <$> rnLocated (renameVar NameBind) lv PWild -> pure PWild PTuple ps -> PTuple <$> traverse rename ps PRecord nps -> PRecord <$> traverse (traverse rename) nps @@ -702,12 +721,12 @@ instance Rename FunDesc where rename (FunDesc nm offset) = - do nm' <- traverse renameVar nm + do nm' <- traverse (renameVar NameBind) nm pure (FunDesc nm' offset) instance Rename Expr where rename expr = case expr of - EVar n -> EVar <$> renameVar n + EVar n -> EVar <$> renameVar NameUse n ELit l -> return (ELit l) ENeg e -> ENeg <$> rename e EComplement e -> EComplement @@ -724,6 +743,18 @@ <*> traverse rename n <*> rename e <*> traverse rename t + EFromToBy isStrict s e b t -> + EFromToBy isStrict + <$> rename s + <*> rename e + <*> rename b + <*> traverse rename t + EFromToDownBy isStrict s e b t -> + EFromToDownBy isStrict + <$> rename s + <*> rename e + <*> rename b + <*> traverse rename t EFromToLessThan s e t -> EFromToLessThan <$> rename s <*> rename e @@ -737,9 +768,8 @@ EApp f x -> EApp <$> rename f <*> rename x EAppT f ti -> EAppT <$> rename f <*> traverse rename ti EIf b t f -> EIf <$> rename b <*> rename t <*> rename f - EWhere e' ds -> do ns <- getNS - shadowNames (map (InModule ns) ds) $ - EWhere <$> rename e' <*> traverse rename ds + EWhere e' ds -> shadowNames (map (InModule Nothing) ds) $ + EWhere <$> rename e' <*> renameDecls ds ETyped e' ty -> ETyped <$> rename e' <*> rename ty ETypeVal ty -> ETypeVal<$> rename ty EFun desc ps e' -> do desc' <- rename desc @@ -810,14 +840,14 @@ renameOp :: Located PName -> RenameM (Located Name, Fixity) renameOp ln = withLoc ln $ - do n <- renameVar (thing ln) + do n <- renameVar NameUse (thing ln) fixity <- lookupFixity n return (ln { thing = n }, fixity) renameTypeOp :: Located PName -> RenameM (Located Name, Fixity) renameTypeOp ln = withLoc ln $ - do n <- renameType (thing ln) + do n <- renameType NameUse (thing ln) fixity <- lookupFixity n return (ln { thing = n }, fixity) @@ -859,8 +889,7 @@ return (pe,Match p' e') renameMatch (MatchLet b) = - do ns <- getNS - be <- liftSupply (namingEnv' (InModule ns b)) + do be <- liftSupply (defsOf (InModule Nothing b)) b' <- shadowNames be (rename b) return (be,MatchLet b') @@ -892,7 +921,8 @@ patternEnv = go where go (PVar Located { .. }) = - do n <- liftSupply (mkParameter (getIdent thing) srcRange) + do n <- liftSupply (mkParameter NSValue (getIdent thing) srcRange) + -- XXX: for deps, we should record a use return (singletonE thing n) go PWild = return mempty @@ -919,7 +949,7 @@ typeEnv TChar{} = return mempty typeEnv (TUser pn ps) = - do mb <- typeExists pn + do mb <- resolveNameMaybe NameUse NSType pn case mb of -- The type is already bound, don't introduce anything. @@ -931,15 +961,15 @@ -- of the type of the pattern. | null ps -> do loc <- curLoc - n <- liftSupply (mkParameter (getIdent pn) loc) + n <- liftSupply (mkParameter NSType (getIdent pn) loc) return (singletonT pn n) -- This references a type synonym that's not in scope. Record an -- error and continue with a made up name. | otherwise -> do loc <- curLoc - record (UnboundType (Located loc pn)) - n <- liftSupply (mkParameter (getIdent pn) loc) + record (UnboundName NSType (Located loc pn)) + n <- liftSupply (mkParameter NSType (getIdent pn) loc) return (singletonT pn n) typeEnv (TRecord fs) = bindTypes (map snd (recordElements fs)) @@ -961,18 +991,17 @@ instance Rename Match where rename m = case m of Match p e -> Match <$> rename p <*> rename e - MatchLet b -> shadowNamesNS b (MatchLet <$> rename b) + MatchLet b -> shadowNames (InModule Nothing b) (MatchLet <$> rename b) instance Rename TySyn where rename (TySyn n f ps ty) = - shadowNames ps $ TySyn <$> rnLocated renameType n - <*> pure f - <*> traverse rename ps - <*> rename ty + shadowNames ps + do n' <- rnLocated (renameType NameBind) n + depsOf (NamedThing (thing n')) $ + TySyn n' <$> pure f <*> traverse rename ps <*> rename ty instance Rename PropSyn where rename (PropSyn n f ps cs) = - shadowNames ps $ PropSyn <$> rnLocated renameType n - <*> pure f - <*> traverse rename ps - <*> traverse rename cs + shadowNames ps + do n' <- rnLocated (renameType NameBind) n + PropSyn n' <$> pure f <*> traverse rename ps <*> traverse rename cs diff --git a/src/Cryptol/ModuleSystem/Renamer/Error.hs b/src/Cryptol/ModuleSystem/Renamer/Error.hs new file mode 100644 --- /dev/null +++ b/src/Cryptol/ModuleSystem/Renamer/Error.hs @@ -0,0 +1,205 @@ +-- | +-- Module : Cryptol.ModuleSystem.Renamer +-- Copyright : (c) 2013-2016 Galois, Inc. +-- License : BSD3 +-- Maintainer : cryptol@galois.com +-- Stability : provisional +-- Portability : portable + +{-# Language DeriveGeneric, DeriveAnyClass #-} +{-# Language OverloadedStrings #-} +module Cryptol.ModuleSystem.Renamer.Error where + +import Cryptol.ModuleSystem.Name +import Cryptol.Parser.AST +import Cryptol.Parser.Position +import Cryptol.Parser.Selector(ppNestedSels) +import Cryptol.Utils.PP + +import GHC.Generics (Generic) +import Control.DeepSeq + +import Prelude () +import Prelude.Compat + +-- Errors ---------------------------------------------------------------------- + +data RenamerError + = MultipleSyms (Located PName) [Name] + -- ^ Multiple imported symbols contain this name + + | UnboundName Namespace (Located PName) + -- ^ Some name not bound to any definition + + | OverlappingSyms [Name] + -- ^ An environment has produced multiple overlapping symbols + + | WrongNamespace Namespace Namespace (Located PName) + -- ^ expected, actual. + -- When a name is missing from the expected namespace, but exists in another + + | FixityError (Located Name) Fixity (Located Name) Fixity + -- ^ When the fixity of two operators conflict + + | InvalidConstraint (Type PName) + -- ^ When it's not possible to produce a Prop from a Type. + + | MalformedBuiltin (Type PName) PName + -- ^ When a builtin type/type-function is used incorrectly. + + | BoundReservedType PName (Maybe Range) Doc + -- ^ When a builtin type is named in a binder. + + | OverlappingRecordUpdate (Located [Selector]) (Located [Selector]) + -- ^ When record updates overlap (e.g., @{ r | x = e1, x.y = e2 }@) + + | InvalidDependency [DepName] + deriving (Show, Generic, NFData) + + +-- We use this because parameter constrstaints have no names +data DepName = NamedThing Name + | ConstratintAt Range -- ^ identifed by location in source + deriving (Eq,Ord,Show,Generic,NFData) + +depNameLoc :: DepName -> Range +depNameLoc x = + case x of + NamedThing n -> nameLoc n + ConstratintAt r -> r + + + +instance PP RenamerError where + ppPrec _ e = case e of + + MultipleSyms lqn qns -> + hang (text "[error] at" <+> pp (srcRange lqn)) + 4 $ (text "Multiple definitions for symbol:" <+> pp (thing lqn)) + $$ vcat (map ppLocName qns) + + UnboundName ns lqn -> + hang (text "[error] at" <+> pp (srcRange lqn)) + 4 (something <+> "not in scope:" <+> pp (thing lqn)) + where + something = case ns of + NSValue -> "Value" + NSType -> "Type" + NSModule -> "Module" + + OverlappingSyms qns -> + hang (text "[error]") + 4 $ text "Overlapping symbols defined:" + $$ vcat (map ppLocName qns) + + WrongNamespace expected actual lqn -> + hang ("[error] at" <+> pp (srcRange lqn )) + 4 (fsep $ + [ "Expected a", sayNS expected, "named", quotes (pp (thing lqn)) + , "but found a", sayNS actual, "instead" + ] ++ suggestion) + where + sayNS ns = case ns of + NSValue -> "value" + NSType -> "type" + NSModule -> "module" + suggestion = + case (expected,actual) of + + (NSValue,NSType) -> + ["Did you mean `(" <.> pp (thing lqn) <.> text")?"] + _ -> [] + + FixityError o1 f1 o2 f2 -> + hang (text "[error] at" <+> pp (srcRange o1) <+> text "and" <+> pp (srcRange o2)) + 4 (vsep [ text "The fixities of" + , indent 2 $ vcat + [ "•" <+> pp (thing o1) <+> parens (pp f1) + , "•" <+> pp (thing o2) <+> parens (pp f2) ] + , text "are not compatible." + , text "You may use explicit parentheses to disambiguate." ]) + + InvalidConstraint ty -> + hang (hsep $ [text "[error]"] ++ maybe [] (\r -> [text "at" <+> pp r]) (getLoc ty)) + 4 (fsep [ pp ty, text "is not a valid constraint" ]) + + MalformedBuiltin ty pn -> + hang (hsep $ [text "[error]"] ++ maybe [] (\r -> [text "at" <+> pp r]) (getLoc ty)) + 4 (fsep [ text "invalid use of built-in type", pp pn + , text "in type", pp ty ]) + + BoundReservedType n loc src -> + hang (hsep $ [text "[error]"] ++ maybe [] (\r -> [text "at" <+> pp r]) loc) + 4 (fsep [ text "built-in type", quotes (pp n), text "shadowed in", src ]) + + OverlappingRecordUpdate xs ys -> + hang "[error] Overlapping record updates:" + 4 (vcat [ ppLab xs, ppLab ys ]) + where + ppLab as = ppNestedSels (thing as) <+> "at" <+> pp (srcRange as) + + InvalidDependency ds -> + hang "[error] Invalid recursive dependency:" + 4 (vcat [ "•" <+> pp x <.> ", defined at" <+> ppR (depNameLoc x) + | x <- ds ]) + where ppR r = pp (from r) <.> "--" <.> pp (to r) + +instance PP DepName where + ppPrec _ d = + case d of + ConstratintAt r -> "constraint at" <+> pp r + NamedThing n -> + case nameNamespace n of + NSModule -> "submodule" <+> pp n + NSType -> "type" <+> pp n + NSValue -> pp n + + + +-- Warnings -------------------------------------------------------------------- + +data RenamerWarning + = SymbolShadowed PName Name [Name] + | UnusedName Name + deriving (Show, Generic, NFData) + +instance Eq RenamerWarning where + x == y = compare x y == EQ + +-- used to determine in what order ot show things +instance Ord RenamerWarning where + compare w1 w2 = + case w1 of + SymbolShadowed x y _ -> + case w2 of + SymbolShadowed x' y' _ -> compare (byStart y,x) (byStart y',x') + _ -> LT + UnusedName x -> + case w2 of + UnusedName y -> compare (byStart x) (byStart y) + _ -> GT + + where + byStart = from . nameLoc + + +instance PP RenamerWarning where + ppPrec _ (SymbolShadowed k x os) = + hang (text "[warning] at" <+> loc) + 4 $ fsep [ "This binding for" <+> backticks (pp k) + , "shadows the existing binding" <.> plural + , text "at" ] + $$ vcat (map (pp . nameLoc) os) + + where + plural | length os > 1 = char 's' + | otherwise = mempty + + loc = pp (nameLoc x) + + ppPrec _ (UnusedName x) = + hang (text "[warning] at" <+> pp (nameLoc x)) + 4 (text "Unused name:" <+> pp x) + + + diff --git a/src/Cryptol/ModuleSystem/Renamer/Monad.hs b/src/Cryptol/ModuleSystem/Renamer/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Cryptol/ModuleSystem/Renamer/Monad.hs @@ -0,0 +1,342 @@ +-- | +-- Module : Cryptol.ModuleSystem.Renamer +-- Copyright : (c) 2013-2016 Galois, Inc. +-- License : BSD3 +-- Maintainer : cryptol@galois.com +-- Stability : provisional +-- Portability : portable + +{-# Language RecordWildCards #-} +{-# Language FlexibleContexts #-} +{-# Language BlockArguments #-} +module Cryptol.ModuleSystem.Renamer.Monad where + +import Data.List(sort) +import Data.Set(Set) +import qualified Data.Set as Set +import qualified Data.Foldable as F +import Data.Map.Strict ( Map ) +import qualified Data.Map.Strict as Map +import qualified Data.Sequence as Seq +import qualified Data.Semigroup as S +import MonadLib hiding (mapM, mapM_) + +import Prelude () +import Prelude.Compat + +import Cryptol.ModuleSystem.Name +import Cryptol.ModuleSystem.NamingEnv +import Cryptol.ModuleSystem.Interface +import Cryptol.Parser.AST +import Cryptol.Parser.Position +import Cryptol.Utils.Panic (panic) +import Cryptol.Utils.Ident(modPathCommon) + +import Cryptol.ModuleSystem.Renamer.Error + +-- | Indicates if a name is in a binding poisition or a use site +data NameType = NameBind | NameUse + +-- | Information needed to do some renaming. +data RenamerInfo = RenamerInfo + { renSupply :: Supply -- ^ Use to make new names + , renContext :: ModPath -- ^ We are renaming things in here + , renEnv :: NamingEnv -- ^ This is what's in scope + , renIfaces :: ModName -> Iface + } + +newtype RenameM a = RenameM { unRenameM :: ReaderT RO (StateT RW Lift) a } + +data RO = RO + { roLoc :: Range + , roNames :: NamingEnv + , roIfaces :: ModName -> Iface + , roCurMod :: ModPath -- ^ Current module we are working on + , roNestedMods :: Map ModPath Name + } + +data RW = RW + { rwWarnings :: ![RenamerWarning] + , rwErrors :: !(Seq.Seq RenamerError) + , rwSupply :: !Supply + , rwNameUseCount :: !(Map Name Int) + -- ^ How many times did we refer to each name. + -- Used to generate warnings for unused definitions. + + , rwCurrentDeps :: Set Name + -- ^ keeps track of names *used* by something. + -- see 'depsOf' + + , rwDepGraph :: Map DepName (Set Name) + -- ^ keeps track of the dependencies for things. + -- see 'depsOf' + + , rwExternalDeps :: !IfaceDecls + -- ^ Info about imported things + } + + + +instance S.Semigroup a => S.Semigroup (RenameM a) where + {-# INLINE (<>) #-} + a <> b = + do x <- a + y <- b + return (x S.<> y) + +instance (S.Semigroup a, Monoid a) => Monoid (RenameM a) where + {-# INLINE mempty #-} + mempty = return mempty + + {-# INLINE mappend #-} + mappend = (S.<>) + +instance Functor RenameM where + {-# INLINE fmap #-} + fmap f m = RenameM (fmap f (unRenameM m)) + +instance Applicative RenameM where + {-# INLINE pure #-} + pure x = RenameM (pure x) + + {-# INLINE (<*>) #-} + l <*> r = RenameM (unRenameM l <*> unRenameM r) + +instance Monad RenameM where + {-# INLINE return #-} + return x = RenameM (return x) + + {-# INLINE (>>=) #-} + m >>= k = RenameM (unRenameM m >>= unRenameM . k) + +instance FreshM RenameM where + liftSupply f = RenameM $ sets $ \ RW { .. } -> + let (a,s') = f rwSupply + rw' = RW { rwSupply = s', .. } + in a `seq` rw' `seq` (a, rw') + + +runRenamer :: RenamerInfo -> RenameM a + -> ( Either [RenamerError] (a,Supply) + , [RenamerWarning] + ) +runRenamer info m = (res, warns) + where + warns = sort (rwWarnings rw ++ warnUnused (renContext info) (renEnv info) rw) + + (a,rw) = runM (unRenameM m) ro + RW { rwErrors = Seq.empty + , rwWarnings = [] + , rwSupply = renSupply info + , rwNameUseCount = Map.empty + , rwExternalDeps = mempty + , rwCurrentDeps = Set.empty + , rwDepGraph = Map.empty + } + + ro = RO { roLoc = emptyRange + , roNames = renEnv info + , roIfaces = renIfaces info + , roCurMod = renContext info + , roNestedMods = Map.empty + } + + res | Seq.null (rwErrors rw) = Right (a,rwSupply rw) + | otherwise = Left (F.toList (rwErrors rw)) + + +setCurMod :: ModPath -> RenameM a -> RenameM a +setCurMod mpath (RenameM m) = + RenameM $ mapReader (\ro -> ro { roCurMod = mpath }) m + +getCurMod :: RenameM ModPath +getCurMod = RenameM $ asks roCurMod + +getNamingEnv :: RenameM NamingEnv +getNamingEnv = RenameM (asks roNames) + + +setNestedModule :: Map ModPath Name -> RenameM a -> RenameM a +setNestedModule mp (RenameM m) = + RenameM $ mapReader (\ro -> ro { roNestedMods = mp }) m + +nestedModuleOrig :: ModPath -> RenameM (Maybe Name) +nestedModuleOrig x = RenameM (asks (Map.lookup x . roNestedMods)) + + +-- | Record an error. XXX: use a better name +record :: RenamerError -> RenameM () +record f = RenameM $ + do RW { .. } <- get + set RW { rwErrors = rwErrors Seq.|> f, .. } + +collectIfaceDeps :: RenameM a -> RenameM (IfaceDecls,a) +collectIfaceDeps (RenameM m) = + RenameM + do ds <- sets \s -> (rwExternalDeps s, s { rwExternalDeps = mempty }) + a <- m + ds' <- sets \s -> (rwExternalDeps s, s { rwExternalDeps = ds }) + pure (ds',a) + +-- | Rename something. All name uses in the sub-computation are assumed +-- to be dependenices of the thing. +depsOf :: DepName -> RenameM a -> RenameM a +depsOf x (RenameM m) = RenameM + do ds <- sets \rw -> (rwCurrentDeps rw, rw { rwCurrentDeps = Set.empty }) + a <- m + sets_ \rw -> + rw { rwCurrentDeps = Set.union (rwCurrentDeps rw) ds + , rwDepGraph = Map.insert x (rwCurrentDeps rw) (rwDepGraph rw) + } + pure a + +-- | This is used when renaming a group of things. The result contains +-- dependencies between names defines and the group, and is intended to +-- be used to order the group members in dependency order. +depGroup :: RenameM a -> RenameM (a, Map DepName (Set Name)) +depGroup (RenameM m) = RenameM + do ds <- sets \rw -> (rwDepGraph rw, rw { rwDepGraph = Map.empty }) + a <- m + ds1 <- sets \rw -> (rwDepGraph rw, rw { rwDepGraph = ds }) + pure (a,ds1) + +-- | Get the source range for wahtever we are currently renaming. +curLoc :: RenameM Range +curLoc = RenameM (roLoc `fmap` ask) + +-- | Annotate something with the current range. +located :: a -> RenameM (Located a) +located thing = + do srcRange <- curLoc + return Located { .. } + +-- | Do the given computation using the source code range from `loc` if any. +withLoc :: HasLoc loc => loc -> RenameM a -> RenameM a +withLoc loc m = RenameM $ case getLoc loc of + + Just range -> do + ro <- ask + local ro { roLoc = range } (unRenameM m) + + Nothing -> unRenameM m + + +-- | Shadow the current naming environment with some more names. +shadowNames :: BindsNames env => env -> RenameM a -> RenameM a +shadowNames = shadowNames' CheckAll + +data EnvCheck = CheckAll -- ^ Check for overlap and shadowing + | CheckOverlap -- ^ Only check for overlap + | CheckNone -- ^ Don't check the environment + deriving (Eq,Show) + +-- | Shadow the current naming environment with some more names. +shadowNames' :: BindsNames env => EnvCheck -> env -> RenameM a -> RenameM a +shadowNames' check names m = do + do env <- liftSupply (defsOf names) + RenameM $ + do ro <- ask + env' <- sets (checkEnv check env (roNames ro)) + let ro' = ro { roNames = env' `shadowing` roNames ro } + local ro' (unRenameM m) + +-- | Generate warnings when the left environment shadows things defined in +-- the right. Additionally, generate errors when two names overlap in the +-- left environment. +checkEnv :: EnvCheck -> NamingEnv -> NamingEnv -> RW -> (NamingEnv,RW) +checkEnv check (NamingEnv lenv) r rw0 + | check == CheckNone = (newEnv,rw0) + | otherwise = (newEnv,rwFin) + + where + newEnv = NamingEnv newMap + (rwFin,newMap) = Map.mapAccumWithKey doNS rw0 lenv -- lenv 1 ns at a time + doNS rw ns = Map.mapAccumWithKey (step ns) rw + + -- namespace, current state, k : parse name, xs : possible entities for k + step ns acc k xs = (acc', case check of + CheckNone -> xs + _ -> [head xs] + -- we've already reported an overlap error, + -- so resolve arbitrarily to the first entry + ) + where + acc' = acc + { rwWarnings = + if check == CheckAll + then case Map.lookup k (namespaceMap ns r) of + Just os | [x] <- xs + , let os' = filter (/=x) os + , not (null os') -> + SymbolShadowed k x os' : rwWarnings acc + _ -> rwWarnings acc + + else rwWarnings acc + , rwErrors = rwErrors acc Seq.>< containsOverlap xs + } + +-- | Check the RHS of a single name rewrite for conflicting sources. +containsOverlap :: [Name] -> Seq.Seq RenamerError +containsOverlap [_] = Seq.empty +containsOverlap [] = panic "Renamer" ["Invalid naming environment"] +containsOverlap ns = Seq.singleton (OverlappingSyms ns) + + +recordUse :: Name -> RenameM () +recordUse x = RenameM $ sets_ $ \rw -> + rw { rwNameUseCount = Map.insertWith (+) x 1 (rwNameUseCount rw) } + {- NOTE: we don't distinguish between bindings and uses here, because + the situation is complicated by the pattern signatures where the first + "use" site is actually the binding site. Instead we just count them all, and + something is considered unused if it is used only once (i.e, just the + binding site) -} + +-- | Mark something as a dependency. This is similar but different from +-- `recordUse`, in particular: +-- * We only record use sites, not bindings +-- * We record all namespaces, not just types +-- * We only keep track of actual uses mentioned in the code. +-- Otoh, `recordUse` also considers exported entities to be used. +-- * If we depend on a name from a sibling submodule we add a dependency on +-- the module in our common ancestor. Examples: +-- - @A::B::x@ depends on @A::B::C::D::y@, @x@ depends on @A::B::C@ +-- - @A::B::x@ depends on @A::P::Q::y@@, @x@ depends on @A::P@ + +addDep :: Name -> RenameM () +addDep x = + do cur <- getCurMod + deps <- case nameInfo x of + Declared m _ | Just (c,_,i:_) <- modPathCommon cur m -> + do mb <- nestedModuleOrig (Nested c i) + pure case mb of + Just y -> Set.fromList [x,y] + Nothing -> Set.singleton x + _ -> pure (Set.singleton x) + RenameM $ + sets_ \rw -> rw { rwCurrentDeps = Set.union deps (rwCurrentDeps rw) } + + +warnUnused :: ModPath -> NamingEnv -> RW -> [RenamerWarning] +warnUnused m0 env rw = + map warn + $ Map.keys + $ Map.filterWithKey keep + $ rwNameUseCount rw + where + warn x = UnusedName x + keep nm count = count == 1 && isLocal nm + oldNames = Map.findWithDefault Set.empty NSType (visibleNames env) + isLocal nm = case nameInfo nm of + Declared m sys -> sys == UserName && + m == m0 && nm `Set.notMember` oldNames + Parameter -> True + +-- | Get the exported declarations in a module +lookupImport :: Import -> RenameM IfaceDecls +lookupImport imp = RenameM $ + do getIf <- roIfaces <$> ask + let ifs = ifPublic (getIf (iModule imp)) + sets_ \s -> s { rwExternalDeps = ifs <> rwExternalDeps s } + pure ifs + + diff --git a/src/Cryptol/Parser.y b/src/Cryptol/Parser.y --- a/src/Cryptol/Parser.y +++ b/src/Cryptol/Parser.y @@ -35,6 +35,7 @@ import Cryptol.Parser.AST import Cryptol.Parser.Position import Cryptol.Parser.LexerUtils hiding (mkIdent) +import Cryptol.Parser.Token import Cryptol.Parser.ParserUtils import Cryptol.Parser.Unlit(PreProc(..), guessPreProc) import Cryptol.Utils.Ident(paramInstModName) @@ -43,7 +44,7 @@ import Paths_cryptol } -{- state 196 contains 1 shift/reduce conflicts. +{- 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 .. _ ]`. @@ -77,12 +78,15 @@ 'type' { Located $$ (Token (KW KW_type ) _)} 'newtype' { Located $$ (Token (KW KW_newtype) _)} 'module' { Located $$ (Token (KW KW_module ) _)} + 'submodule' { Located $$ (Token (KW KW_submodule ) _)} 'where' { Located $$ (Token (KW KW_where ) _)} 'let' { Located $$ (Token (KW KW_let ) _)} 'if' { Located $$ (Token (KW KW_if ) _)} 'then' { Located $$ (Token (KW KW_then ) _)} 'else' { Located $$ (Token (KW KW_else ) _)} 'x' { Located $$ (Token (KW KW_x) _)} + 'down' { Located $$ (Token (KW KW_down) _)} + 'by' { Located $$ (Token (KW KW_by) _)} 'primitive' { Located $$ (Token (KW KW_primitive) _)} 'constraint'{ Located $$ (Token (KW KW_constraint) _)} @@ -94,8 +98,10 @@ '..' { Located $$ (Token (Sym DotDot ) _)} '...' { Located $$ (Token (Sym DotDotDot) _)} '..<' { Located $$ (Token (Sym DotDotLt) _)} + '..>' { Located $$ (Token (Sym DotDotGt) _)} '|' { Located $$ (Token (Sym Bar ) _)} '<' { Located $$ (Token (Sym Lt ) _)} + '>' { Located $$ (Token (Sym Gt ) _)} '(' { Located $$ (Token (Sym ParenL ) _)} ')' { Located $$ (Token (Sym ParenR ) _)} @@ -158,27 +164,27 @@ %% -vmodule :: { Module PName } - : 'module' modName 'where' 'v{' vmod_body 'v}' { mkModule $2 $5 } - | 'module' modName '=' modName 'where' 'v{' vmod_body 'v}' - { mkModuleInstance $2 $4 $7 } - | 'v{' vmod_body 'v}' { mkAnonymousModule $2 } +vmodule :: { Module PName } + : 'module' module_def { $2 } + | 'v{' vmod_body 'v}' { mkAnonymousModule $2 } -vmod_body :: { ([Located Import], [TopDecl PName]) } - : vimports 'v;' vtop_decls { (reverse $1, reverse $3) } - | vimports ';' vtop_decls { (reverse $1, reverse $3) } - | vimports { (reverse $1, []) } - | vtop_decls { ([], reverse $1) } - | {- empty -} { ([], []) } -vimports :: { [Located Import] } - : vimports 'v;' import { $3 : $1 } - | vimports ';' import { $3 : $1 } - | import { [$1] } +module_def :: { Module PName } + : modName 'where' + 'v{' vmod_body 'v}' { mkModule $1 $4 } + + | modName '=' modName 'where' + 'v{' vmod_body 'v}' { mkModuleInstance $1 $3 $6 } + +vmod_body :: { [TopDecl PName] } + : vtop_decls { reverse $1 } + | {- empty -} { [] } + + -- XXX replace rComb with uses of at -import :: { Located Import } - : 'import' modName mbAs mbImportSpec +import :: { Located (ImportG (ImpName PName)) } + : 'import' impName mbAs mbImportSpec { Located { srcRange = rComb $1 $ fromMaybe (srcRange $2) $ msum [ fmap srcRange $4 @@ -191,6 +197,11 @@ } } } +impName :: { Located (ImpName PName) } + : 'submodule' qname { ImpNested `fmap` $2 } + | modName { ImpTop `fmap` $1 } + + mbAs :: { Maybe (Located ModName) } : 'as' modName { Just $2 } | {- empty -} { Nothing } @@ -242,6 +253,9 @@ | prim_bind { $1 } | private_decls { $1 } | parameter_decls { $1 } + | mbDoc 'submodule' + module_def {% ((:[]) . exportModule $1) `fmap` mkNested $3 } + | import { [DImport $1] } top_decl :: { [TopDecl PName] } : decl { [Decl (TopLevel {tlExport = Public, tlValue = $1 })] } @@ -303,6 +317,7 @@ , bInfix = True , bFixity = Nothing , bDoc = Nothing + , bExport = Public } } | 'type' name '=' type {% at ($1,$4) `fmap` mkTySyn $2 [] $4 } @@ -323,10 +338,49 @@ | 'infix' NUM ops {% mkFixity NonAssoc $2 (reverse $3) } | error {% expected "a declaration" } +let_decls :: { [Decl PName] } + : let_decl { [$1] } + | let_decl ';' { [$1] } + | let_decl ';' let_decls { ($1:$3) } + let_decl :: { Decl PName } - : 'let' ipat '=' expr { at ($2,$4) $ DPatBind $2 $4 } - | 'let' name apats_indices '=' expr { at ($2,$5) $ mkIndexedDecl $2 $3 $5 } + : 'let' ipat '=' expr { at ($2,$4) $ DPatBind $2 $4 } + | 'let' var apats_indices '=' expr { at ($2,$5) $ mkIndexedDecl $2 $3 $5 } + | 'let' '(' op ')' '=' expr { at ($2,$6) $ DPatBind (PVar $3) $6 } + | 'let' apat pat_op apat '=' expr + { at ($2,$6) $ + DBind $ Bind { bName = $3 + , bParams = [$2,$4] + , bDef = at $6 (Located emptyRange (DExpr $6)) + , bSignature = Nothing + , bPragmas = [] + , bMono = False + , bInfix = True + , bFixity = Nothing + , bDoc = Nothing + , bExport = Public + } } + | 'let' vars_comma ':' schema { at (head $2,$4) $ DSignature (reverse $2) $4 } + + | 'type' name '=' type {% at ($1,$4) `fmap` mkTySyn $2 [] $4 } + | 'type' name tysyn_params '=' type + {% at ($1,$5) `fmap` mkTySyn $2 (reverse $3) $5 } + | 'type' tysyn_param op tysyn_param '=' type + {% at ($1,$6) `fmap` mkTySyn $3 [$2, $4] $6 } + + | 'type' 'constraint' name '=' type + {% at ($2,$5) `fmap` mkPropSyn $3 [] $5 } + | 'type' 'constraint' name tysyn_params '=' type + {% at ($2,$6) `fmap` mkPropSyn $3 (reverse $4) $6 } + | 'type' 'constraint' tysyn_param op tysyn_param '=' type + {% at ($2,$7) `fmap` mkPropSyn $4 [$3, $5] $7 } + + | 'infixl' NUM ops {% mkFixity LeftAssoc $2 (reverse $3) } + | 'infixr' NUM ops {% mkFixity RightAssoc $2 (reverse $3) } + | 'infix' NUM ops {% mkFixity NonAssoc $2 (reverse $3) } + + newtype :: { Newtype PName } : 'newtype' qname '=' newtype_body { Newtype $2 [] (thing $4) } @@ -380,7 +434,7 @@ repl :: { ReplInput PName } : expr { ExprInput $1 } - | let_decl { LetInput $1 } + | let_decls { LetInput $1 } | {- empty -} { EmptyInput } @@ -407,7 +461,7 @@ | '~' { Located $1 $ mkUnqual $ mkInfix "~" } | '^^' { Located $1 $ mkUnqual $ mkInfix "^^" } | '<' { Located $1 $ mkUnqual $ mkInfix "<" } - + | '>' { Located $1 $ mkUnqual $ mkInfix ">" } other_op :: { LPName } : OP { let Token (Op (Other [] str)) _ = thing $1 @@ -576,6 +630,14 @@ | expr '..' '<' expr {% eFromToLessThan $2 $1 $4 } | expr '..<' expr {% eFromToLessThan $2 $1 $3 } + | expr '..' expr 'by' expr {% eFromToBy $2 $1 $3 $5 False } + | expr '..' '<' expr 'by' expr {% eFromToBy $2 $1 $4 $6 True } + | expr '..<' expr 'by' expr {% eFromToBy $2 $1 $3 $5 True } + + | expr '..' expr 'down' 'by' expr {% eFromToDownBy $2 $1 $3 $6 False } + | expr '..' '>' expr 'down' 'by' expr {% eFromToDownBy $2 $1 $4 $7 True } + | expr '..>' expr 'down' 'by' expr {% eFromToDownBy $2 $1 $3 $6 True } + | expr '...' { EInfFrom $1 Nothing } | expr ',' expr '...' { EInfFrom $1 (Just $3) } @@ -720,7 +782,6 @@ | 'private' { Located { srcRange = $1, thing = mkIdent "private" } } | 'as' { Located { srcRange = $1, thing = mkIdent "as" } } | 'hiding' { Located { srcRange = $1, thing = mkIdent "hiding" } } - name :: { LPName } : ident { fmap mkUnqual $1 } 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 @@ -37,7 +37,10 @@ , psFixity -- * Declarations - , Module(..) + , Module + , ModuleG(..) + , mImports + , mSubmoduleImports , Program(..) , TopDecl(..) , Decl(..) @@ -50,11 +53,12 @@ , Pragma(..) , ExportType(..) , TopLevel(..) - , Import(..), ImportSpec(..) + , Import, ImportG(..), ImportSpec(..), ImpName(..) , Newtype(..) , PrimType(..) , ParameterType(..) , ParameterFun(..) + , NestedModule(..) -- * Interactive , ReplInput(..) @@ -119,15 +123,39 @@ deriving (Show) -- | A parsed module. -data Module name = Module - { mName :: Located ModName -- ^ Name of the module +data ModuleG mname name = Module + { mName :: Located mname -- ^ Name of the module , mInstance :: !(Maybe (Located ModName)) -- ^ Functor to instantiate -- (if this is a functor instnaces) - , mImports :: [Located Import] -- ^ Imports for the module + -- , mImports :: [Located Import] -- ^ Imports for the module , mDecls :: [TopDecl name] -- ^ Declartions for the module } deriving (Show, Generic, NFData) +mImports :: ModuleG mname name -> [ Located Import ] +mImports m = + [ li { thing = i { iModule = n } } + | DImport li <- mDecls m + , let i = thing li + , ImpTop n <- [iModule i] + ] +mSubmoduleImports :: ModuleG mname name -> [ Located (ImportG name) ] +mSubmoduleImports m = + [ li { thing = i { iModule = n } } + | DImport li <- mDecls m + , let i = thing li + , ImpNested n <- [iModule i] + ] + + + +type Module = ModuleG ModName + + +newtype NestedModule name = NestedModule (ModuleG name name) + deriving (Show,Generic,NFData) + + modRange :: Module name -> Range modRange m = rCombs $ catMaybes [ getLoc (mName m) @@ -146,12 +174,21 @@ | DParameterConstraint [Located (Prop name)] -- ^ @parameter type constraint (fin T)@ | DParameterFun (ParameterFun name) -- ^ @parameter someVal : [256]@ + | DModule (TopLevel (NestedModule name)) -- ^ Nested module + | DImport (Located (ImportG (ImpName name))) -- ^ An import declaration deriving (Show, Generic, NFData) +data ImpName name = + ImpTop ModName + | ImpNested name + deriving (Show, Generic, NFData) + data Decl name = DSignature [Located name] (Schema name) | DFixity !Fixity [Located name] | DPragma [Located name] Pragma | DBind (Bind name) + | DRec [Bind name] + -- ^ A group of recursive bindings, introduced by the renamer. | DPatBind (Pattern name) (Expr name) | DType (TySyn name) | DProp (PropSyn name) @@ -178,16 +215,15 @@ -- | An import declaration. -data Import = Import { iModule :: !ModName - , iAs :: Maybe ModName - , iSpec :: Maybe ImportSpec - } deriving (Eq, Show, Generic, NFData) +data ImportG mname = Import + { iModule :: !mname + , iAs :: Maybe ModName + , iSpec :: Maybe ImportSpec + } deriving (Eq, Show, Generic, NFData) +type Import = ImportG ModName + -- | The list of names following an import. --- --- INVARIANT: All of the 'Name' entries in the list are expected to be --- unqualified names; the 'QName' or 'NewName' constructors should not be --- present. data ImportSpec = Hiding [Ident] | Only [Ident] deriving (Eq, Show, Generic, NFData) @@ -234,6 +270,7 @@ , bPragmas :: [Pragma] -- ^ Optional pragmas , bMono :: Bool -- ^ Is this a monomorphic binding , bDoc :: Maybe Text -- ^ Optional doc string + , bExport :: !ExportType } deriving (Eq, Generic, NFData, Functor, Show) type LBindDef = Located (BindDef PName) @@ -263,7 +300,7 @@ -- | Input at the REPL, which can be an expression, a @let@ -- statement, or empty (possibly a comment). data ReplInput name = ExprInput (Expr name) - | LetInput (Decl name) + | LetInput [Decl name] | EmptyInput deriving (Eq, Show) @@ -314,6 +351,11 @@ | EList [Expr n] -- ^ @ [1,2,3] @ | EFromTo (Type n) (Maybe (Type n)) (Type n) (Maybe (Type n)) -- ^ @ [1, 5 .. 117 : t] @ + | EFromToBy Bool (Type n) (Type n) (Type n) (Maybe (Type n)) + -- ^ @ [1 .. 10 by 2 : t ] @ + + | EFromToDownBy Bool (Type n) (Type n) (Type n) (Maybe (Type n)) + -- ^ @ [10 .. 1 down by 2 : t ] @ | EFromToLessThan (Type n) (Type n) (Maybe (Type n)) -- ^ @ [ 1 .. < 10 : t ] @ @@ -482,14 +524,17 @@ getLoc = getLoc . tlValue instance HasLoc (TopDecl name) where - getLoc td = case td of - Decl tld -> getLoc tld - DPrimType pt -> getLoc pt - TDNewtype n -> getLoc n - Include lfp -> getLoc lfp - DParameterType d -> getLoc d - DParameterFun d -> getLoc d - DParameterConstraint d -> getLoc d + getLoc td = + case td of + Decl tld -> getLoc tld + DPrimType pt -> getLoc pt + TDNewtype n -> getLoc n + Include lfp -> getLoc lfp + DParameterType d -> getLoc d + DParameterFun d -> getLoc d + DParameterConstraint d -> getLoc d + DModule d -> getLoc d + DImport d -> getLoc d instance HasLoc (PrimType name) where getLoc pt = Just (rComb (srcRange (primTName pt)) (srcRange (primTKind pt))) @@ -500,7 +545,7 @@ instance HasLoc (ParameterFun name) where getLoc a = getLoc (pfName a) -instance HasLoc (Module name) where +instance HasLoc (ModuleG mname name) where getLoc m | null locs = Nothing | otherwise = Just (rCombs locs) @@ -510,6 +555,9 @@ , getLoc (mDecls m) ] +instance HasLoc (NestedModule name) where + getLoc (NestedModule m) = getLoc m + instance HasLoc (Newtype name) where getLoc n | null locs = Nothing @@ -537,11 +585,25 @@ ppNamed' :: PP a => String -> (Ident, (Range, a)) -> Doc ppNamed' s (i,(_,v)) = pp i <+> text s <+> pp v -instance (Show name, PPName name) => PP (Module name) where - ppPrec _ m = text "module" <+> ppL (mName m) <+> text "where" - $$ vcat (map ppL (mImports m)) - $$ vcat (map pp (mDecls m)) + +instance (Show name, PPName mname, PPName name) => PP (ModuleG mname name) where + ppPrec _ = ppModule 0 + +ppModule :: (Show name, PPName mname, PPName name) => + Int -> ModuleG mname name -> Doc +ppModule n m = + text "module" <+> ppL (mName m) <+> text "where" $$ nest n body + where + body = vcat (map ppL (mImports m)) + $$ vcat (map pp (mDecls m)) + + + +instance (Show name, PPName name) => PP (NestedModule name) where + ppPrec _ (NestedModule m) = ppModule 2 m + + instance (Show name, PPName name) => PP (Program name) where ppPrec _ (Program ds) = vcat (map pp ds) @@ -556,10 +618,12 @@ DParameterType d -> pp d DParameterConstraint d -> "parameter" <+> "type" <+> "constraint" <+> prop - where prop = case map pp d of + where prop = case map (pp . thing) d of [x] -> x [] -> "()" - xs -> parens (hsep (punctuate comma xs)) + xs -> nest 1 (parens (commaSepFill xs)) + DModule d -> pp d + DImport i -> pp (thing i) instance (Show name, PPName name) => PP (PrimType name) where ppPrec _ pt = @@ -580,6 +644,7 @@ DSignature xs s -> commaSep (map ppL xs) <+> text ":" <+> pp s DPatBind p e -> 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 DPragma xs p -> ppPragma xs p DType ts -> ppPrec n ts @@ -592,16 +657,22 @@ ppFixity (Fixity NonAssoc i) ns = text "infix" <+> int i <+> commaSep (map pp ns) instance PPName name => PP (Newtype name) where - ppPrec _ nt = hsep - [ text "newtype", ppL (nName nt), hsep (map pp (nParams nt)), char '=' - , braces (commaSep (map (ppNamed' ":") (displayFields (nBody nt)))) ] + ppPrec _ nt = nest 2 $ sep + [ fsep $ [text "newtype", ppL (nName nt)] ++ map pp (nParams nt) ++ [char '='] + , ppRecord (map (ppNamed' ":") (displayFields (nBody nt))) + ] -instance PP Import where - ppPrec _ d = text "import" <+> sep [ pp (iModule d), mbAs, mbSpec ] +instance PP mname => PP (ImportG mname) where + ppPrec _ d = text "import" <+> sep ([pp (iModule d)] ++ mbAs ++ mbSpec) where - mbAs = maybe empty (\ name -> text "as" <+> pp name ) (iAs d) + mbAs = maybe [] (\ name -> [text "as" <+> pp name]) (iAs d) + mbSpec = maybe [] (\x -> [pp x]) (iSpec d) - mbSpec = maybe empty pp (iSpec d) +instance PP name => PP (ImpName name) where + ppPrec _ nm = + case nm of + ImpTop x -> pp x + ImpNested x -> "submodule" <+> pp x instance PP ImportSpec where ppPrec _ s = case s of @@ -623,16 +694,16 @@ <+> text "*/" instance (Show name, PPName name) => PP (Bind name) where - ppPrec _ b = sig $$ vcat [ ppPragma [f] p | p <- bPragmas b ] $$ - hang (def <+> eq) 4 (pp (thing (bDef b))) + ppPrec _ b = vcat (sig ++ [ ppPragma [f] p | p <- bPragmas b ] ++ + [hang (def <+> eq) 4 (pp (thing (bDef b)))]) where def | bInfix b = lhsOp | otherwise = lhs f = bName b sig = case bSignature b of - Nothing -> empty - Just s -> pp (DSignature [f] s) + Nothing -> [] + Just s -> [pp (DSignature [f] s)] eq = if bMono b then text ":=" else text "=" - lhs = ppL f <+> fsep (map (ppPrec 3) (bParams b)) + lhs = fsep (ppL f : (map (ppPrec 3) (bParams b))) lhsOp = case bParams b of [x,y] -> pp x <+> ppL f <+> pp y @@ -647,13 +718,17 @@ instance PPName name => PP (TySyn name) where ppPrec _ (TySyn x _ xs t) = - text "type" <+> ppL x <+> fsep (map (ppPrec 1) xs) - <+> text "=" <+> pp t + nest 2 $ sep $ + [ fsep $ [text "type", ppL x] ++ map (ppPrec 1) xs ++ [text "="] + , pp t + ] instance PPName name => PP (PropSyn name) where ppPrec _ (PropSyn x _ xs ps) = - text "constraint" <+> ppL x <+> fsep (map (ppPrec 1) xs) - <+> text "=" <+> parens (commaSep (map pp ps)) + nest 2 $ sep $ + [ fsep $ [text "constraint", ppL x] ++ map (ppPrec 1) xs ++ [text "="] + , parens (commaSep (map pp ps)) + ] instance PP Literal where ppPrec _ lit = @@ -710,7 +785,7 @@ | otherwise = bits (Just p) (p : res) (p + 1) (num `shiftR` 1) wrap :: Int -> Int -> Doc -> Doc -wrap contextPrec myPrec doc = if myPrec < contextPrec then parens doc else doc +wrap contextPrec myPrec doc = optParens (myPrec < contextPrec) doc isEApp :: Expr n -> Maybe (Expr n, Expr n) isEApp (ELocated e _) = isEApp e @@ -749,15 +824,23 @@ ERecord fs -> braces (commaSep (map (ppNamed' "=") (displayFields fs))) EList es -> brackets (commaSep (map pp es)) EFromTo e1 e2 e3 t1 -> brackets (pp e1 <.> step <+> text ".." <+> end) - where step = maybe empty (\e -> comma <+> pp e) e2 + where step = maybe mempty (\e -> comma <+> pp e) e2 end = maybe (pp e3) (\t -> pp e3 <+> colon <+> pp t) t1 + EFromToBy isStrict e1 e2 e3 t1 -> brackets (pp e1 <+> dots <+> pp e2 <+> text "by" <+> end) + where end = maybe (pp e3) (\t -> pp e3 <+> colon <+> pp t) t1 + dots | isStrict = text ".. <" + | otherwise = text ".." + EFromToDownBy isStrict e1 e2 e3 t1 -> brackets (pp e1 <+> dots <+> pp e2 <+> text "down by" <+> end) + where end = maybe (pp e3) (\t -> pp e3 <+> colon <+> pp t) t1 + dots | isStrict = text ".. >" + | otherwise = text ".." EFromToLessThan e1 e2 t1 -> brackets (strt <+> text ".. <" <+> end) where strt = maybe (pp e1) (\t -> pp e1 <+> colon <+> pp t) t1 end = pp e2 EInfFrom e1 e2 -> brackets (pp e1 <.> step <+> text "...") - where step = maybe empty (\e -> comma <+> pp e) e2 - EComp e mss -> brackets (pp e <+> vcat (map arm mss)) - where arm ms = text "|" <+> commaSep (map pp ms) + where step = maybe mempty (\e -> comma <+> pp e) e2 + EComp e mss -> brackets (pp e <> align (vcat (map arm mss))) + where arm ms = text " |" <+> commaSep (map pp ms) EUpd mb fs -> braces (hd <+> "|" <+> commaSep (map pp fs)) where hd = maybe "_" pp mb @@ -775,10 +858,10 @@ ETyped e t -> wrap n 0 (ppPrec 2 e <+> text ":" <+> pp t) - EWhere e ds -> wrap n 0 (pp e - $$ text "where" - $$ nest 2 (vcat (map pp ds)) - $$ text "") + EWhere e ds -> wrap n 0 $ align $ vsep + [ pp e + , hang "where" 2 (vcat (map pp ds)) + ] -- infix applications _ | Just ifix <- isInfix expr -> @@ -814,9 +897,9 @@ case pat of PVar x -> pp (thing x) PWild -> char '_' - PTuple ps -> parens (commaSep (map pp ps)) - PRecord fs -> braces (commaSep (map (ppNamed' "=") (displayFields fs))) - PList ps -> brackets (commaSep (map pp ps)) + PTuple ps -> ppTuple (map pp ps) + PRecord fs -> ppRecord (map (ppNamed' "=") (displayFields fs)) + PList ps -> ppList (map pp ps) PTyped p t -> wrap n 0 (ppPrec 1 p <+> text ":" <+> pp t) PSplit p1 p2 -> wrap n 1 (ppPrec 1 p1 <+> text "#" <+> ppPrec 1 p2) PLocated p _ -> ppPrec n p @@ -827,13 +910,13 @@ instance PPName name => PP (Schema name) where - ppPrec _ (Forall xs ps t _) = sep [vars <+> preds, pp t] + ppPrec _ (Forall xs ps t _) = sep (vars ++ preds ++ [pp t]) where vars = case xs of - [] -> empty - _ -> braces (commaSep (map pp xs)) + [] -> [] + _ -> [nest 1 (braces (commaSepFill (map pp xs)))] preds = case ps of - [] -> empty - _ -> parens (commaSep (map pp ps)) <+> text "=>" + [] -> [] + _ -> [nest 1 (parens (commaSepFill (map pp ps))) <+> text "=>"] instance PP Kind where ppPrec _ KType = text "*" @@ -915,13 +998,15 @@ instance NoPos (Program name) where noPos (Program x) = Program (noPos x) -instance NoPos (Module name) where +instance NoPos (ModuleG mname name) where noPos m = Module { mName = mName m , mInstance = mInstance m - , mImports = noPos (mImports m) , mDecls = noPos (mDecls m) } +instance NoPos (NestedModule name) where + noPos (NestedModule m) = NestedModule (noPos m) + instance NoPos (TopDecl name) where noPos decl = case decl of @@ -932,7 +1017,10 @@ DParameterFun d -> DParameterFun (noPos d) DParameterType d -> DParameterType (noPos d) DParameterConstraint d -> DParameterConstraint (noPos d) + DModule d -> DModule (noPos d) + DImport d -> DImport (noPos d) + instance NoPos (PrimType name) where noPos x = x @@ -953,6 +1041,7 @@ DPatBind x y -> DPatBind (noPos x) (noPos y) DFixity f ns -> DFixity f (noPos ns) DBind x -> DBind (noPos x) + DRec bs -> DRec (map noPos bs) DType x -> DType (noPos x) DProp x -> DProp (noPos x) DLocated x _ -> noPos x @@ -973,6 +1062,7 @@ , bPragmas = noPos (bPragmas x) , bMono = bMono x , bDoc = bDoc x + , bExport = bExport x } instance NoPos Pragma where @@ -1001,6 +1091,10 @@ EUpd x y -> EUpd (noPos x) (noPos y) EList x -> EList (noPos x) EFromTo x y z t -> EFromTo (noPos x) (noPos y) (noPos z) (noPos t) + EFromToBy isStrict x y z t + -> EFromToBy isStrict (noPos x) (noPos y) (noPos z) (noPos t) + EFromToDownBy isStrict x y z t + -> EFromToDownBy isStrict (noPos x) (noPos y) (noPos z) (noPos t) EFromToLessThan x y t -> EFromToLessThan (noPos x) (noPos y) (noPos t) EInfFrom x y -> EInfFrom (noPos x) (noPos y) EComp x y -> EComp (noPos x) (noPos y) diff --git a/src/Cryptol/Parser/Layout.hs b/src/Cryptol/Parser/Layout.hs new file mode 100644 --- /dev/null +++ b/src/Cryptol/Parser/Layout.hs @@ -0,0 +1,237 @@ +{-# Language BlockArguments #-} +{-# Language OverloadedStrings #-} +module Cryptol.Parser.Layout where + +import Cryptol.Utils.Panic(panic) +import Cryptol.Parser.Position +import Cryptol.Parser.Token + +{- + +We assume the existence of an explicit EOF token at the end of the input. This token is *less* indented +than all other tokens (i.e., it is at column 0) + +Explicit Layout Blocks + + * The symbols `(`, `{`, and `[` start an explicit layout block. + * While in an explicit layout block we pass through tokens, except: + - We may start new implicit or explicit layout blocks + - A `,` terminates any *nested* layout blocks + - We terminate the current layout block if we encounter the matching + closing symbol `)`, `}`, `]` + +Implicit Layout Blocks + + * The keywords `where`, `private`, and `parameter` start an implicit + layout block. + * The layout block starts at the column of the *following* token and we + insert "virtual start block" between the current and the following tokens. + * While in an implicit layout block: + - We may start new implicit or explicit layout blocks + - We insert a "virtual separator" before tokens starting at the same + column as the layout block, EXCEPT: + * we do not insert a separator if the previous token was a + "documentation comment" + * we do not insert a separator before the first token in the block + + - The implicit layout block is ended by: + * a token than is less indented that the block, or + * `)`, `}`, `]`, or + * ',' but only if there is an outer paren block + block's column. + - When an implicit layout block ends, we insert a "virtual end block" + token just before the token that caused the block to end. + +Examples: + +f = x where x = 0x1 -- end implicit layout by layout +g = 0x3 -- (`g` is less indented than `x`) + +f (x where x = 2) -- end implicit layout by `)` + +[ x where x = 2, 3 ] -- end implicit layout by `,` + +module A where -- two implicit layout blocks with the +private -- *same* indentation (`where` and `private`) +x = 0x2 +-} + + +layout :: Bool -> [Located Token] -> [Located Token] +layout isMod ts0 + + -- Star an implicit layout block at the top of the module + | let t = head ts0 + rng = srcRange t + blockCol = max 1 (col (from rng)) -- see startImplicitBlock + , isMod && tokenType (thing t) /= KW KW_module = + virt rng VCurlyL : go [ Virtual blockCol ] blockCol True ts0 + + | otherwise = + go [] 0 False ts0 + + where + + {- State parameters for `go`: + + stack: + The stack of implicit and explicit blocks + + lastVirt: + The indentation of the outer most implicit block, or 0 if none. + This can be computed from the stack but we cache + it here as we need to check it on each token. + + 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 + next token. + + tokens: + remaining tokens to process + -} + + go stack lastVirt noVirtSep tokens + + -- End implicit layout due to indentation. If the outermost block + -- is a lyout block we just end it. If the outermost block is an + -- explicit layout block we report a lexical error. + | col curLoc < lastVirt = + endImplictBlock + + -- End implicit layout block due to a symbol + | Just (Virtual {}) <- curBlock, endsLayout curTokTy = + endImplictBlock + + -- End implicit layout block due to a comma + | Just (Virtual {}) <- curBlock + , Sym Comma <- curTokTy + , not (null [ () | Explicit _ <- popStack ]) = + endImplictBlock + + -- Insert a virtual separator + | Just (Virtual {}) <- curBlock + , col curLoc == lastVirt && not noVirtSep = + virt curRange VSemi : go stack lastVirt True tokens + + -- Start a new implicit layout. Advances token position. + | startsLayout curTokTy = startImplicitBlock + + -- Start a paren block. Advances token position + | Just close <- startsParenBlock curTokTy = + curTok : go (Explicit close : stack) lastVirt False advanceTokens + + -- End a paren block. Advances token position + | Just (Explicit close) <- curBlock, close == curTokTy = + curTok : go popStack lastVirt False advanceTokens + + -- Disable virtual separator after doc string. Advances token position + | White DocStr <- curTokTy = + curTok : go stack lastVirt True advanceTokens + + -- Check to see if we are done. Note that if we got here, implicit layout + -- blocks should have already been closed, as `EOF` is less indented than + -- all other tokens + | EOF <- curTokTy = + [curTok] + + -- Any other token, just emit. Advances token position + | otherwise = + curTok : go stack lastVirt False advanceTokens + + where + curTok : advanceTokens = tokens + curTokTy = tokenType (thing curTok) + curRange = srcRange curTok + curLoc = from curRange + + (curBlock,popStack) = + case stack of + a : b -> (Just a,b) + [] -> (Nothing, panic "layout" ["pop empty stack"]) + + + startImplicitBlock = + let nextRng = srcRange (head advanceTokens) + nextLoc = from nextRng + blockCol = max 1 (col nextLoc) + -- the `max` ensuraes that indentation is always at least 1, + -- in case we are starting a block at the very end of the input + + in curTok + : virt nextRng VCurlyL + : go (Virtual blockCol : stack) blockCol True advanceTokens + + + endImplictBlock = + case curBlock of + Just (Virtual {}) -> + virt curRange VCurlyR + : go popStack newVirt False tokens + where newVirt = case [ n | Virtual n <- popStack ] of + n : _ -> n + _ -> 0 + + Just (Explicit c) -> + errTok curRange (InvalidIndentation c) : advanceTokens + + Nothing -> panic "layout" ["endImplictBlock with empty stack"] + + +-------------------------------------------------------------------------------- + +data Block = + Virtual Int -- ^ Virtual layout block + | Explicit TokenT -- ^ An explicit layout block, expecting this ending token. + deriving (Show) + +-- | These tokens start an implicit layout block +startsLayout :: TokenT -> Bool +startsLayout ty = + case ty of + KW KW_where -> True + KW KW_private -> True + KW KW_parameter -> True + _ -> False + +-- | These tokens end an implicit layout block +endsLayout :: TokenT -> Bool +endsLayout ty = + case ty of + Sym BracketR -> True + Sym ParenR -> True + Sym CurlyR -> True + _ -> False + +-- | These tokens start an explicit "paren" layout block. +-- If so, the result contains the corresponding closing paren. +startsParenBlock :: TokenT -> Maybe TokenT +startsParenBlock ty = + case ty of + Sym BracketL -> Just (Sym BracketR) + Sym ParenL -> Just (Sym ParenR) + Sym CurlyL -> Just (Sym CurlyR) + _ -> Nothing + + +-------------------------------------------------------------------------------- + +-- | Make a virtual token of the given type +virt :: Range -> TokenV -> Located Token +virt rng x = Located { srcRange = rng { to = from rng }, thing = t } + where + t = Token (Virt x) + case x of + VCurlyL -> "beginning of layout block" + VCurlyR -> "end of layout block" + VSemi -> "layout block separator" + +errTok :: Range -> TokenErr -> Located Token +errTok rng x = Located { srcRange = rng { to = from rng }, thing = t } + where + t = Token { tokenType = Err x, tokenText = "" } + + + + 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 @@ -18,10 +18,13 @@ , Located(..) , Config(..) , defaultConfig + , dbgLex ) where import Cryptol.Parser.Position +import Cryptol.Parser.Token import Cryptol.Parser.LexerUtils +import qualified Cryptol.Parser.Layout as L import Cryptol.Parser.Unlit(unLit) import Data.Text (Text) import qualified Data.Text as Text @@ -100,6 +103,7 @@ "private" { emit $ KW KW_private } "include" { emit $ KW KW_include } "module" { emit $ KW KW_module } +"submodule" { emit $ KW KW_submodule } "newtype" { emit $ KW KW_newtype } "pragma" { emit $ KW KW_pragma } "property" { emit $ KW KW_property } @@ -112,6 +116,8 @@ "as" { emit $ KW KW_as } "hiding" { emit $ KW KW_hiding } "newtype" { emit $ KW KW_newtype } +"down" { emit $ KW KW_down } +"by" { emit $ KW KW_by } "infixl" { emit $ KW KW_infixl } "infixr" { emit $ KW KW_infixr } @@ -143,6 +149,7 @@ ".." { emit $ Sym DotDot } "..." { emit $ Sym DotDotDot } "..<" { emit $ Sym DotDotLt } +"..>" { emit $ Sym DotDotGt } "|" { emit $ Sym Bar } "(" { emit $ Sym ParenL } ")" { emit $ Sym ParenR } @@ -165,6 +172,9 @@ -- < can appear in the enumeration syntax `[ x .. < y ] "<" { emit $ Sym Lt } +-- > can appear in the enumeration syntax `[ x .. > y down by n ] +">" { emit $ Sym Gt } + -- hash is used as a kind, and as a pattern "#" { emit (Op Hash ) } @@ -194,7 +204,7 @@ -- This stream is fed to the parser. lexer :: Config -> Text -> ([Located Token], Position) lexer cfg cs = ( case cfgLayout cfg of - Layout -> layout cfg lexemes + Layout -> L.layout (cfgModuleScope cfg) lexemes NoLayout -> lexemes , finalPos ) @@ -251,6 +261,11 @@ (mtok,s') = act cfg (alexPos i) txt s (rest,pos) = run i' $! s' in (mtok ++ rest, pos) + +dbgLex file = + do txt <- readFile file + let (ts,_) = lexer defaultConfig (Text.pack txt) + mapM_ (print . thing) ts -- vim: ft=haskell } diff --git a/src/Cryptol/Parser/LexerUtils.hs b/src/Cryptol/Parser/LexerUtils.hs --- a/src/Cryptol/Parser/LexerUtils.hs +++ b/src/Cryptol/Parser/LexerUtils.hs @@ -5,19 +5,9 @@ -- Maintainer : cryptol@galois.com -- Stability : provisional -- Portability : portable - -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE BlockArguments #-} module Cryptol.Parser.LexerUtils where -import Cryptol.Parser.Position -import Cryptol.Parser.Unlit(PreProc(None)) -import Cryptol.Utils.PP -import Cryptol.Utils.Panic - import Control.Monad(guard) import Data.Char(toLower,generalCategory,isAscii,ord,isSpace, isAlphaNum,isAlpha) @@ -27,9 +17,13 @@ import qualified Data.Text.Read as T import Data.Word(Word8) -import GHC.Generics (Generic) -import Control.DeepSeq +import Cryptol.Utils.Panic +import Cryptol.Parser.Position +import Cryptol.Parser.Token +import Cryptol.Parser.Unlit(PreProc(None)) + + data Config = Config { cfgSource :: !FilePath -- ^ File that we are working on , cfgStart :: !Position -- ^ Starting position for the parser @@ -362,209 +356,6 @@ notWhite _ = True -data Block = Virtual Int -- ^ Virtual layout block - | Explicit TokenT -- ^ An explicit layout block, expecting this ending - -- token. - deriving (Show) - -isExplicit :: Block -> Bool -isExplicit Explicit{} = True -isExplicit Virtual{} = False - -startsLayout :: TokenT -> Bool -startsLayout (KW KW_where) = True -startsLayout (KW KW_private) = True -startsLayout (KW KW_parameter) = True -startsLayout _ = False - --- Add separators computed from layout -layout :: Config -> [Located Token] -> [Located Token] -layout cfg ts0 = loop False implicitScope [] ts0 - where - - (_pos0,implicitScope) = case ts0 of - t : _ -> (from (srcRange t), cfgModuleScope cfg && tokenType (thing t) /= KW KW_module) - _ -> (start,False) - - - loop :: Bool -> Bool -> [Block] -> [Located Token] -> [Located Token] - loop afterDoc startBlock stack (t : ts) - | startsLayout ty = toks ++ loop False True stack' ts - - -- We don't do layout within these delimeters - | Sym ParenL <- ty = toks ++ loop False False (Explicit (Sym ParenR) : stack') ts - | Sym CurlyL <- ty = toks ++ loop False False (Explicit (Sym CurlyR) : stack') ts - | Sym BracketL <- ty = toks ++ loop False False (Explicit (Sym BracketR) : stack') ts - - | EOF <- ty = toks - | White DocStr <- ty = toks ++ loop True False stack' ts - | otherwise = toks ++ loop False False stack' ts - - where - ty = tokenType (thing t) - pos = srcRange t - - (toks,offStack) - | afterDoc = ([t], stack) - | otherwise = offsides startToks t stack - - -- add any block start tokens, and push a level on the stack - (startToks,stack') - | startBlock && ty == EOF = ( [ virt cfg (to pos) VCurlyR - , virt cfg (to pos) VCurlyL ] - , offStack ) - | startBlock = ( [ virt cfg (to pos) VCurlyL ], Virtual (col (from pos)) : offStack ) - | otherwise = ( [], offStack ) - - loop _ _ _ [] = panic "[Lexer] layout" ["Missing EOF token"] - - - offsides :: [Located Token] -> Located Token -> [Block] -> ([Located Token], [Block]) - offsides startToks t = go startToks - where - go virts stack = case stack of - - -- delimit or close a layout block - Virtual c : rest - -- commas only close to an explicit marker, so if there is none, the - -- comma doesn't close anything - | Sym Comma == ty -> - if any isExplicit rest - then go (virt cfg (to pos) VCurlyR : virts) rest - else done virts stack - - | closingToken -> go (virt cfg (to pos) VCurlyR : virts) rest - | col (from pos) == c -> done (virt cfg (to pos) VSemi : virts) stack - | col (from pos) < c -> go (virt cfg (to pos) VCurlyR : virts) rest - - -- close an explicit block - Explicit close : rest | close == ty -> done virts rest - | Sym Comma == ty -> done virts stack - - _ -> done virts stack - - ty = tokenType (thing t) - pos = srcRange t - - done ts s = (reverse (t:ts), s) - - closingToken = ty `elem` [ Sym ParenR, Sym BracketR, Sym CurlyR ] - -virt :: Config -> Position -> TokenV -> Located Token -virt cfg pos x = Located { srcRange = Range - { from = pos - , to = pos - , source = cfgSource cfg - } - , thing = t } - where t = Token (Virt x) $ case x of - VCurlyL -> "beginning of layout block" - VCurlyR -> "end of layout block" - VSemi -> "layout block separator" - --------------------------------------------------------------------------------- - -data Token = Token { tokenType :: !TokenT, tokenText :: !Text } - deriving (Show, Generic, NFData) - --- | Virtual tokens, inserted by layout processing. -data TokenV = VCurlyL| VCurlyR | VSemi - deriving (Eq, Show, Generic, NFData) - -data TokenW = BlockComment | LineComment | Space | DocStr - deriving (Eq, Show, Generic, NFData) - -data TokenKW = KW_else - | KW_extern - | KW_fin - | KW_if - | KW_private - | KW_include - | KW_inf - | KW_lg2 - | KW_lengthFromThen - | KW_lengthFromThenTo - | KW_max - | KW_min - | KW_module - | KW_newtype - | KW_pragma - | KW_property - | KW_then - | KW_type - | KW_where - | KW_let - | KW_x - | KW_import - | KW_as - | KW_hiding - | KW_infixl - | KW_infixr - | KW_infix - | KW_primitive - | KW_parameter - | KW_constraint - | KW_Prop - deriving (Eq, Show, Generic, NFData) - --- | The named operators are a special case for parsing types, and 'Other' is --- used for all other cases that lexed as an operator. -data TokenOp = Plus | Minus | Mul | Div | Exp | Mod - | Equal | LEQ | GEQ - | Complement | Hash | At - | Other [T.Text] T.Text - deriving (Eq, Show, Generic, NFData) - -data TokenSym = Bar - | ArrL | ArrR | FatArrR - | Lambda - | EqDef - | Comma - | Semi - | Dot - | DotDot - | DotDotDot - | DotDotLt - | Colon - | BackTick - | ParenL | ParenR - | BracketL | BracketR - | CurlyL | CurlyR - | TriL | TriR - | Lt - | Underscore - deriving (Eq, Show, Generic, NFData) - -data TokenErr = UnterminatedComment - | UnterminatedString - | UnterminatedChar - | InvalidString - | InvalidChar - | LexicalError - | MalformedLiteral - | MalformedSelector - deriving (Eq, Show, Generic, NFData) - -data SelectorType = RecordSelectorTok Text | TupleSelectorTok Int - deriving (Eq, Show, Generic, NFData) - -data TokenT = Num !Integer !Int !Int -- ^ value, base, number of digits - | Frac !Rational !Int -- ^ value, base. - | ChrLit !Char -- ^ character literal - | Ident ![T.Text] !T.Text -- ^ (qualified) identifier - | StrLit !String -- ^ string literal - | Selector !SelectorType -- ^ .hello or .123 - | KW !TokenKW -- ^ keyword - | Op !TokenOp -- ^ operator - | Sym !TokenSym -- ^ symbol - | Virt !TokenV -- ^ virtual token (for layout) - | White !TokenW -- ^ white space token - | Err !TokenErr -- ^ error token - | EOF - deriving (Eq, Show, Generic, NFData) - -instance PP Token where - ppPrec _ (Token _ s) = text (T.unpack s) -- | Collapse characters into a single Word8, identifying ASCII, and classes of -- unicode. This came from: diff --git a/src/Cryptol/Parser/Name.hs b/src/Cryptol/Parser/Name.hs --- a/src/Cryptol/Parser/Name.hs +++ b/src/Cryptol/Parser/Name.hs @@ -78,7 +78,7 @@ i = getIdent n pfx = case getModName n of Just ns -> pp ns <.> text "::" - Nothing -> empty + Nothing -> mempty ppInfixName n | isInfixIdent i = pfx <.> pp i @@ -87,4 +87,4 @@ i = getIdent n pfx = case getModName n of Just ns -> pp ns <.> text "::" - Nothing -> empty + Nothing -> mempty 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 @@ -9,15 +9,26 @@ -- This module defines the scoping rules for value- and type-level -- names in Cryptol. -module Cryptol.Parser.Names where +module Cryptol.Parser.Names + ( tnamesNT + , tnamesT + , tnamesC + , namesD + , tnamesD + , namesB + , namesP + + , boundNames + , boundNamesSet + ) where + import Cryptol.Parser.AST import Cryptol.Utils.RecordMap import Data.Set (Set) import qualified Data.Set as Set - -- | The names defined by a newtype. tnamesNT :: Newtype name -> ([Located name], ()) tnamesNT x = ([ nName x ], ()) @@ -34,6 +45,8 @@ namesD decl = case decl of DBind b -> namesB b + DRec bs -> let (xs,ys) = unzip (map namesB bs) + in (concat xs, Set.unions ys) -- remove binders? DPatBind p e -> (namesP p, namesE e) DSignature {} -> ([],Set.empty) DFixity{} -> ([],Set.empty) @@ -42,25 +55,10 @@ DProp {} -> ([],Set.empty) DLocated d _ -> namesD d --- | The names defined and used by a single declarations in such a way --- that they cannot be duplicated in a file. For example, it is fine --- to use @x@ on the RHS of two bindings, but not on the LHS of two --- type signatures. -allNamesD :: Ord name => Decl name -> [Located name] -allNamesD decl = - case decl of - DBind b -> fst (namesB b) - DPatBind p _ -> namesP p - DSignature ns _ -> ns - DFixity _ ns -> ns - DPragma ns _ -> ns - DType ts -> [tsName ts] - DProp ps -> [psName ps] - DLocated d _ -> allNamesD d - -- | The names defined and used by a single binding. namesB :: Ord name => Bind name -> ([Located name], Set name) -namesB b = ([bName b], boundLNames (namesPs (bParams b)) (namesDef (thing (bDef b)))) +namesB b = + ([bName b], boundLNames (namesPs (bParams b)) (namesDef (thing (bDef b)))) namesDef :: Ord name => BindDef name -> Set name @@ -84,6 +82,8 @@ in Set.unions (e : map namesUF fs) EList es -> Set.unions (map namesE es) EFromTo{} -> Set.empty + EFromToBy{} -> Set.empty + EFromToDownBy{} -> Set.empty EFromToLessThan{} -> Set.empty EInfFrom e e' -> Set.union (namesE e) (maybe Set.empty namesE e') EComp e arms -> let (dss,uss) = unzip (map namesArm arms) @@ -164,6 +164,7 @@ DFixity {} -> ([], Set.empty) DPragma {} -> ([], Set.empty) DBind b -> ([], tnamesB b) + DRec bs -> ([], Set.unions (map tnamesB bs)) DPatBind _ e -> ([], tnamesE e) DLocated d _ -> tnamesD d DType (TySyn n _ ps t) @@ -204,6 +205,8 @@ `Set.union` maybe Set.empty tnamesT b `Set.union` tnamesT c `Set.union` maybe Set.empty tnamesT t + EFromToBy _ a b c t -> Set.unions [ tnamesT a, tnamesT b, tnamesT c, maybe Set.empty tnamesT t ] + EFromToDownBy _ a b c t -> Set.unions [ tnamesT a, tnamesT b, tnamesT c, maybe Set.empty tnamesT t ] EFromToLessThan a b t -> tnamesT a `Set.union` tnamesT b `Set.union` maybe Set.empty tnamesT t EInfFrom e e' -> Set.union (tnamesE e) (maybe Set.empty tnamesE e') diff --git a/src/Cryptol/Parser/NoInclude.hs b/src/Cryptol/Parser/NoInclude.hs --- a/src/Cryptol/Parser/NoInclude.hs +++ b/src/Cryptol/Parser/NoInclude.hs @@ -34,7 +34,7 @@ import Cryptol.Parser.LexerUtils (Config(..),defaultConfig) import Cryptol.Parser.ParserUtils import Cryptol.Parser.Unlit (guessPreProc) -import Cryptol.Utils.PP +import Cryptol.Utils.PP hiding (()) removeIncludesModule :: (FilePath -> IO ByteString) -> @@ -160,7 +160,7 @@ return rs -- | Remove includes from a module. -noIncludeModule :: Module PName -> NoIncM (Module PName) +noIncludeModule :: ModuleG mname PName -> NoIncM (ModuleG mname PName) noIncludeModule m = update `fmap` collectErrors noIncTopDecl (mDecls m) where update tds = m { mDecls = concat tds } @@ -174,13 +174,19 @@ -- reference. noIncTopDecl :: TopDecl PName -> NoIncM [TopDecl PName] noIncTopDecl td = case td of - Decl _ -> return [td] + Decl _ -> pure [td] DPrimType {} -> pure [td] - TDNewtype _-> return [td] - DParameterType {} -> return [td] - DParameterConstraint {} -> return [td] - DParameterFun {} -> return [td] + TDNewtype _-> pure [td] + DParameterType {} -> pure [td] + DParameterConstraint {} -> pure [td] + DParameterFun {} -> pure [td] Include lf -> resolveInclude lf + DModule tl -> + case tlValue tl of + NestedModule m -> + do m1 <- noIncludeModule m + pure [ DModule tl { tlValue = NestedModule m1 } ] + DImport {} -> pure [td] -- | Resolve the file referenced by a include into a list of top-level -- declarations. 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 @@ -44,18 +44,23 @@ instance RemovePatterns (Expr PName) where removePatterns e = runNoPatM (noPatE e) -instance RemovePatterns (Module PName) where +instance RemovePatterns (ModuleG mname PName) where removePatterns m = runNoPatM (noPatModule m) instance RemovePatterns [Decl PName] where removePatterns ds = runNoPatM (noPatDs ds) +instance RemovePatterns (NestedModule PName) where + removePatterns (NestedModule m) = (NestedModule m1,errs) + where (m1,errs) = removePatterns m + simpleBind :: Located PName -> Expr PName -> Bind PName simpleBind x e = Bind { bName = x, bParams = [] , bDef = at e (Located emptyRange (DExpr e)) , bSignature = Nothing, bPragmas = [] , bMono = True, bInfix = False, bFixity = Nothing , bDoc = Nothing + , bExport = Public } sel :: Pattern PName -> PName -> Selector -> Bind PName @@ -154,6 +159,8 @@ EUpd mb fs -> EUpd <$> traverse noPatE mb <*> traverse noPatUF fs EList es -> EList <$> mapM noPatE es EFromTo {} -> return expr + EFromToBy {} -> return expr + EFromToDownBy {} -> return expr EFromToLessThan{} -> return expr EInfFrom e e' -> EInfFrom <$> noPatE e <*> traverse noPatE e' EComp e mss -> EComp <$> noPatE e <*> mapM noPatArm mss @@ -226,6 +233,7 @@ DBind b -> do b1 <- noMatchB b return [DBind b1] + DRec {} -> panic "noMatchD" [ "DRec" ] DPatBind p e -> do (p',bs) <- noPat p let (x,ts) = splitSimpleP p' @@ -240,6 +248,7 @@ , bInfix = False , bFixity = Nothing , bDoc = Nothing + , bExport = Public } : map DBind bs DType {} -> return [decl] DProp {} -> return [decl] @@ -323,7 +332,7 @@ noPatProg :: Program PName -> NoPatM (Program PName) noPatProg (Program topDs) = Program <$> noPatTopDs topDs -noPatModule :: Module PName -> NoPatM (Module PName) +noPatModule :: ModuleG mname PName -> NoPatM (ModuleG mname PName) noPatModule m = do ds1 <- noPatTopDs (mDecls m) return m { mDecls = ds1 } @@ -385,6 +394,13 @@ TDNewtype {} -> (d :) <$> annotTopDs ds Include {} -> (d :) <$> annotTopDs ds + DModule m -> + case removePatterns (tlValue m) of + (m1,errs) -> do lift (mapM_ recordError errs) + (DModule m { tlValue = m1 } :) <$> annotTopDs ds + + DImport {} -> (d :) <$> annotTopDs ds + [] -> return [] @@ -403,6 +419,7 @@ annotD decl = case decl of DBind b -> DBind <$> lift (annotB b) + DRec {} -> panic "annotD" [ "DRec" ] DSignature {} -> raise () DFixity{} -> raise () DPragma {} -> raise () @@ -524,6 +541,7 @@ DSignature ns _ -> [ (thing n, [txt]) | n <- ns ] DFixity _ ns -> [ (thing n, [txt]) | n <- ns ] DBind b -> [ (thing (bName b), [txt]) ] + DRec {} -> panic "toDocs" [ "DRec" ] DLocated d _ -> go txt d DPatBind p _ -> [ (thing n, [txt]) | n <- namesP p ] 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 @@ -35,10 +35,10 @@ import Cryptol.Parser.AST import Cryptol.Parser.Lexer -import Cryptol.Parser.LexerUtils(SelectorType(..)) +import Cryptol.Parser.Token(SelectorType(..)) import Cryptol.Parser.Position import Cryptol.Parser.Utils (translateExprToNumT,widthIdent) -import Cryptol.Utils.Ident(packModName) +import Cryptol.Utils.Ident(packModName,packIdent,modNameChunks) import Cryptol.Utils.PP import Cryptol.Utils.Panic import Cryptol.Utils.RecordMap @@ -81,6 +81,12 @@ T.unpack (tokenText it) MalformedSelector -> "malformed selector: " ++ T.unpack (tokenText it) + InvalidIndentation c -> "invalid indentation, unmatched " ++ + case c of + Sym CurlyR -> "{ ... } " + Sym ParenR -> "( ... )" + Sym BracketR -> "[ ... ]" + _ -> show c -- basically panic ] where it = thing t @@ -111,13 +117,13 @@ | White DocStr <- tokenType tok = "Unexpected documentation (/**) comment at" <+> text path <.> char ':' <.> pp pos <.> colon $$ - nest 2 + indent 2 "Documentation comments need to be followed by something to document." | otherwise = text "Parse error at" <+> text path <.> char ':' <.> pp pos <.> comma $$ - nest 2 (text "unexpected:" <+> pp tok) + indent 2 (text "unexpected:" <+> pp tok) where pos = from (srcRange ltok) tok = thing ltok @@ -126,18 +132,18 @@ text "Unexpected end of file at:" <+> text path <.> char ':' <.> pp pos -ppError (HappyErrorMsg p xs) = text "Parse error at" <+> pp p $$ nest 2 (vcat (map text xs)) +ppError (HappyErrorMsg p xs) = text "Parse error at" <+> pp p $$ indent 2 (vcat (map text xs)) ppError (HappyUnexpected path ltok e) = - text "Parse error at" <+> - text path <.> char ':' <.> pp pos <.> comma $$ - nest 2 unexp $$ - nest 2 ("expected:" <+> text e) + nest 2 $ vcat $ + [ text "Parse error at" <+> text path <.> char ':' <.> pp pos <.> comma ] + ++ unexp + ++ ["expected:" <+> text e] where (unexp,pos) = case ltok of - Nothing -> (empty,start) - Just t -> ( "unexpected:" <+> text (T.unpack (tokenText (thing t))) + Nothing -> ( [] ,start) + Just t -> ( ["unexpected:" <+> text (T.unpack (tokenText (thing t)))] , from (srcRange t) ) @@ -372,6 +378,43 @@ (Nothing, Nothing, Nothing) -> eFromToType r e1 e2 e3 Nothing _ -> errorMessage r ["A sequence enumeration may have at most one element type annotation."] +eFromToBy :: Range -> Expr PName -> Expr PName -> Expr PName -> Bool -> ParseM (Expr PName) +eFromToBy r e1 e2 e3 isStrictBound = + case (asETyped e1, asETyped e2, asETyped e3) of + (Just (e1', t), Nothing, Nothing) -> eFromToByTyped r e1' e2 e3 (Just t) isStrictBound + (Nothing, Just (e2', t), Nothing) -> eFromToByTyped r e1 e2' e3 (Just t) isStrictBound + (Nothing, Nothing, Just (e3', t)) -> eFromToByTyped r e1 e2 e3' (Just t) isStrictBound + (Nothing, Nothing, Nothing) -> eFromToByTyped r e1 e2 e3 Nothing isStrictBound + _ -> errorMessage r ["A sequence enumeration may have at most one element type annotation."] + +eFromToByTyped :: Range -> Expr PName -> Expr PName -> Expr PName -> Maybe (Type PName) -> Bool -> ParseM (Expr PName) +eFromToByTyped r e1 e2 e3 t isStrictBound = + EFromToBy isStrictBound + <$> exprToNumT r e1 + <*> exprToNumT r e2 + <*> exprToNumT r e3 + <*> pure t + +eFromToDownBy :: + Range -> Expr PName -> Expr PName -> Expr PName -> Bool -> ParseM (Expr PName) +eFromToDownBy r e1 e2 e3 isStrictBound = + case (asETyped e1, asETyped e2, asETyped e3) of + (Just (e1', t), Nothing, Nothing) -> eFromToDownByTyped r e1' e2 e3 (Just t) isStrictBound + (Nothing, Just (e2', t), Nothing) -> eFromToDownByTyped r e1 e2' e3 (Just t) isStrictBound + (Nothing, Nothing, Just (e3', t)) -> eFromToDownByTyped r e1 e2 e3' (Just t) isStrictBound + (Nothing, Nothing, Nothing) -> eFromToDownByTyped r e1 e2 e3 Nothing isStrictBound + _ -> errorMessage r ["A sequence enumeration may have at most one element type annotation."] + +eFromToDownByTyped :: + Range -> Expr PName -> Expr PName -> Expr PName -> Maybe (Type PName) -> Bool -> ParseM (Expr PName) +eFromToDownByTyped r e1 e2 e3 t isStrictBound = + EFromToDownBy isStrictBound + <$> exprToNumT r e1 + <*> exprToNumT r e2 + <*> exprToNumT r e3 + <*> pure t + + asETyped :: Expr n -> Maybe (Expr n, Type n) asETyped (ELocated e _) = asETyped e asETyped (ETyped e t) = Just (e, t) @@ -433,6 +476,11 @@ , tlDoc = d , tlValue = n } +exportModule :: Maybe (Located Text) -> NestedModule PName -> TopDecl PName +exportModule mbDoc m = DModule TopLevel { tlExport = Public + , tlDoc = mbDoc + , tlValue = m } + mkParFun :: Maybe (Located Text) -> Located PName -> Schema PName -> @@ -464,7 +512,9 @@ change (Decl d) = Decl d { tlExport = e } change (DPrimType t) = DPrimType t { tlExport = e } change (TDNewtype n) = TDNewtype n { tlExport = e } + change (DModule m) = DModule m { tlExport = e } change td@Include{} = td + change td@DImport{} = td change (DParameterType {}) = panic "changeExport" ["private type parameter?"] change (DParameterFun {}) = panic "changeExport" ["private value parameter?"] change (DParameterConstraint {}) = @@ -534,6 +584,7 @@ , bInfix = False , bFixity = Nothing , bDoc = Nothing + , bExport = Public } -- NOTE: The lists of patterns are reversed! @@ -549,6 +600,7 @@ , bInfix = False , bFixity = Nothing , bDoc = Nothing + , bExport = Public } where rhs :: Expr PName @@ -588,6 +640,7 @@ , bInfix = isInfixIdent (getIdent (thing ln)) , bFixity = Nothing , bDoc = Nothing + , bExport = Public } , exportDecl Nothing Public $ DSignature [ln] sig @@ -737,18 +790,24 @@ err = errorMessage r ["Invalid constraint"] -- | Make an ordinary module -mkModule :: Located ModName -> - ([Located Import], [TopDecl PName]) -> - Module PName -mkModule nm (is,ds) = Module { mName = nm - , mInstance = Nothing - , mImports = is - , mDecls = ds - } +mkModule :: Located ModName -> [TopDecl PName] -> Module PName +mkModule nm ds = Module { mName = nm + , mInstance = Nothing + , mDecls = ds + } +mkNested :: Module PName -> ParseM (NestedModule PName) +mkNested m = + case modNameChunks (thing nm) of + [c] -> pure (NestedModule m { mName = nm { thing = mkUnqual (packIdent c)}}) + _ -> errorMessage r + ["Nested modules names should be a simple identifier."] + where + nm = mName m + r = srcRange nm + -- | Make an unnamed module---gets the name @Main@. -mkAnonymousModule :: ([Located Import], [TopDecl PName]) -> - Module PName +mkAnonymousModule :: [TopDecl PName] -> Module PName mkAnonymousModule = mkModule Located { srcRange = emptyRange , thing = mkModName [T.pack "Main"] } @@ -756,12 +815,11 @@ -- | Make a module which defines a functor instance. mkModuleInstance :: Located ModName -> Located ModName -> - ([Located Import], [TopDecl PName]) -> + [TopDecl PName] -> Module PName -mkModuleInstance nm fun (is,ds) = +mkModuleInstance nm fun ds = Module { mName = nm , mInstance = Just fun - , mImports = is , mDecls = ds } 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,6 +10,9 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE RecordWildCards #-} module Cryptol.Parser.Position where @@ -22,7 +25,8 @@ import Cryptol.Utils.PP data Located a = Located { srcRange :: !Range, thing :: !a } - deriving (Eq, Ord, Show, Generic, NFData) + deriving (Eq, Ord, Show, Generic, NFData + , Functor, Foldable, Traversable ) data Position = Position { line :: !Int, col :: !Int } @@ -65,8 +69,6 @@ rCombs :: [Range] -> Range rCombs = foldl1 rComb -instance Functor Located where - fmap f l = l { thing = f (thing l) } -------------------------------------------------------------------------------- diff --git a/src/Cryptol/Parser/Selector.hs b/src/Cryptol/Parser/Selector.hs --- a/src/Cryptol/Parser/Selector.hs +++ b/src/Cryptol/Parser/Selector.hs @@ -48,16 +48,16 @@ instance PP Selector where ppPrec _ sel = case sel of - TupleSel x sig -> int x <+> ppSig tupleSig sig - RecordSel x sig -> pp x <+> ppSig recordSig sig - ListSel x sig -> int x <+> ppSig listSig sig + TupleSel x sig -> sep (int x : ppSig tupleSig sig) + RecordSel x sig -> sep (pp x : ppSig recordSig sig) + ListSel x sig -> sep (int x : ppSig listSig sig) where tupleSig n = int n - recordSig xs = braces $ fsep $ punctuate comma $ map pp xs + recordSig xs = ppRecord $ map pp xs listSig n = int n - ppSig f = maybe empty (\x -> text "/* of" <+> f x <+> text "*/") + ppSig f = maybe [] (\x -> [text "/* of" <+> f x <+> text "*/"]) -- | Display the thing selected by the selector, nicely. diff --git a/src/Cryptol/Parser/Token.hs b/src/Cryptol/Parser/Token.hs new file mode 100644 --- /dev/null +++ b/src/Cryptol/Parser/Token.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +module Cryptol.Parser.Token where + +import Data.Text(Text) +import qualified Data.Text as Text +import Control.DeepSeq +import GHC.Generics + +import Cryptol.Utils.PP + +data Token = Token { tokenType :: !TokenT, tokenText :: !Text } + deriving (Show, Generic, NFData) + +-- | Virtual tokens, inserted by layout processing. +data TokenV = VCurlyL| VCurlyR | VSemi + deriving (Eq, Show, Generic, NFData) + +data TokenW = BlockComment | LineComment | Space | DocStr + deriving (Eq, Show, Generic, NFData) + +data TokenKW = KW_else + | KW_extern + | KW_fin + | KW_if + | KW_private + | KW_include + | KW_inf + | KW_lg2 + | KW_lengthFromThen + | KW_lengthFromThenTo + | KW_max + | KW_min + | KW_module + | KW_submodule + | KW_newtype + | KW_pragma + | KW_property + | KW_then + | KW_type + | KW_where + | KW_let + | KW_x + | KW_import + | KW_as + | KW_hiding + | KW_infixl + | KW_infixr + | KW_infix + | KW_primitive + | KW_parameter + | KW_constraint + | KW_Prop + | KW_by + | KW_down + deriving (Eq, Show, Generic, NFData) + +-- | The named operators are a special case for parsing types, and 'Other' is +-- used for all other cases that lexed as an operator. +data TokenOp = Plus | Minus | Mul | Div | Exp | Mod + | Equal | LEQ | GEQ + | Complement | Hash | At + | Other [Text] Text + deriving (Eq, Show, Generic, NFData) + +data TokenSym = Bar + | ArrL | ArrR | FatArrR + | Lambda + | EqDef + | Comma + | Semi + | Dot + | DotDot + | DotDotDot + | DotDotLt + | DotDotGt + | Colon + | BackTick + | ParenL | ParenR + | BracketL | BracketR + | CurlyL | CurlyR + | TriL | TriR + | Lt | Gt + | Underscore + deriving (Eq, Show, Generic, NFData) + +data TokenErr = UnterminatedComment + | UnterminatedString + | UnterminatedChar + | InvalidString + | InvalidChar + | LexicalError + | MalformedLiteral + | MalformedSelector + | InvalidIndentation TokenT -- expected closing paren + deriving (Eq, Show, Generic, NFData) + +data SelectorType = RecordSelectorTok Text | TupleSelectorTok Int + deriving (Eq, Show, Generic, NFData) + +data TokenT = Num !Integer !Int !Int -- ^ value, base, number of digits + | Frac !Rational !Int -- ^ value, base. + | ChrLit !Char -- ^ character literal + | Ident ![Text] !Text -- ^ (qualified) identifier + | StrLit !String -- ^ string literal + | Selector !SelectorType -- ^ .hello or .123 + | KW !TokenKW -- ^ keyword + | Op !TokenOp -- ^ operator + | Sym !TokenSym -- ^ symbol + | Virt !TokenV -- ^ virtual token (for layout) + | White !TokenW -- ^ white space token + | Err !TokenErr -- ^ error token + | EOF + deriving (Eq, Show, Generic, NFData) + +instance PP Token where + ppPrec _ (Token _ s) = text (Text.unpack s) + + diff --git a/src/Cryptol/REPL/Browse.hs b/src/Cryptol/REPL/Browse.hs new file mode 100644 --- /dev/null +++ b/src/Cryptol/REPL/Browse.hs @@ -0,0 +1,155 @@ +{-# Language OverloadedStrings, BlockArguments #-} +module Cryptol.REPL.Browse (BrowseHow(..), browseModContext) where + +import qualified Data.Set as Set +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe(mapMaybe) +import Data.List(sortBy) +import Data.Void (Void) +import qualified Prettyprinter as PP + +import Cryptol.Parser.AST(Pragma(..)) +import qualified Cryptol.TypeCheck.Type as T + +import Cryptol.Utils.PP +import Cryptol.ModuleSystem.Env(ModContext(..)) +import Cryptol.ModuleSystem.NamingEnv(namingEnvNames) +import Cryptol.ModuleSystem.Name +import Cryptol.ModuleSystem.Interface + +data BrowseHow = BrowseExported | BrowseInScope + +browseModContext :: BrowseHow -> ModContext -> PP.Doc Void +browseModContext how mc = runDoc (env disp) (vcat sections) + where + sections = concat + [ browseMParams (env disp) (mctxParams mc) + , browseMods disp decls + , browseTSyns disp decls + , browsePrimTys disp decls + , browseNewtypes disp decls + , browseVars disp decls + ] + + disp = DispInfo { dispHow = how, env = mctxNameDisp mc } + decls = filterIfaceDecls (`Set.member` visNames) (mctxDecls mc) + allNames = namingEnvNames (mctxNames mc) + visNames = case how of + BrowseInScope -> allNames + BrowseExported -> mctxExported mc + +data DispInfo = DispInfo { dispHow :: BrowseHow, env :: NameDisp } + +-------------------------------------------------------------------------------- + + +browseMParams :: NameDisp -> IfaceParams -> [Doc] +browseMParams disp params = + ppSectionHeading "Module Parameters" + $ addEmpty + $ map ppParamTy (sortByName disp (Map.toList (ifParamTypes params))) ++ + map ppParamFu (sortByName disp (Map.toList (ifParamFuns params))) + where + ppParamTy p = nest 2 (sep ["type", pp (T.mtpName p) <+> ":", pp (T.mtpKind p)]) + ppParamFu p = nest 2 (sep [pp (T.mvpName p) <+> ":", pp (T.mvpType p)]) + -- XXX: should we print the constraints somewhere too? + + addEmpty xs = case xs of + [] -> [] + _ -> xs ++ [" "] + + +browseMods :: DispInfo -> IfaceDecls -> [Doc] +browseMods disp decls = + ppSection disp "Modules" ppM (ifModules decls) + where + ppM m = "submodule" <+> pp (ifModName m) + -- XXX: can print a lot more information about the moduels, but + -- might be better to do that with a separate command + + + + +browseTSyns :: DispInfo -> IfaceDecls -> [Doc] +browseTSyns disp decls = + ppSection disp "Type Synonyms" pp tss + ++ ppSection disp "Constraint Synonyms" pp cts + where + (cts,tss) = Map.partition isCtrait (ifTySyns decls) + isCtrait t = T.kindResult (T.kindOf (T.tsDef t)) == T.KProp + +browsePrimTys :: DispInfo -> IfaceDecls -> [Doc] +browsePrimTys disp decls = + ppSection disp "Primitive Types" ppA (ifAbstractTypes decls) + where + ppA a = nest 2 (sep [pp (T.atName a) <+> ":", pp (T.atKind a)]) + +browseNewtypes :: DispInfo -> IfaceDecls -> [Doc] +browseNewtypes disp decls = + ppSection disp "Newtypes" T.ppNewtypeShort (ifNewtypes decls) + +browseVars :: DispInfo -> IfaceDecls -> [Doc] +browseVars disp decls = + ppSection disp "Properties" ppVar props + ++ ppSection disp "Symbols" ppVar syms + where + isProp p = PragmaProperty `elem` ifDeclPragmas p + (props,syms) = Map.partition isProp (ifDecls decls) + + ppVar d = nest 2 (sep [pp (ifDeclName d) <+> ":", pp (ifDeclSig d)]) + +-------------------------------------------------------------------------------- + +ppSection :: DispInfo -> String -> (a -> Doc) -> Map Name a -> [Doc] +ppSection disp heading ppThing mp = + ppSectionHeading heading + case dispHow disp of + BrowseExported | [(_,xs)] <- grouped -> ppThings xs + _ -> concatMap ppMod grouped + where + grouped = groupDecls (env disp) mp + + ppThings xs = map ppThing xs ++ [" "] + + ppMod (nm,things) = + [ "From" <+> pp nm + , "-----" <.> text (map (const '-') (show (runDoc (env disp) (pp nm)))) + , " " + , indent 2 (vcat (ppThings things)) + ] + +ppSectionHeading :: String -> [Doc] -> [Doc] +ppSectionHeading heading body + | null body = [] + | otherwise = + [ text heading + , text (map (const '=') heading) + , " " + , indent 2 (vcat body) + ] + + + + +-- | Organize by module where defined, then sort by name. +groupDecls :: NameDisp -> Map Name a -> [(ModPath,[a])] +groupDecls disp = Map.toList + . fmap (sortByName disp) + . Map.fromListWith (++) + . mapMaybe toEntry + . Map.toList + where + toEntry (n,a) = + case nameInfo n of + Declared m _ -> Just (m,[(n,a)]) + _ -> Nothing + + +sortByName :: NameDisp -> [(Name,a)] -> [a] +sortByName disp = map snd . sortBy cmpByDispName + where + cmpByDispName (x,_) (y,_) = cmpNameDisplay disp x y + + + 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 @@ -46,6 +46,7 @@ -- Misc utilities , handleCtrlC , sanitize + , withRWTempFile -- To support Notebook interface (might need to refactor) , replParse @@ -55,6 +56,7 @@ import Cryptol.REPL.Monad import Cryptol.REPL.Trie +import Cryptol.REPL.Browse import qualified Cryptol.ModuleSystem as M import qualified Cryptol.ModuleSystem.Name as M @@ -64,6 +66,7 @@ import qualified Cryptol.ModuleSystem.Env as M import qualified Cryptol.Backend.Monad as E +import qualified Cryptol.Backend.SeqMap as E import Cryptol.Eval.Concrete( Concrete(..) ) import qualified Cryptol.Eval.Concrete as Concrete import qualified Cryptol.Eval.Env as E @@ -81,9 +84,8 @@ import qualified Cryptol.TypeCheck.Parseable as T import qualified Cryptol.TypeCheck.Subst as T import Cryptol.TypeCheck.Solve(defaultReplExpr) -import qualified Cryptol.TypeCheck.Solver.SMT as SMT import Cryptol.TypeCheck.PP (dump,ppWithNames,emptyNameMap) -import Cryptol.Utils.PP +import Cryptol.Utils.PP hiding (()) import Cryptol.Utils.Panic(panic) import Cryptol.Utils.RecordMap import qualified Cryptol.Parser.AST as P @@ -106,8 +108,7 @@ import Data.Bits (shiftL, (.&.), (.|.)) import Data.Char (isSpace,isPunctuation,isSymbol,isAlphaNum,isAscii) import Data.Function (on) -import Data.List (intercalate, nub, sortBy, groupBy, - partition, isPrefixOf,intersperse) +import Data.List (intercalate, nub, isPrefixOf,intersperse) import Data.Maybe (fromMaybe,mapMaybe,isNothing) import System.Environment (lookupEnv) import System.Exit (ExitCode(ExitSuccess)) @@ -117,7 +118,6 @@ import System.Directory(getHomeDirectory,setCurrentDirectory,doesDirectoryExist ,getTemporaryDirectory,setPermissions,removeFile ,emptyPermissions,setOwnerReadable) -import Data.Map (Map) import qualified Data.Map as Map import qualified Data.Set as Set import System.IO @@ -200,8 +200,12 @@ "Check the type of an expression." "" , CommandDescr [ ":b", ":browse" ] ["[ MODULE ]"] (ModNameArg browseCmd) - "Display environment for all loaded modules, or for a specific module." - "" + "Display information about loaded modules." + (unlines + [ "With no arguent, :browse shows information about the names in scope." + , "With an argument M, shows information about the names exported from M" + ] + ) , CommandDescr [ ":version"] [] (NoArg versionCmd) "Display the version of this Cryptol executable" "" @@ -332,10 +336,10 @@ -- $ return $!! show $ pp $ E.WithBase ppOpts val rPutStrLn (show valDoc) - P.LetInput decl -> do + P.LetInput ds -> do -- explicitly make this a top-level declaration, so that it will -- be generalized if mono-binds is enabled - replEvalDecl decl + replEvalDecls ds P.EmptyInput -> -- comment or empty input does nothing pure () @@ -344,16 +348,16 @@ printCounterexample cexTy exprDoc vs = do ppOpts <- getPPValOpts docs <- mapM (rEval . E.ppValue Concrete ppOpts) vs - rPrint $ hang exprDoc 2 (sep docs) <+> - case cexTy of - SafetyViolation -> text "~> ERROR" - PredicateFalsified -> text "= False" + let cexRes = case cexTy of + SafetyViolation -> [text "~> ERROR"] + PredicateFalsified -> [text "= False"] + rPrint $ nest 2 (sep ([exprDoc] ++ docs ++ cexRes)) printSatisfyingModel :: Doc -> [Concrete.Value] -> REPL () printSatisfyingModel exprDoc vs = do ppOpts <- getPPValOpts docs <- mapM (rEval . E.ppValue Concrete ppOpts) vs - rPrint $ hang exprDoc 2 (sep docs) <+> text ("= True") + rPrint $ nest 2 (sep ([exprDoc] ++ docs ++ [text "= True"])) dumpTestsCmd :: FilePath -> String -> (Int,Int) -> Maybe FilePath -> REPL () @@ -781,6 +785,9 @@ ~(EnvBool yes) <- getUser "showExamples" when yes $ forM_ vss (printSatisfyingModel exprDoc) + let numModels = length tevss + when (numModels > 1) (rPutStrLn ("Models found: " ++ show numModels)) + case exprs of [e] -> void $ bindItVariable ty e _ -> bindItVariables ty exprs @@ -881,10 +888,10 @@ Just path -> io $ writeFile path smtlib Nothing -> rPutStr smtlib - Right w4Cfg -> + Right _w4Cfg -> do ~(EnvBool hashConsing) <- getUser "hashConsing" ~(EnvBool warnUninterp) <- getUser "warnUninterp" - result <- liftModuleCmd $ W4.satProveOffline w4Cfg hashConsing warnUninterp cmd $ \f -> + result <- liftModuleCmd $ W4.satProveOffline hashConsing warnUninterp cmd $ \f -> do displayMsg case mfile of Just path -> @@ -977,7 +984,8 @@ whenDebug (rPutStrLn (dump def)) fDisp <- M.mctxNameDisp <$> getFocusedEnv -- type annotation ':' has precedence 2 - rPrint $ runDoc fDisp $ ppPrec 2 expr <+> text ":" <+> pp sig + rPrint $ runDoc fDisp $ group $ hang + (ppPrec 2 expr <+> text ":") 2 (pp sig) readFileCmd :: FilePath -> REPL () readFileCmd fp = do @@ -1156,212 +1164,18 @@ quitCmd = stop browseCmd :: String -> REPL () -browseCmd input = do - let mnames = map (M.textToModName . T.pack) (words input) - validModNames <- (:) M.interactiveName <$> getModNames - let checkModName m = - unless (m `elem` validModNames) $ - rPutStrLn ("error: " ++ show m ++ " is not a loaded module.") - mapM_ checkModName mnames - - fe <- getFocusedEnv - - let params = M.mctxParams fe - iface = M.mctxDecls fe - names = M.mctxNames fe - disp = M.mctxNameDisp fe - provV = M.mctxValueProvenance fe - provT = M.mctxTypeProvenace fe - - - let f &&& g = \x -> f x && g x - isUser x = case M.nameInfo x of - M.Declared _ M.SystemName -> False - _ -> True - inSet s x = x `Set.member` s - - let (visibleTypes,visibleDecls) = M.visibleNames names - - restricted = if null mnames then const True else hasAnyModName mnames - - visibleType = isUser &&& restricted &&& inSet visibleTypes - visibleDecl = isUser &&& restricted &&& inSet visibleDecls - - browseMParams visibleType visibleDecl params disp - browseTSyns visibleType provT iface disp - browsePrimTys visibleType provT iface disp - browseNewtypes visibleType provT iface disp - browseVars visibleDecl provV iface disp - - -browseMParams :: (M.Name -> Bool) -> (M.Name -> Bool) -> - M.IfaceParams -> NameDisp -> REPL () -browseMParams visT visD M.IfaceParams { .. } names = - do ppBlock names ppParamTy "Type Parameters" - (sorted visT T.mtpName ifParamTypes) - ppBlock names ppParamFu "Value Parameters" - (sorted visD T.mvpName ifParamFuns) - - where - ppParamTy T.ModTParam { .. } = hang ("type" <+> pp mtpName <+> ":") - 2 (pp mtpKind) - ppParamFu T.ModVParam { .. } = hang (pp mvpName <+> ":") 2 (pp mvpType) - - sorted vis nm mp = sortBy (M.cmpNameDisplay names `on` nm) - $ filter (vis . nm) $ Map.elems mp - -type Prov = Map M.Name M.DeclProvenance - -browsePrimTys :: (M.Name -> Bool) -> Prov -> M.IfaceDecls -> NameDisp -> REPL () -browsePrimTys isVisible prov M.IfaceDecls { .. } names = - ppSection (Map.elems ifAbstractTypes) - Section { secName = "Primitive Types" - , secEntryName = T.atName - , secProvenance = prov - , secDisp = names - , secPP = ppA - , secVisible = isVisible - } - where - ppA a = pp (T.atName a) <+> ":" <+> pp (T.atKind a) - - -browseTSyns :: (M.Name -> Bool) -> Prov -> M.IfaceDecls -> NameDisp -> REPL () -browseTSyns isVisible prov M.IfaceDecls { .. } names = - do ppSection tss - Section { secName = "Type Synonyms" - , secEntryName = T.tsName - , secProvenance = prov - , secDisp = names - , secVisible = isVisible - , secPP = pp - } - ppSection cts - Section { secName = "Constraint Synonyms" - , secEntryName = T.tsName - , secProvenance = prov - , secDisp = names - , secVisible = isVisible - , secPP = pp - } - where - (cts,tss) = partition isCtrait (Map.elems ifTySyns) - isCtrait t = T.kindResult (T.kindOf (T.tsDef t)) == T.KProp - -browseNewtypes :: - (M.Name -> Bool) -> Prov -> M.IfaceDecls -> NameDisp -> REPL () -browseNewtypes isVisible prov M.IfaceDecls { .. } names = - ppSection (Map.elems ifNewtypes) - Section { secName = "Newtypes" - , secEntryName = T.ntName - , secVisible = isVisible - , secProvenance = prov - , secDisp = names - , secPP = T.ppNewtypeShort - } - -browseVars :: (M.Name -> Bool) -> Prov -> M.IfaceDecls -> NameDisp -> REPL () -browseVars isVisible prov M.IfaceDecls { .. } names = - do ppSection props Section { secName = "Properties" - , secEntryName = M.ifDeclName - , secVisible = isVisible - , secProvenance = prov - , secDisp = names - , secPP = ppVar - } - ppSection syms Section { secName = "Symbols" - , secEntryName = M.ifDeclName - , secVisible = isVisible - , secProvenance = prov - , secDisp = names - , secPP = ppVar - } - - where - isProp p = T.PragmaProperty `elem` (M.ifDeclPragmas p) - (props,syms) = partition isProp (Map.elems ifDecls) - - ppVar M.IfaceDecl { .. } = hang (pp ifDeclName <+> char ':') 2 (pp ifDeclSig) - - - -data Section a = Section - { secName :: String - , secEntryName :: a -> M.Name - , secVisible :: M.Name -> Bool - , secProvenance :: Map M.Name M.DeclProvenance - , secDisp :: NameDisp - , secPP :: a -> Doc - } - -ppSection :: [a] -> Section a -> REPL () -ppSection things s - | null grouped = pure () +browseCmd input + | null input = + do fe <- getFocusedEnv + rPrint (browseModContext BrowseInScope fe) | otherwise = - do let heading = secName s - rPutStrLn heading - rPutStrLn (map (const '=') heading) - rPutStrLn "" - mapM_ ppSub grouped - - where - ppSub (p,ts) = - do let heading = provHeading p - rPutStrLn (" " ++ heading) - rPutStrLn (" " ++ map (const '-') heading) - rPutStrLn "" - rPutStrLn $ show $ runDoc (secDisp s) $ nest 4 $ vcat $ map (secPP s) ts - rPutStrLn "" - - grouped = map rearrange $ - groupBy sameProv $ - sortBy cmpThings - [ (n,p,t) | t <- things, - let n = secEntryName s t, - secVisible s n, - let p = case Map.lookup n (secProvenance s) of - Just i -> i - Nothing -> panic "ppSection" - [ "Name with no provenance" - , show n ] - ] - - rearrange xs = (p, [ a | (_,_,a) <- xs ]) - where (_,p,_) : _ = xs - - cmpThings (n1, p1, _) (n2, p2, _) = - case cmpProv p1 p2 of - EQ -> M.cmpNameDisplay (secDisp s) n1 n2 - r -> r - - sameProv (_,p1,_) (_,p2,_) = provOrd p1 == provOrd p2 - - provOrd p = - case p of - M.NameIsParameter -> Left 1 :: Either Int P.ModName - M.NameIsDynamicDecl -> Left 2 - M.NameIsLocalPublic -> Left 3 - M.NameIsLocalPrivate -> Left 4 - M.NameIsImportedFrom x -> Right x - - cmpProv p1 p2 = compare (provOrd p1) (provOrd p2) - - provHeading p = - case p of - M.NameIsParameter -> "Parameters" - M.NameIsDynamicDecl -> "REPL" - M.NameIsLocalPublic -> "Public" - M.NameIsLocalPrivate -> "Private" - M.NameIsImportedFrom m -> "From " ++ show (pp m) - - - -ppBlock :: NameDisp -> (a -> Doc) -> String -> [a] -> REPL () -ppBlock names ppFun name xs = unless (null xs) $ - do rPutStrLn name - rPutStrLn (replicate (length name) '=') - rPrint (runDoc names (nest 4 (vcat (map ppFun xs)))) - rPutStrLn "" + case parseModName input of + Nothing -> rPutStrLn "Invalid module name" + Just m -> + do mb <- M.modContextOf m <$> getModuleEnv + case mb of + Nothing -> rPutStrLn ("Module " ++ show input ++ " is not loaded") + Just fe -> rPrint (browseModContext BrowseExported fe) setOptionCmd :: String -> REPL () @@ -1414,14 +1228,16 @@ vNames = M.lookupValNames qname rnEnv tNames = M.lookupTypeNames qname rnEnv + mNames = M.lookupNS M.NSModule qname rnEnv let helps = map (showTypeHelp params env disp) tNames ++ - map (showValHelp params env disp qname) vNames + map (showValHelp params env disp qname) vNames ++ + map (showModHelp env disp) mNames separ = rPutStrLn " ---------" sequence_ (intersperse separ helps) - when (null (vNames ++ tNames)) $ + when (null (vNames ++ tNames ++ mNames)) $ rPrint $ "Undefined name:" <+> pp qname Nothing -> rPutStrLn ("Unable to parse name: " ++ cmd) @@ -1434,6 +1250,9 @@ M.Parameter -> rPutStrLn "// No documentation is available." + showModHelp _env disp x = + rPrint $ runDoc disp $ vcat [ "`" <> pp x <> "` is a module." ] + -- XXX: show doc. if any showTypeHelp params env nameEnv name = fromMaybe (noInfo nameEnv name) $ @@ -1463,9 +1282,9 @@ ns = T.addTNames vs emptyNameMap rs = [ "•" <+> ppWithNames ns c | c <- cs ] rPutStrLn "" - rPrint $ runDoc nameEnv $ nest 4 $ + rPrint $ runDoc nameEnv $ indent 4 $ backticks (ppWithNames ns example) <+> - "requires:" $$ nest 2 (vcat rs) + "requires:" $$ indent 2 (vcat rs) doShowFix (T.atFixitiy a) doShowDocString (T.atDoc a) @@ -1475,12 +1294,13 @@ let uses c = T.TVBound (T.mtpParam p) `Set.member` T.fvs c ctrs = filter uses (map P.thing (M.ifParamConstraints params)) ctrDoc = case ctrs of - [] -> empty - [x] -> pp x - xs -> parens $ hsep $ punctuate comma $ map pp xs - decl = text "parameter" <+> pp name <+> text ":" - <+> pp (T.mtpKind p) - $$ ctrDoc + [] -> [] + [x] -> [pp x] + xs -> [parens $ commaSep $ map pp xs] + decl = vcat $ + [ text "parameter" <+> pp name <+> text ":" + <+> pp (T.mtpKind p) ] + ++ ctrDoc return $ doShowTyHelp nameEnv decl (T.mtpDoc p) doShowTyHelp nameEnv decl doc = @@ -1510,16 +1330,15 @@ return $ do rPutStrLn "" - let property - | P.PragmaProperty `elem` ifDeclPragmas = text "property" - | otherwise = empty + let property + | P.PragmaProperty `elem` ifDeclPragmas = [text "property"] + | otherwise = [] rPrint $ runDoc nameEnv - $ nest 4 - $ property - <+> pp qname - <+> colon - <+> pp (ifDeclSig) + $ indent 4 + $ hsep + $ property ++ [pp qname, colon, pp (ifDeclSig)] + doShowFix $ ifDeclFixity `mplus` (guard ifDeclInfix >> return P.defaultFixity) @@ -1534,7 +1353,7 @@ return $ do rPutStrLn "" rPrint $ runDoc nameEnv - $ nest 4 + $ indent 4 $ text "parameter" <+> pp qname <+> colon <+> pp (T.mvpType p) @@ -1591,18 +1410,11 @@ -- XXX this should probably do something a bit more specific. handleCtrlC :: a -> REPL a handleCtrlC a = do rPutStrLn "Ctrl-C" + resetTCSolver return a - -- Utilities ------------------------------------------------------------------- -hasAnyModName :: [M.ModName] -> M.Name -> Bool -hasAnyModName mnames n = - case M.nameInfo n of - M.Declared m _ -> m `elem` mnames - M.Parameter -> False - - -- | Lift a parsing action into the REPL monad. replParse :: (String -> Either ParseError a) -> String -> REPL a replParse parse str = case parse str of @@ -1648,16 +1460,16 @@ do evo <- getEvalOptsAction env <- getModuleEnv callStacks <- getCallStacks - let cfg = M.meSolverConfig env - let minp s = + tcSolver <- getTCSolver + let minp = M.ModuleInput { minpCallStacks = callStacks , minpEvalOpts = evo , minpByteReader = BS.readFile , minpModuleEnv = env - , minpTCSolver = s + , minpTCSolver = tcSolver } - moduleCmdResult =<< io (SMT.withSolver cfg (cmd . minp)) + moduleCmdResult =<< io (cmd minp) moduleCmdResult :: M.ModuleRes a -> REPL a moduleCmdResult (res,ws0) = do @@ -1714,12 +1526,13 @@ let mkTop d = P.Decl P.TopLevel { P.tlExport = P.Public , P.tlDoc = Nothing , P.tlValue = d } - (names,ds') <- liftModuleCmd (M.checkDecls (map mkTop npds)) + (names,ds',tyMap) <- liftModuleCmd (M.checkDecls (map mkTop npds)) - -- extend the naming env + -- extend the naming env and type synonym maps denv <- getDynEnv - setDynEnv denv { M.deNames = names `M.shadowing` M.deNames denv } - + setDynEnv denv { M.deNames = names `M.shadowing` M.deNames denv + , M.deTySyns = tyMap <> M.deTySyns denv + } return ds' replSpecExpr :: T.Expr -> REPL T.Expr @@ -1735,9 +1548,8 @@ do validEvalContext def validEvalContext sig - me <- getModuleEnv - let cfg = M.meSolverConfig me - mbDef <- io $ SMT.withSolver cfg (\s -> defaultReplExpr s def sig) + s <- getTCSolver + mbDef <- io (defaultReplExpr s def sig) (def1,ty) <- case mbDef of @@ -1834,9 +1646,9 @@ seqTy = E.TVSeq (toInteger len) ty seqExpr = T.EList exprs (E.tValTy ty) -replEvalDecl :: P.Decl P.PName -> REPL () -replEvalDecl decl = do - dgs <- replCheckDecls [decl] +replEvalDecls :: [P.Decl P.PName] -> REPL () +replEvalDecls ds = do + dgs <- replCheckDecls ds validEvalContext dgs whenDebug (mapM_ (\dg -> (rPutStrLn (dump dg))) dgs) liftModuleCmd (M.evalDecls dgs) 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 @@ -6,6 +6,7 @@ -- Stability : provisional -- Portability : portable +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -36,6 +37,8 @@ , getModuleEnv, setModuleEnv , getDynEnv, setDynEnv , getCallStacks + , getTCSolver + , resetTCSolver , uniqify, freshName , whenDebug , getEvalOptsAction @@ -65,7 +68,9 @@ , getUserShowProverStats , getUserProverValidate , parsePPFloatFormat + , parseFieldOrder , getProverConfig + , parseSearchPath -- ** Configurable Output , getPutStr @@ -91,6 +96,7 @@ import Cryptol.Parser.Position (emptyRange, Range(from)) import qualified Cryptol.TypeCheck.AST as T import qualified Cryptol.TypeCheck as T +import qualified Cryptol.TypeCheck.Solver.SMT as SMT import qualified Cryptol.IR.FreeVars as T import qualified Cryptol.Utils.Ident as I import Cryptol.Utils.PP @@ -103,6 +109,8 @@ import qualified Cryptol.Symbolic.SBV as SBV (proverNames, setupProver, defaultProver, SBVProverConfig) import qualified Cryptol.Symbolic.What4 as W4 (proverNames, setupProver, W4ProverConfig) + + import Control.Monad (ap,unless,when) import Control.Monad.Base import qualified Control.Monad.Catch as Ex @@ -110,12 +118,13 @@ import Control.Monad.Trans.Control import Data.Char (isSpace, toLower) import Data.IORef - (IORef,newIORef,readIORef,modifyIORef,atomicModifyIORef) + (IORef,newIORef,readIORef,atomicModifyIORef) import Data.List (intercalate, isPrefixOf, unfoldr, sortBy) import Data.Maybe (catMaybes) import Data.Ord (comparing) import Data.Typeable (Typeable) import System.Directory (findExecutable) +import System.FilePath (splitSearchPath, searchPathSeparator) import qualified Control.Exception as X import qualified Data.Map as Map import qualified Data.Set as Set @@ -165,12 +174,27 @@ -- This is used to change the title of terminal when loading a module. , eProverConfig :: Either SBV.SBVProverConfig W4.W4ProverConfig + + , eTCConfig :: T.SolverConfig + -- ^ Solver configuration to be used for typechecking + + , eTCSolver :: Maybe SMT.Solver + -- ^ Solver instance to be used for typechecking + + , eTCSolverRestarts :: !Int + -- ^ Counts how many times we've restarted the solver. + -- Used as a kind of id for the current solver, which helps avoid + -- a race condition where the callback of a dead solver runs after + -- a new one has been started. } + -- | Initial, empty environment. -defaultRW :: Bool -> Bool ->Logger -> IO RW +defaultRW :: Bool -> Bool -> Logger -> IO RW defaultRW isBatch callStacks l = do env <- M.initialModuleEnv + let searchPath = M.meSearchPath env + let solverConfig = T.defaultSolverConfig searchPath return RW { eLoadedMod = Nothing , eEditFile = Nothing @@ -182,6 +206,9 @@ , eCallStacks = callStacks , eUpdateTitle = return () , eProverConfig = Left SBV.defaultProver + , eTCConfig = solverConfig + , eTCSolver = Nothing + , eTCSolverRestarts = 0 } -- | Build up the prompt for the REPL. @@ -228,8 +255,10 @@ -- | Run a REPL action with a fresh environment. runREPL :: Bool -> Bool -> Logger -> REPL a -> IO a runREPL isBatch callStacks l m = do - ref <- newIORef =<< defaultRW isBatch callStacks l - unREPL m ref + Ex.bracket + (newIORef =<< defaultRW isBatch callStacks l) + (unREPL resetTCSolver) + (unREPL m) instance Functor REPL where {-# INLINE fmap #-} @@ -331,9 +360,9 @@ $$ text "Type:" <+> pp s TypeNotTestable t -> text "The expression is not of a testable type." $$ text "Type:" <+> pp t - EvalInParamModule xs -> - text "Expression depends on definitions from a parameterized module:" - $$ nest 2 (vcat (map pp xs)) + EvalInParamModule xs -> nest 2 $ vsep $ + [ text "Expression depends on definitions from a parameterized module:" ] + ++ map pp xs SBVError s -> text "SBV error:" $$ text s SBVException e -> text "SBV exception:" $$ text (show e) SBVPortfolioException e -> text "SBV exception:" $$ text (show e) @@ -384,7 +413,7 @@ modifyRW f = REPL (\ ref -> atomicModifyIORef ref f) modifyRW_ :: (RW -> RW) -> REPL () -modifyRW_ f = REPL (\ ref -> modifyIORef ref f) +modifyRW_ f = REPL (\ ref -> atomicModifyIORef ref (\x -> (f x, ()))) -- | Construct the prompt for the current environment. getPrompt :: REPL String @@ -393,25 +422,56 @@ getCallStacks :: REPL Bool getCallStacks = eCallStacks <$> getRW +-- This assumes that we are not starting solvers in parallel, otherwise +-- there are a bunch of race conditions here. +getTCSolver :: REPL SMT.Solver +getTCSolver = + do rw <- getRW + case eTCSolver rw of + Just s -> return s + Nothing -> + do ref <- REPL (\ref -> pure ref) + let now = eTCSolverRestarts rw + 1 + upd new = if eTCSolverRestarts new == now + then new { eTCSolver = Nothing } + else new + onExit = atomicModifyIORef ref (\s -> (upd s, ())) + s <- io (SMT.startSolver onExit (eTCConfig rw)) + modifyRW_ (\rw' -> rw'{ eTCSolver = Just s + , eTCSolverRestarts = now }) + return s + + +resetTCSolver :: REPL () +resetTCSolver = + do mtc <- eTCSolver <$> getRW + case mtc of + Nothing -> return () + Just s -> + do io (SMT.stopSolver s) + modifyRW_ (\rw -> rw{ eTCSolver = Nothing }) + -- Get the setting we should use for displaying values. getPPValOpts :: REPL PPOpts getPPValOpts = - do base <- getKnownUser "base" - ascii <- getKnownUser "ascii" - infLength <- getKnownUser "infLength" + do base <- getKnownUser "base" + ascii <- getKnownUser "ascii" + infLength <- getKnownUser "infLength" - fpBase <- getKnownUser "fpBase" - fpFmtTxt <- getKnownUser "fpFormat" + fpBase <- getKnownUser "fpBase" + fpFmtTxt <- getKnownUser "fpFormat" + fieldOrder <- getKnownUser "fieldOrder" let fpFmt = case parsePPFloatFormat fpFmtTxt of Just f -> f Nothing -> panic "getPPOpts" [ "Failed to parse fp-format" ] - return PPOpts { useBase = base - , useAscii = ascii - , useInfLength = infLength - , useFPBase = fpBase - , useFPFormat = fpFmt + return PPOpts { useBase = base + , useAscii = ascii + , useInfLength = infLength + , useFPBase = fpBase + , useFPFormat = fpFmt + , useFieldOrder = fieldOrder } getEvalOptsAction :: REPL (IO EvalOpts) @@ -451,11 +511,14 @@ setSearchPath path = do me <- getModuleEnv setModuleEnv $ me { M.meSearchPath = path } + setUserDirect "path" (EnvString (renderSearchPath path)) prependSearchPath :: [FilePath] -> REPL () prependSearchPath path = do me <- getModuleEnv - setModuleEnv $ me { M.meSearchPath = path ++ M.meSearchPath me } + let path' = path ++ M.meSearchPath me + setModuleEnv $ me { M.meSearchPath = path' } + setUserDirect "path" (EnvString (renderSearchPath path')) getProverConfig :: REPL (Either SBV.SBVProverConfig W4.W4ProverConfig) getProverConfig = eProverConfig <$> getRW @@ -492,7 +555,7 @@ badName nm bs = case M.nameInfo nm of - M.Declared m _ + M.Declared (M.TopModule m) _ -- XXX: can we focus nested modules? | M.isLoadedParamMod m (M.meLoadedModules me) -> Set.insert nm bs _ -> bs @@ -547,14 +610,14 @@ getExprNames :: REPL [String] getExprNames = do fNames <- M.mctxNames <$> getFocusedEnv - return (map (show . pp) (Map.keys (M.neExprs fNames))) + return (map (show . pp) (Map.keys (M.namespaceMap M.NSValue fNames))) -- | Get visible type signature names. -- This is used for command line completition. getTypeNames :: REPL [String] getTypeNames = do fNames <- M.mctxNames <$> getFocusedEnv - return (map (show . pp) (Map.keys (M.neTypes fNames))) + return (map (show . pp) (Map.keys (M.namespaceMap M.NSType fNames))) -- | Return a list of property names, sorted by position in the file. getPropertyNames :: REPL ([(M.Name,M.IfaceDecl)],NameDisp) @@ -595,7 +658,8 @@ uniqify name = case M.nameInfo name of M.Declared ns s -> - M.liftSupply (M.mkDeclared ns s (M.nameIdent name) (M.nameFixity name) (M.nameLoc name)) + M.liftSupply (M.mkDeclared (M.nameNamespace name) + ns s (M.nameIdent name) (M.nameFixity name) (M.nameLoc name)) M.Parameter -> panic "[REPL] uniqify" ["tried to uniqify a parameter: " ++ pretty name] @@ -615,9 +679,28 @@ -- the "" namespace. freshName :: I.Ident -> M.NameSource -> REPL M.Name freshName i sys = - M.liftSupply (M.mkDeclared I.interactiveName sys i Nothing emptyRange) + M.liftSupply (M.mkDeclared I.NSValue mpath sys i Nothing emptyRange) + where mpath = M.TopModule I.interactiveName +parseSearchPath :: String -> [String] +parseSearchPath path = path' +#if defined(mingw32_HOST_OS) || defined(__MINGW32__) + -- Windows paths search from end to beginning + where path' = reverse (splitSearchPath path) +#else + where path' = splitSearchPath path +#endif + +renderSearchPath :: [String] -> String +renderSearchPath pathSegs = path +#if defined(mingw32_HOST_OS) || defined(__MINGW32__) + -- Windows paths search from end to beginning + where path = intercalate [searchPathSeparator] (reverse pathSegs) +#else + where path = intercalate [searchPathSeparator] pathSegs +#endif + -- User Environment Interaction ------------------------------------------------ -- | User modifiable environment, for things like numeric base. @@ -710,6 +793,10 @@ Just ev -> return ev Nothing -> panic "[REPL] getUser" ["option `" ++ name ++ "` does not exist"] +setUserDirect :: String -> EnvVal -> REPL () +setUserDirect optName val = do + modifyRW_ (\rw -> rw { eUserEnv = Map.insert optName val (eUserEnv rw) }) + getKnownUser :: IsEnvVal a => String -> REPL a getKnownUser x = fromEnvVal <$> getUser x @@ -736,6 +823,12 @@ EnvString b -> b _ -> badIsEnv "String" +instance IsEnvVal FieldOrder where + fromEnvVal x = case x of + EnvString s | Just o <- parseFieldOrder s + -> o + _ -> badIsEnv "display` or `canonical" + badIsEnv :: String -> a badIsEnv x = panic "fromEnvVal" [ "[REPL] Expected a `" ++ x ++ "` value." ] @@ -806,6 +899,14 @@ "Choose whether to issue a warning when uninterpreted functions are used to implement primitives in the symbolic simulator." , simpleOpt "smtFile" ["smt-file"] (EnvString "-") noCheck "The file to use for SMT-Lib scripts (for debugging or offline proving).\nUse \"-\" for stdout." + , OptionDescr "path" [] (EnvString "") noCheck + "The search path for finding named Cryptol modules." $ + \case EnvString path -> + do let segs = parseSearchPath path + me <- getModuleEnv + setModuleEnv me { M.meSearchPath = segs } + _ -> return () + , OptionDescr "monoBinds" ["mono-binds"] (EnvBool True) noCheck "Whether or not to generalize bindings in a 'where' clause." $ \case EnvBool b -> do me <- getModuleEnv @@ -815,11 +916,11 @@ , OptionDescr "tcSolver" ["tc-solver"] (EnvProg "z3" [ "-smt2", "-in" ]) noCheck -- TODO: check for the program in the path "The solver that will be used by the type checker." $ - \case EnvProg prog args -> do me <- getModuleEnv - let cfg = M.meSolverConfig me - setModuleEnv me { M.meSolverConfig = - cfg { T.solverPath = prog - , T.solverArgs = args } } + \case EnvProg prog args -> do modifyRW_ (\rw -> rw { eTCConfig = (eTCConfig rw) + { T.solverPath = prog + , T.solverArgs = args + }}) + resetTCSolver _ -> return () , OptionDescr "tcDebug" ["tc-debug"] (EnvNum 0) @@ -829,9 +930,10 @@ , " * 0 no debug output" , " * 1 show type-checker debug info" , " * >1 show type-checker debug info and interactions with SMT solver"]) $ - \case EnvNum n -> do me <- getModuleEnv - let cfg = M.meSolverConfig me - setModuleEnv me { M.meSolverConfig = cfg{ T.solverVerbose = n } } + \case EnvNum n -> do changed <- modifyRW (\rw -> ( rw{ eTCConfig = (eTCConfig rw){ T.solverVerbose = n } } + , n /= T.solverVerbose (eTCConfig rw) + )) + when changed resetTCSolver _ -> return () , OptionDescr "coreLint" ["core-lint"] (EnvBool False) noCheck @@ -869,6 +971,13 @@ , simpleOpt "ignoreSafety" ["ignore-safety"] (EnvBool False) noCheck "Ignore safety predicates when performing :sat or :prove checks" + + , simpleOpt "fieldOrder" ["field-order"] (EnvString "display") checkFieldOrder + $ unlines + [ "The order that record fields are displayed in." + , " * display try to match the order they were written in the source code" + , " * canonical use a predictable, canonical order" + ] ] @@ -893,7 +1002,16 @@ EnvString s | Just _ <- parsePPFloatFormat s -> noWarns Nothing _ -> noWarns $ Just "Failed to parse `fp-format`" +parseFieldOrder :: String -> Maybe FieldOrder +parseFieldOrder "canonical" = Just CanonicalOrder +parseFieldOrder "display" = Just DisplayOrder +parseFieldOrder _ = Nothing +checkFieldOrder :: Checker +checkFieldOrder val = + case val of + EnvString s | Just _ <- parseFieldOrder s -> noWarns Nothing + _ -> noWarns $ Just "Failed to parse field-order (expected one of \"canonical\" or \"display\")" -- | Check the value to the `base` option. checkBase :: Checker diff --git a/src/Cryptol/Symbolic.hs b/src/Cryptol/Symbolic.hs --- a/src/Cryptol/Symbolic.hs +++ b/src/Cryptol/Symbolic.hs @@ -38,6 +38,8 @@ , modelPred , varModelPred , varToExpr + , flattenShape + , flattenShapes ) where @@ -50,6 +52,8 @@ import Cryptol.Backend import Cryptol.Backend.FloatHelpers(bfValue) +import Cryptol.Backend.SeqMap (finiteSeqMap) +import Cryptol.Backend.WordValue (wordVal) import qualified Cryptol.Eval.Concrete as Concrete import Cryptol.Eval.Value @@ -211,24 +215,42 @@ ppVarShape _sym (VarRational _n _d) = text "" ppVarShape sym (VarWord w) = text " integer (wordLen sym w) <> text ">" ppVarShape sym (VarFinSeq _ xs) = - brackets (fsep (punctuate comma (map (ppVarShape sym) xs))) + ppList (map (ppVarShape sym) xs) ppVarShape sym (VarTuple xs) = - parens (sep (punctuate comma (map (ppVarShape sym) xs))) + ppTuple (map (ppVarShape sym) xs) ppVarShape sym (VarRecord fs) = - braces (sep (punctuate comma (map ppField (displayFields fs)))) + ppRecord (map ppField (displayFields fs)) where ppField (f,v) = pp f <+> char '=' <+> ppVarShape sym v +-- | Flatten structured shapes (like tuples and sequences), leaving only +-- a sequence of variable shapes of base type. +flattenShapes :: [VarShape sym] -> [VarShape sym] -> [VarShape sym] +flattenShapes [] tl = tl +flattenShapes (x:xs) tl = flattenShape x (flattenShapes xs tl) + +flattenShape :: VarShape sym -> [VarShape sym] -> [VarShape sym] +flattenShape x tl = + case x of + VarBit{} -> x : tl + VarInteger{} -> x : tl + VarRational{} -> x : tl + VarWord{} -> x : tl + VarFloat{} -> x : tl + VarFinSeq _ vs -> flattenShapes vs tl + VarTuple vs -> flattenShapes vs tl + VarRecord fs -> flattenShapes (recordElements fs) tl + varShapeToValue :: Backend sym => sym -> VarShape sym -> GenValue sym varShapeToValue sym var = case var of VarBit b -> VBit b VarInteger i -> VInteger i VarRational n d -> VRational (SRational n d) - VarWord w -> VWord (wordLen sym w) (return (WordVal w)) + VarWord w -> VWord (wordLen sym w) (wordVal w) VarFloat f -> VFloat f - VarFinSeq n vs -> VSeq n (finiteSeqMap (map (pure . varShapeToValue sym) vs)) + VarFinSeq n vs -> VSeq n (finiteSeqMap sym (map (pure . varShapeToValue sym) vs)) VarTuple vs -> VTuple (map (pure . varShapeToValue sym) vs) VarRecord fs -> VRecord (fmap (pure . varShapeToValue sym) fs) 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 @@ -8,8 +8,10 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ParallelListComp #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} @@ -33,13 +35,14 @@ import Control.Concurrent.Async import Control.Concurrent.MVar import Control.Monad.IO.Class -import Control.Monad (when, foldM, forM_) +import Control.Monad (when, foldM, forM_, void) import qualified Control.Exception as X import System.IO (Handle) import Data.Time import Data.IORef -import Data.List (intercalate) +import Data.List (intercalate, tails, inits) import Data.List.NonEmpty (NonEmpty(..)) +import Data.Proxy import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set @@ -60,7 +63,9 @@ import qualified Cryptol.Eval as Eval import qualified Cryptol.Eval.Concrete as Concrete import qualified Cryptol.Eval.Value as Eval +import Cryptol.Eval.Type (TValue) import Cryptol.Eval.What4 + import Cryptol.Parser.Position (emptyRange) import Cryptol.Symbolic import Cryptol.TypeCheck.AST @@ -75,7 +80,15 @@ import qualified What4.SFloat as W4 import qualified What4.SWord as SW import What4.Solver +import qualified What4.Solver.Boolector as W4 +import qualified What4.Solver.CVC4 as W4 +import qualified What4.Solver.ExternalABC as W4 +import qualified What4.Solver.Yices as W4 +import qualified What4.Solver.Z3 as W4 import qualified What4.Solver.Adapter as W4 +import qualified What4.Protocol.Online as W4 +import qualified What4.Protocol.SMTLib2 as W4 +import qualified What4.ProblemFeatures as W4 import qualified Data.BitVector.Sized as BV import Data.Parameterized.Nonce @@ -130,32 +143,64 @@ W4Result p x -> pure (p,x) -data AnAdapter = AnAdapter (forall st. SolverAdapter st) +data AnAdapter + = AnAdapter (forall st. SolverAdapter st) + | forall s. W4.OnlineSolver s => + AnOnlineAdapter + String + W4.ProblemFeatures + [W4.ConfigDesc] + (Proxy s) data W4ProverConfig = W4ProverConfig AnAdapter + | W4OfflineConfig | W4Portfolio (NonEmpty AnAdapter) proverConfigs :: [(String, W4ProverConfig)] proverConfigs = - [ ("w4-cvc4" , W4ProverConfig (AnAdapter cvc4Adapter) ) - , ("w4-yices" , W4ProverConfig (AnAdapter yicesAdapter) ) - , ("w4-z3" , W4ProverConfig (AnAdapter z3Adapter) ) - , ("w4-boolector", W4ProverConfig (AnAdapter boolectorAdapter) ) - , ("w4-offline" , W4ProverConfig (AnAdapter z3Adapter) ) - , ("w4-any" , allSolvers) + [ ("w4-cvc4" , W4ProverConfig cvc4OnlineAdapter) + , ("w4-yices" , W4ProverConfig yicesOnlineAdapter) + , ("w4-z3" , W4ProverConfig z3OnlineAdapter) + , ("w4-boolector" , W4ProverConfig boolectorOnlineAdapter) + + , ("w4-abc" , W4ProverConfig (AnAdapter W4.externalABCAdapter)) + + , ("w4-offline" , W4OfflineConfig ) + , ("w4-any" , allSolvers) ] +z3OnlineAdapter :: AnAdapter +z3OnlineAdapter = + AnOnlineAdapter "Z3" W4.z3Features W4.z3Options + (Proxy :: Proxy (W4.Writer W4.Z3)) + +yicesOnlineAdapter :: AnAdapter +yicesOnlineAdapter = + AnOnlineAdapter "Yices" W4.yicesDefaultFeatures W4.yicesOptions + (Proxy :: Proxy W4.Connection) + +cvc4OnlineAdapter :: AnAdapter +cvc4OnlineAdapter = + AnOnlineAdapter "CVC4" W4.cvc4Features W4.cvc4Options + (Proxy :: Proxy (W4.Writer W4.CVC4)) + +boolectorOnlineAdapter :: AnAdapter +boolectorOnlineAdapter = + AnOnlineAdapter "Boolector" W4.boolectorFeatures W4.boolectorOptions + (Proxy :: Proxy (W4.Writer W4.Boolector)) + allSolvers :: W4ProverConfig allSolvers = W4Portfolio - $ AnAdapter z3Adapter :| - [ AnAdapter cvc4Adapter - , AnAdapter boolectorAdapter - , AnAdapter yicesAdapter + $ z3OnlineAdapter :| + [ cvc4OnlineAdapter + , boolectorOnlineAdapter + , yicesOnlineAdapter + , AnAdapter W4.externalABCAdapter ] defaultProver :: W4ProverConfig -defaultProver = W4ProverConfig (AnAdapter z3Adapter) +defaultProver = W4ProverConfig z3OnlineAdapter proverNames :: [String] proverNames = map fst proverConfigs @@ -178,12 +223,16 @@ let msg = "What4 found the following solvers: " ++ show (adapterNames (p:ps')) in pure (Right ([msg], W4Portfolio (p:|ps'))) + Just W4OfflineConfig -> pure (Right ([], W4OfflineConfig)) + Nothing -> pure (Left ("unknown solver name: " ++ nm)) where adapterNames [] = [] adapterNames (AnAdapter adpt : ps) = solver_adapter_name adpt : adapterNames ps + adapterNames (AnOnlineAdapter n _ _ _ : ps) = + n : adapterNames ps filterAdapters [] = pure [] filterAdapters (p:ps) = @@ -191,12 +240,25 @@ Just _err -> filterAdapters ps Nothing -> (p:) <$> filterAdapters ps + tryAdapter :: AnAdapter -> IO (Maybe X.SomeException) + tryAdapter (AnAdapter adpt) = do sym <- W4.newExprBuilder W4.FloatIEEERepr CryptolState globalNonceGenerator W4.extendConfig (W4.solver_adapter_config_options adpt) (W4.getConfiguration sym) W4.smokeTest sym adpt - + tryAdapter (AnOnlineAdapter _ fs opts (_ :: Proxy s)) = test `X.catch` (pure . Just) + where + test = + do sym <- W4.newExprBuilder W4.FloatIEEERepr CryptolState globalNonceGenerator + W4.extendConfig opts (W4.getConfiguration sym) + (proc :: W4.SolverProcess GlobalNonceGenerator s) <- W4.startSolverProcess fs Nothing sym + res <- W4.checkSatisfiable proc "smoke test" (W4.falsePred sym) + case res of + W4.Unsat () -> return () + _ -> fail "smoke test failed, expected UNSAT!" + void (W4.shutdownSolverProcess proc) + return Nothing proverError :: String -> M.ModuleCmd (Maybe String, ProverResult) proverError msg minp = @@ -211,11 +273,13 @@ case cfg of W4ProverConfig p -> setupAnAdapter p W4Portfolio ps -> mapM_ setupAnAdapter ps + W4OfflineConfig -> return () where setupAnAdapter (AnAdapter adpt) = W4.extendConfig (W4.solver_adapter_config_options adpt) (W4.getConfiguration sym) - + setupAnAdapter (AnOnlineAdapter _n _fs opts _p) = + W4.extendConfig opts (W4.getConfiguration sym) what4FreshFns :: W4.IsSymExprBuilder sym => sym -> FreshVarFns (What4 sym) what4FreshFns sym = @@ -350,16 +414,13 @@ Right (ts,args,safety,query) -> case pcQueryType of ProveQuery -> - singleQuery sym solverCfg primMap logData ts args - (Just safety) query + singleQuery sym solverCfg primMap logData ts args (Just safety) query SafetyQuery -> - singleQuery sym solverCfg primMap logData ts args - (Just safety) query + singleQuery sym solverCfg primMap logData ts args (Just safety) query SatQuery num -> - multiSATQuery sym solverCfg primMap logData ts args - query num + multiSATQuery sym solverCfg primMap logData ts args query num printUninterpWarn :: Logger -> Set Text -> IO () printUninterpWarn lg uninterpWarns = @@ -371,17 +432,14 @@ , " " ++ intercalate ", " (map Text.unpack xs) ] satProveOffline :: - W4ProverConfig -> Bool {- ^ hash consing -} -> Bool {- ^ warn on uninterpreted functions -} -> ProverCommand -> ((Handle -> IO ()) -> IO ()) -> M.ModuleCmd (Maybe String) -satProveOffline (W4Portfolio (p:|_)) hashConsing warnUninterp cmd outputContinuation = - satProveOffline (W4ProverConfig p) hashConsing warnUninterp cmd outputContinuation +satProveOffline hashConsing warnUninterp ProverCommand{ .. } outputContinuation = -satProveOffline (W4ProverConfig (AnAdapter adpt)) hashConsing warnUninterp ProverCommand {..} outputContinuation = protectStack onError \modIn -> M.runModuleM modIn do w4sym <- liftIO makeSym @@ -396,27 +454,26 @@ case ok of Left msg -> return (Just msg) Right (_ts,_args,_safety,query) -> - do outputContinuation - (\hdl -> solver_adapter_write_smt2 adpt w4sym hdl [query]) + do outputContinuation (\hdl -> W4.writeZ3SMT2File w4sym hdl [query]) return Nothing where makeSym = - do sym <- W4.newExprBuilder W4.FloatIEEERepr CryptolState - globalNonceGenerator - W4.extendConfig (W4.solver_adapter_config_options adpt) - (W4.getConfiguration sym) + do sym <- W4.newExprBuilder W4.FloatIEEERepr CryptolState globalNonceGenerator + W4.extendConfig W4.z3Options (W4.getConfiguration sym) when hashConsing (W4.startCaching sym) pure sym onError msg minp = pure (Right (Just msg, M.minpModuleEnv minp), []) +{- decSatNum :: SatNum -> SatNum decSatNum (SomeSat n) | n > 0 = SomeSat (n-1) decSatNum n = n +-} -multiSATQuery :: +multiSATQuery :: forall sym t fm. sym ~ W4.ExprBuilder t CryptolState fm => What4 sym -> W4ProverConfig -> @@ -427,58 +484,145 @@ W4.Pred sym -> SatNum -> IO (Maybe String, ProverResult) + multiSATQuery sym solverCfg primMap logData ts args query (SomeSat n) | n <= 1 = singleQuery sym solverCfg primMap logData ts args Nothing query +multiSATQuery _sym W4OfflineConfig _primMap _logData _ts _args _query _satNum = + fail "What4 offline solver cannot be used for multi-SAT queries" + multiSATQuery _sym (W4Portfolio _) _primMap _logData _ts _args _query _satNum = - fail "What4 portfolio solver cannot be used for multi SAT queries" + fail "What4 portfolio solver cannot be used for multi-SAT queries" -multiSATQuery sym (W4ProverConfig (AnAdapter adpt)) primMap logData ts args query satNum0 = - do pres <- W4.solver_adapter_check_sat adpt (w4 sym) logData [query] $ \res -> - case res of - W4.Unknown -> return (Left (ProverError "Solver returned UNKNOWN")) - W4.Unsat _ -> return (Left (ThmResult (map unFinType ts))) - W4.Sat (evalFn,_) -> - do xs <- mapM (varShapeToConcrete evalFn) args - let model = computeModel primMap ts xs - blockingPred <- computeBlockingPred sym args xs - return (Right (model, blockingPred)) +multiSATQuery _sym (W4ProverConfig (AnAdapter adpt)) _primMap _logData _ts _args _query _satNum = + fail ("Solver " ++ solver_adapter_name adpt ++ " does not support incremental solving and " ++ + "cannot be used for multi-SAT queries.") - case pres of - Left res -> pure (Just (solver_adapter_name adpt), res) - Right (mdl,block) -> - do mdls <- (mdl:) <$> computeMoreModels [block,query] (decSatNum satNum0) - return (Just (solver_adapter_name adpt), AllSatResult mdls) +multiSATQuery sym (W4ProverConfig (AnOnlineAdapter nm fs _opts (_ :: Proxy s))) + primMap _logData ts args query satNum0 = + X.bracket + (W4.startSolverProcess fs Nothing (w4 sym)) + (void . W4.shutdownSolverProcess) + (\ (proc :: W4.SolverProcess t s) -> + 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.Unsat _ -> return (Just nm, ThmResult (map unFinType ts)) + W4.Sat evalFn -> + do xs <- mapM (varShapeToConcrete evalFn) args + let mdl = computeModel primMap ts xs + -- NB, we flatten these shapes to make sure that we can split + -- our search across all of the atomic variables + let vs = flattenShapes args [] + let cs = flattenShapes xs [] + mdls <- runMultiSat satNum0 $ + do yield mdl + computeMoreModels proc vs cs + return (Just nm, AllSatResult mdls)) where + -- This search procedure uses incremental solving and push/pop to split on the concrete + -- values of variables, while also helping to prevent the accumulation of unhelpful + -- lemmas in the solver state. This algorithm is basically taken from: + -- http://theory.stanford.edu/%7Enikolaj/programmingz3.html#sec-blocking-evaluations + computeMoreModels :: + W4.SolverProcess t s -> + [VarShape (What4 sym)] -> + [VarShape Concrete.Concrete] -> + MultiSat () + computeMoreModels proc vs cs = + -- Enumerate all the ways to split up the current model + forM_ (computeSplits vs cs) $ \ (prefix, vi, ci, suffix) -> + do -- open a new solver frame + liftIO $ W4.push proc + -- force the selected pair to be different + liftIO $ W4.assume (W4.solverConn proc) =<< W4.notPred (w4 sym) =<< computeModelPred sym vi ci + -- force the prefix values to be the same + liftIO $ forM_ prefix $ \(v,c) -> + W4.assume (W4.solverConn proc) =<< computeModelPred sym v c + -- under these assumptions, find all the remaining models + findMoreModels proc (vi:suffix) + -- pop the current assumption frame + liftIO $ W4.pop proc - computeMoreModels _qs (SomeSat n) | n <= 0 = return [] -- should never happen... - computeMoreModels qs (SomeSat n) | n <= 1 = -- final model - W4.solver_adapter_check_sat adpt (w4 sym) logData qs $ \res -> - case res of - W4.Unknown -> return [] - W4.Unsat _ -> return [] - W4.Sat (evalFn,_) -> - do xs <- mapM (varShapeToConcrete evalFn) args - let model = computeModel primMap ts xs - return [model] + findMoreModels :: + W4.SolverProcess t s -> + [VarShape (What4 sym)] -> + MultiSat () + findMoreModels proc vs = + -- see if our current assumptions are consistent + do res <- liftIO (W4.checkAndGetModel proc "find model") + case res of + -- if the solver gets stuck, drop all the way out and stop search + W4.Unknown -> done + -- if our assumptions are already unsatisfiable, stop search and return + W4.Unsat _ -> return () + W4.Sat evalFn -> + -- We found a model. Record it and then use it to split the remaining + -- search variables some more. + do xs <- liftIO (mapM (varShapeToConcrete evalFn) args) + yield (computeModel primMap ts xs) + cs <- liftIO (mapM (varShapeToConcrete evalFn) vs) + computeMoreModels proc vs cs - computeMoreModels qs satNum = - do pres <- W4.solver_adapter_check_sat adpt (w4 sym) logData qs $ \res -> - case res of - W4.Unknown -> return Nothing - W4.Unsat _ -> return Nothing - W4.Sat (evalFn,_) -> - do xs <- mapM (varShapeToConcrete evalFn) args - let model = computeModel primMap ts xs - blockingPred <- computeBlockingPred sym args xs - return (Just (model, blockingPred)) +-- == Support operations for multi-SAT == +type Models = [[(TValue, Expr, Concrete.Value)]] - case pres of - Nothing -> return [] - Just (mdl, block) -> - (mdl:) <$> computeMoreModels (block:qs) (decSatNum satNum) +newtype MultiSat a = + MultiSat { unMultiSat :: Models -> SatNum -> (a -> Models -> SatNum -> IO Models) -> IO Models } +instance Functor MultiSat where + fmap f m = MultiSat (\ms satNum k -> unMultiSat m ms satNum (k . f)) + +instance Applicative MultiSat where + pure x = MultiSat (\ms satNum k -> k x ms satNum) + mf <*> mx = mf >>= \f -> fmap f mx + +instance Monad MultiSat where + m >>= f = MultiSat (\ms satNum k -> unMultiSat m ms satNum (\x ms' satNum' -> unMultiSat (f x) ms' satNum' k)) + +instance MonadIO MultiSat where + liftIO m = MultiSat (\ms satNum k -> do x <- m; k x ms satNum) + +runMultiSat :: SatNum -> MultiSat a -> IO Models +runMultiSat satNum m = reverse <$> unMultiSat m [] satNum (\_ ms _ -> return ms) + +done :: MultiSat a +done = MultiSat (\ms _satNum _k -> return ms) + +yield :: [(TValue, Expr, Concrete.Value)] -> MultiSat () +yield mdl = MultiSat (\ms satNum k -> + case satNum of + SomeSat n + | n > 1 -> k () (mdl:ms) (SomeSat (n-1)) + | otherwise -> return (mdl:ms) + _ -> k () (mdl:ms) satNum) + +-- Compute all the ways to split a sequences of variables +-- and concrete values for those variables. Each element +-- of the list consists of a prefix of (varaible,value) +-- pairs whose values we will fix, a single (varaible,value) +-- pair that we will force to be different, and a list of +-- additional unconstrained variables. +computeSplits :: + [VarShape (What4 sym)] -> + [VarShape Concrete.Concrete] -> + [ ( [(VarShape (What4 sym), VarShape Concrete.Concrete)] + , VarShape (What4 sym) + , VarShape Concrete.Concrete + , [VarShape (What4 sym)] + ) + ] +computeSplits vs cs = reverse + [ (prefix, v, c, tl) + | prefix <- inits (zip vs cs) + | v <- vs + | c <- cs + | tl <- tail (tails vs) + ] +-- == END Support operations for multi-SAT == + singleQuery :: sym ~ W4.ExprBuilder t CryptolState fm => What4 sym -> @@ -491,6 +635,10 @@ W4.Pred sym -> IO (Maybe String, ProverResult) +singleQuery _ W4OfflineConfig _primMap _logData _ts _args _msafe _query = + -- this shouldn't happen... + fail "What4 offline solver cannot be used for direct queries" + singleQuery sym (W4Portfolio ps) primMap logData ts args msafe query = do as <- mapM async [ singleQuery sym (W4ProverConfig p) primMap logData ts args msafe query | p <- NE.toList ps @@ -528,16 +676,37 @@ return (Just (W4.solver_adapter_name adpt), pres) +singleQuery sym (W4ProverConfig (AnOnlineAdapter nm fs _opts (_ :: Proxy s))) + primMap _logData ts args msafe query = + X.bracket + (W4.startSolverProcess fs Nothing (w4 sym)) + (void . W4.shutdownSolverProcess) + (\ (proc :: W4.SolverProcess t s) -> + 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.Unsat _ -> return (Just nm, ThmResult (map unFinType ts)) + W4.Sat evalFn -> + do xs <- mapM (varShapeToConcrete evalFn) args + let model = computeModel primMap ts xs + case msafe of + Just s -> + do s' <- W4.groundEval evalFn s + let cexType = if s' then PredicateFalsified else SafetyViolation + return (Just nm, CounterExample cexType model) + Nothing -> return (Just nm, AllSatResult [ model ]) + ) -computeBlockingPred :: + +computeModelPred :: sym ~ W4.ExprBuilder t CryptolState fm => What4 sym -> - [VarShape (What4 sym)] -> - [VarShape Concrete.Concrete] -> + VarShape (What4 sym) -> + VarShape Concrete.Concrete -> IO (W4.Pred sym) -computeBlockingPred sym vs xs = - do res <- doW4Eval (w4 sym) (modelPred sym vs xs) - W4.notPred (w4 sym) (snd res) +computeModelPred sym v c = + snd <$> doW4Eval (w4 sym) (varModelPred sym (v, c)) varShapeToConcrete :: W4.GroundEvalFn t -> diff --git a/src/Cryptol/Testing/Random.hs b/src/Cryptol/Testing/Random.hs --- a/src/Cryptol/Testing/Random.hs +++ b/src/Cryptol/Testing/Random.hs @@ -34,16 +34,18 @@ import Data.List (unfoldr, genericTake, genericIndex, genericReplicate) import qualified Data.Sequence as Seq -import System.Random (RandomGen, split, random, randomR) +import System.Random.TF.Gen +import System.Random.TF.Instances import Cryptol.Backend (Backend(..), SRational(..)) import Cryptol.Backend.FloatHelpers (floatFromBits) import Cryptol.Backend.Monad (runEval,Eval,EvalErrorEx(..)) import Cryptol.Backend.Concrete +import Cryptol.Backend.SeqMap (indexSeqMap, finiteSeqMap) +import Cryptol.Backend.WordValue (wordVal) import Cryptol.Eval.Type (TValue(..)) -import Cryptol.Eval.Value (GenValue(..),SeqMap(..), WordValue(..), - ppValue, defaultPPOpts, finiteSeqMap, fromVFun) +import Cryptol.Eval.Value (GenValue(..), ppValue, defaultPPOpts, fromVFun) import Cryptol.TypeCheck.Solver.InfNat (widthInteger) import Cryptol.Utils.Ident (Ident) import Cryptol.Utils.Panic (panic) @@ -212,7 +214,7 @@ randomWord :: (Backend sym, RandomGen g) => sym -> Integer -> Gen g sym randomWord sym w _sz g = let (val, g1) = randomR (0,2^w-1) g - in (return $ VWord w (WordVal <$> wordLit sym w val), g1) + in (VWord w . wordVal <$> wordLit sym w val, g1) {-# INLINE randomStream #-} @@ -220,7 +222,7 @@ randomStream :: (Backend sym, RandomGen g) => Gen g sym -> Gen g sym randomStream mkElem sz g = let (g1,g2) = split g - in (pure $ VStream $ IndexSeqMap $ genericIndex (unfoldr (Just . mkElem sz) g1), g2) + in (pure $ VStream $ indexSeqMap $ genericIndex (unfoldr (Just . mkElem sz) g1), g2) {-# INLINE randomSequence #-} @@ -232,7 +234,7 @@ let f g = let (x,g') = mkElem sz g in seq x (Just (x, g')) let xs = Seq.fromList $ genericTake w $ unfoldr f g1 - let v = VSeq w $ IndexSeqMap $ \i -> Seq.index xs (fromInteger i) + let v = VSeq w $ indexSeqMap $ \i -> Seq.index xs (fromInteger i) seq xs (pure v, g2) {-# INLINE randomTuple #-} @@ -401,11 +403,11 @@ TVArray{} -> [] TVStream{} -> [] TVSeq n TVBit -> - [ VWord n (pure (WordVal (BV n x))) + [ VWord n (wordVal (BV n x)) | x <- [ 0 .. 2^n - 1 ] ] TVSeq n el -> - [ VSeq n (finiteSeqMap (map pure xs)) + [ VSeq n (finiteSeqMap Concrete (map pure xs)) | xs <- sequence (genericReplicate n (typeValues el)) ] TVTuple ts -> 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 @@ -79,11 +79,11 @@ module Cryptol.Transform.MonoValues (rewModule) where import Cryptol.ModuleSystem.Name - (SupplyT,liftSupply,Supply,mkDeclared,NameSource(..)) + (SupplyT,liftSupply,Supply,mkDeclared,NameSource(..),ModPath(..)) import Cryptol.Parser.Position (emptyRange) import Cryptol.TypeCheck.AST hiding (splitTApp) -- XXX: just use this one import Cryptol.TypeCheck.TypeMap -import Cryptol.Utils.Ident (ModName) +import Cryptol.Utils.Ident(Namespace(..)) import Data.List(sortBy,groupBy) import Data.Either(partitionEithers) import Data.Map (Map) @@ -132,7 +132,7 @@ -- | Note that this assumes that this pass will be run only once for each -- module, otherwise we will get name collisions. rewModule :: Supply -> Module -> (Module,Supply) -rewModule s m = runM body (mName m) s +rewModule s m = runM body (TopModule (mName m)) s where body = do ds <- mapM (rewDeclGroup emptyTM) (mDecls m) return m { mDecls = ds } @@ -140,13 +140,13 @@ -------------------------------------------------------------------------------- type M = ReaderT RO (SupplyT Id) -type RO = ModName +type RO = ModPath -- | Produce a fresh top-level name. newName :: M Name newName = do ns <- ask - liftSupply (mkDeclared ns SystemName "$mono" Nothing emptyRange) + liftSupply (mkDeclared NSValue ns SystemName "$mono" Nothing emptyRange) newTopOrLocalName :: M Name newTopOrLocalName = newName 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 @@ -242,9 +242,10 @@ freshName :: Name -> [Type] -> SpecM Name freshName n _ = case nameInfo n of - Declared ns s -> liftSupply (mkDeclared ns s ident fx loc) - Parameter -> liftSupply (mkParameter ident loc) + Declared m s -> liftSupply (mkDeclared ns m s ident fx loc) + Parameter -> liftSupply (mkParameter ns ident loc) where + ns = nameNamespace n fx = nameFixity n ident = nameIdent n loc = nameLoc n diff --git a/src/Cryptol/TypeCheck.hs b/src/Cryptol/TypeCheck.hs --- a/src/Cryptol/TypeCheck.hs +++ b/src/Cryptol/TypeCheck.hs @@ -15,6 +15,7 @@ , InferInput(..) , InferOutput(..) , SolverConfig(..) + , defaultSolverConfig , NameSeeds , nameSeeds , Error(..) @@ -27,12 +28,15 @@ , ppNamedError ) where +import Data.IORef(IORef,modifyIORef') +import Data.Map(Map) + import Cryptol.ModuleSystem.Name - (liftSupply,mkDeclared,NameSource(..)) + (liftSupply,mkDeclared,NameSource(..),ModPath(..)) +import Cryptol.ModuleSystem.NamingEnv(NamingEnv,namingEnvRename) import qualified Cryptol.Parser.AST as P import Cryptol.Parser.Position(Range,emptyRange) import Cryptol.TypeCheck.AST -import Cryptol.TypeCheck.Depends (FromDecl) import Cryptol.TypeCheck.Error import Cryptol.TypeCheck.Monad ( runInferM @@ -41,16 +45,20 @@ , NameSeeds , nameSeeds , lookupVar + , newLocalScope, endLocalScope + , newModuleScope, addParamType, addParameterConstraints + , endModuleInstance + , io ) -import Cryptol.TypeCheck.Infer (inferModule, inferBinds, inferDs) -import Cryptol.TypeCheck.InferTypes(VarType(..), SolverConfig(..)) -import Cryptol.TypeCheck.Solve(proveModuleTopLevel) -import Cryptol.TypeCheck.CheckModuleInstance(checkModuleInstance) -import Cryptol.TypeCheck.Monad(withParamType,withParameterConstraints) -import Cryptol.TypeCheck.PP(WithNames(..),NameMap) -import Cryptol.Utils.Ident (exprModName,packIdent) -import Cryptol.Utils.PP -import Cryptol.Utils.Panic(panic) +import Cryptol.TypeCheck.Infer (inferModule, inferBinds, checkTopDecls) +import Cryptol.TypeCheck.InferTypes(VarType(..), SolverConfig(..), defaultSolverConfig) +import Cryptol.TypeCheck.Solve(proveModuleTopLevel) +import Cryptol.TypeCheck.CheckModuleInstance(checkModuleInstance) +-- import Cryptol.TypeCheck.Monad(withParamType,withParameterConstraints) +import Cryptol.TypeCheck.PP(WithNames(..),NameMap) +import Cryptol.Utils.Ident (exprModName,packIdent,Namespace(..)) +import Cryptol.Utils.PP +import Cryptol.Utils.Panic(panic) @@ -59,17 +67,22 @@ -- | Check a module instantiation, assuming that the functor has already -- been checked. -tcModuleInst :: Module {- ^ functor -} -> - P.Module Name {- params -} -> +-- XXX: This will change +tcModuleInst :: IORef NamingEnv {- ^ renaming environment of functor -} -> + Module {- ^ functor -} -> + P.Module Name {- ^ params -} -> InferInput {- ^ TC settings -} -> IO (InferOutput Module) {- ^ new version of instance -} -tcModuleInst func m inp = runInferM inp - $ do x <- inferModule m - flip (foldr withParamType) (mParamTypes x) $ - withParameterConstraints (mParamConstraints x) $ - do y <- checkModuleInstance func x - proveModuleTopLevel - pure y +tcModuleInst renThis func m inp = runInferM inp $ + do x <- inferModule m + newModuleScope (mName func) [] mempty + mapM_ addParamType (mParamTypes x) + addParameterConstraints (mParamConstraints x) + (ren,y) <- checkModuleInstance func x + io $ modifyIORef' renThis (namingEnvRename ren) + proveModuleTopLevel + endModuleInstance + pure y tcExpr :: P.Expr Name -> InferInput -> IO (InferOutput (Expr,Schema)) tcExpr e0 inp = runInferM inp @@ -92,8 +105,9 @@ , show e' , show t ] - _ -> do fresh <- liftSupply (mkDeclared exprModName SystemName - (packIdent "(expression)") Nothing loc) + _ -> do fresh <- liftSupply $ + mkDeclared NSValue (TopModule exprModName) SystemName + (packIdent "(expression)") Nothing loc res <- inferBinds True False [ P.Bind { P.bName = P.Located { P.srcRange = loc, P.thing = fresh } @@ -105,6 +119,7 @@ , P.bInfix = False , P.bFixity = Nothing , P.bDoc = Nothing + , P.bExport = Public } ] case res of @@ -119,24 +134,24 @@ : map show res ) -tcDecls :: FromDecl d => [d] -> InferInput -> IO (InferOutput [DeclGroup]) -tcDecls ds inp = runInferM inp $ inferDs ds $ \dgs -> do - proveModuleTopLevel - return dgs +tcDecls :: [P.TopDecl Name] -> InferInput -> IO (InferOutput ([DeclGroup],Map Name TySyn)) +tcDecls ds inp = runInferM inp $ + do newLocalScope + checkTopDecls ds + proveModuleTopLevel + endLocalScope ppWarning :: (Range,Warning) -> Doc -ppWarning (r,w) = text "[warning] at" <+> pp r <.> colon $$ nest 2 (pp w) +ppWarning (r,w) = nest 2 (text "[warning] at" <+> pp r <.> colon $$ pp w) ppError :: (Range,Error) -> Doc -ppError (r,w) = text "[error] at" <+> pp r <.> colon $$ nest 2 (pp w) - +ppError (r,w) = nest 2 (text "[error] at" <+> pp r <.> colon $$ pp w) ppNamedWarning :: NameMap -> (Range,Warning) -> Doc ppNamedWarning nm (r,w) = - text "[warning] at" <+> pp r <.> colon $$ nest 2 (pp (WithNames w nm)) + nest 2 (text "[warning] at" <+> pp r <.> colon $$ pp (WithNames w nm)) ppNamedError :: NameMap -> (Range,Error) -> Doc ppNamedError nm (r,e) = - text "[error] at" <+> pp r <.> colon $$ nest 2 (pp (WithNames e nm)) - + nest 2 (text "[error] at" <+> pp r <.> colon $$ pp (WithNames e nm)) 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 @@ -18,10 +18,10 @@ , Name() , TFun(..) , Selector(..) - , Import(..) + , Import, ImportG(..) , ImportSpec(..) , ExportType(..) - , ExportSpec(..), isExportedBind, isExportedType + , ExportSpec(..), isExportedBind, isExportedType, isExported , Pragma(..) , Fixity(..) , PrimMap(..) @@ -30,10 +30,12 @@ import Cryptol.Parser.Position(Located,Range,HasLoc(..)) import Cryptol.ModuleSystem.Name +import Cryptol.ModuleSystem.Interface import Cryptol.ModuleSystem.Exports(ExportSpec(..) - , isExportedBind, isExportedType) + , isExportedBind, isExportedType, isExported) import Cryptol.Parser.AST ( Selector(..),Pragma(..) - , Import(..), ImportSpec(..), ExportType(..) + , Import + , ImportG(..), ImportSpec(..), ExportType(..) , Fixity(..)) import Cryptol.Utils.Ident (Ident,isInfixIdent,ModName,PrimIdent,prelPrim) import Cryptol.Utils.RecordMap @@ -50,58 +52,60 @@ -- | A Cryptol module. -data Module = Module { mName :: !ModName - , mExports :: ExportSpec Name - , mImports :: [Import] +data ModuleG mname = + Module { mName :: !mname + , mExports :: ExportSpec Name + , mImports :: [Import] - , mTySyns :: Map Name TySyn - -- ^ This is just the type-level type synonyms - -- of a module. + {-| Interfaces of submodules, including functors. + This is only the directly nested modules. + Info about more nested modules is in the + corresponding interface. -} + , mSubModules :: Map Name (IfaceG Name) - , mNewtypes :: Map Name Newtype - , mPrimTypes :: Map Name AbstractType + -- params, if functor , mParamTypes :: Map Name ModTParam , mParamConstraints :: [Located Prop] , mParamFuns :: Map Name ModVParam + + + -- Declarations, including everything from non-functor + -- submodules + , mTySyns :: Map Name TySyn + , mNewtypes :: Map Name Newtype + , mPrimTypes :: Map Name AbstractType , mDecls :: [DeclGroup] + , mFunctors :: Map Name (ModuleG Name) } deriving (Show, Generic, NFData) +emptyModule :: mname -> ModuleG mname +emptyModule nm = + Module + { mName = nm + , mExports = mempty + , mImports = [] + , mSubModules = mempty + + , mParamTypes = mempty + , mParamConstraints = mempty + , mParamFuns = mempty + + , mTySyns = mempty + , mNewtypes = mempty + , mPrimTypes = mempty + , mDecls = mempty + , mFunctors = mempty + } + +type Module = ModuleG ModName + -- | Is this a parameterized module? -isParametrizedModule :: Module -> Bool +isParametrizedModule :: ModuleG mname -> Bool isParametrizedModule m = not (null (mParamTypes m) && null (mParamConstraints m) && null (mParamFuns m)) --- | A type parameter of a module. -data ModTParam = ModTParam - { mtpName :: Name - , mtpKind :: Kind - , mtpNumber :: !Int -- ^ The number of the parameter in the module - -- This is used when we move parameters from the module - -- level to individual declarations - -- (type synonyms in particular) - , mtpDoc :: Maybe Text - } deriving (Show,Generic,NFData) -mtpParam :: ModTParam -> TParam -mtpParam mtp = TParam { tpUnique = nameUnique (mtpName mtp) - , tpKind = mtpKind mtp - , tpFlav = TPModParam (mtpName mtp) - , tpInfo = desc - } - where desc = TVarInfo { tvarDesc = TVFromModParam (mtpName mtp) - , tvarSource = nameLoc (mtpName mtp) - } - --- | A value parameter of a module. -data ModVParam = ModVParam - { mvpName :: Name - , mvpType :: Schema - , mvpDoc :: Maybe Text - , mvpFixity :: Maybe Fixity - } deriving (Show,Generic,NFData) - - data Expr = EList [Expr] Type -- ^ List value (with type of elements) | ETuple [Expr] -- ^ Tuple value | ERec (RecordMap Ident Expr) -- ^ Record value @@ -207,14 +211,14 @@ EList [] t -> optParens (prec > 0) $ text "[]" <+> colon <+> ppWP prec t - EList es _ -> brackets $ sep $ punctuate comma $ map ppW es + EList es _ -> ppList $ map ppW es - ETuple es -> parens $ sep $ punctuate comma $ map ppW es + ETuple es -> ppTuple $ map ppW es - ERec fs -> braces $ sep $ punctuate comma + ERec fs -> ppRecord [ pp f <+> text "=" <+> ppW e | (f,e) <- displayFields fs ] - ESel e sel -> ppWP 4 e <+> text "." <.> pp sel + ESel e sel -> ppWP 4 e <.> text "." <.> pp sel ESet _ty e sel v -> braces (pp e <+> "|" <+> pp sel <+> "=" <+> pp v) @@ -224,7 +228,7 @@ , text "else" <+> ppW e3 ] EComp _ _ e mss -> let arm ms = text "|" <+> commaSep (map ppW ms) - in brackets $ ppW e <+> vcat (map arm mss) + in brackets $ ppW e <+> (align (vcat (map arm mss))) EVar x -> ppPrefixName x @@ -257,28 +261,29 @@ ETApp e t -> optParens (prec > 3) $ ppWP 3 e <+> ppWP 5 t - EWhere e ds -> optParens (prec > 0) - ( ppW e $$ text "where" - $$ nest 2 (vcat (map ppW ds)) - $$ text "" ) + EWhere e ds -> optParens (prec > 0) $ align $ vsep $ + [ ppW e + , hang "where" 2 (vcat (map ppW ds)) + ] where ppW x = ppWithNames nm x ppWP x = ppWithNamesPrec nm x ppLam :: NameMap -> Int -> [TParam] -> [Prop] -> [(Name,Type)] -> Expr -> Doc -ppLam nm prec [] [] [] e = ppWithNamesPrec nm prec e +ppLam nm prec [] [] [] e = nest 2 (ppWithNamesPrec nm prec e) ppLam nm prec ts ps xs e = optParens (prec > 0) $ - sep [ text "\\" <.> tsD <+> psD <+> xsD <+> text "->" - , ppWithNames ns1 e - ] + nest 2 $ sep + [ text "\\" <.> hsep (tsD ++ psD ++ xsD ++ [text "->"]) + , ppWithNames ns1 e + ] where ns1 = addTNames ts nm - tsD = if null ts then empty else braces $ sep $ punctuate comma $ map ppT ts - psD = if null ps then empty else parens $ sep $ punctuate comma $ map ppP ps - xsD = if null xs then empty else sep $ map ppArg xs + 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 @@ -355,12 +360,12 @@ instance PP (WithNames Decl) where ppPrec _ (WithNames Decl { .. } nm) = - pp dName <+> text ":" <+> ppWithNames nm dSignature $$ - (if null dPragmas - then empty - else text "pragmas" <+> pp dName <+> sep (map pp dPragmas) - ) $$ - pp dName <+> text "=" <+> ppWithNames nm dDefinition + vcat $ + [ pp dName <+> text ":" <+> ppWithNames nm dSignature ] + ++ (if null dPragmas + then [] + else [text "pragmas" <+> pp dName <+> sep (map pp dPragmas)]) + ++ [ nest 2 (sep [pp dName <+> text "=", ppWithNames nm dDefinition]) ] instance PP (WithNames DeclDef) where ppPrec _ (WithNames DPrim _) = text "" @@ -369,10 +374,10 @@ instance PP Decl where ppPrec = ppWithNamesPrec IntMap.empty -instance PP Module where +instance PP n => PP (ModuleG n) where ppPrec = ppWithNamesPrec IntMap.empty -instance PP (WithNames Module) where +instance PP n => PP (WithNames (ModuleG n)) where ppPrec _ (WithNames Module { .. } nm) = text "module" <+> pp mName $$ -- XXX: Print exports? diff --git a/src/Cryptol/TypeCheck/CheckModuleInstance.hs b/src/Cryptol/TypeCheck/CheckModuleInstance.hs --- a/src/Cryptol/TypeCheck/CheckModuleInstance.hs +++ b/src/Cryptol/TypeCheck/CheckModuleInstance.hs @@ -1,3 +1,4 @@ +{-# Language OverloadedStrings #-} module Cryptol.TypeCheck.CheckModuleInstance (checkModuleInstance) where import Data.Map ( Map ) @@ -19,17 +20,24 @@ -- | Check that the instance provides what the functor needs. checkModuleInstance :: Module {- ^ type-checked functor -} -> Module {- ^ type-checked instance -} -> - InferM Module -- ^ Instantiated module -checkModuleInstance func inst = + InferM (Name->Name,Module) + -- ^ Renaming,Instantiated module +checkModuleInstance func inst + | not (null (mSubModules func) && null (mSubModules inst)) = + do recordError $ TemporaryError + "Cannot combine nested modules with old-style parameterized modules" + pure (id,func) -- doesn't matter? + | otherwise = do tMap <- checkTyParams func inst vMap <- checkValParams func tMap inst - (ctrs, m) <- instantiateModule func (mName inst) tMap vMap + (ren, ctrs, m) <- instantiateModule func (mName inst) tMap vMap let toG p = Goal { goal = thing p , goalRange = srcRange p , goalSource = CtModuleInstance (mName inst) } addGoals (map toG ctrs) - return Module { mName = mName m + return ( ren + , Module { mName = mName m , mExports = mExports m , mImports = mImports inst ++ mImports m -- Note that this is just here to record @@ -43,7 +51,11 @@ , mParamConstraints = mParamConstraints inst , mParamFuns = mParamFuns inst , mDecls = mDecls inst ++ mDecls m + + , mSubModules = mempty + , mFunctors = mempty } + ) -- | Check that the type parameters of the functors all have appropriate -- definitions. @@ -179,6 +191,7 @@ , P.bPragmas = [] , P.bMono = False , P.bDoc = Nothing + , P.bExport = Public } loc a = P.Located { P.srcRange = nameLoc x, P.thing = a } diff --git a/src/Cryptol/TypeCheck/Depends.hs b/src/Cryptol/TypeCheck/Depends.hs deleted file mode 100644 --- a/src/Cryptol/TypeCheck/Depends.hs +++ /dev/null @@ -1,214 +0,0 @@ --- | --- Module : Cryptol.TypeCheck.Depends --- Copyright : (c) 2013-2016 Galois, Inc. --- License : BSD3 --- Maintainer : cryptol@galois.com --- Stability : provisional --- Portability : portable - -{-# LANGUAGE Safe #-} -{-# LANGUAGE FlexibleInstances #-} -module Cryptol.TypeCheck.Depends where - -import Cryptol.ModuleSystem.Name (Name) -import qualified Cryptol.Parser.AST as P -import Cryptol.Parser.Position(Range, Located(..), thing) -import Cryptol.Parser.Names (namesB, tnamesT, tnamesC, - boundNamesSet, boundNames) -import Cryptol.TypeCheck.Monad( InferM, getTVars ) -import Cryptol.TypeCheck.Error(Error(..)) -import Cryptol.Utils.Panic(panic) -import Cryptol.Utils.RecordMap(recordElements) - -import Data.List(sortBy, groupBy) -import Data.Function(on) -import Data.Maybe(mapMaybe) -import Data.Graph.SCC(stronglyConnComp) -import Data.Graph (SCC(..)) -import Data.Map (Map) -import qualified Data.Map as Map -import qualified Data.Set as Set -import Data.Text (Text) -import MonadLib (ExceptionT, runExceptionT, raise) - -data TyDecl = - TS (P.TySyn Name) (Maybe Text) -- ^ Type synonym - | NT (P.Newtype Name) (Maybe Text) -- ^ Newtype - | AT (P.ParameterType Name) (Maybe Text) -- ^ Parameter type - | PS (P.PropSyn Name) (Maybe Text) -- ^ Property synonym - | PT (P.PrimType Name) (Maybe Text) -- ^ A primitive/abstract typee - deriving Show - -setDocString :: Maybe Text -> TyDecl -> TyDecl -setDocString x d = - case d of - TS a _ -> TS a x - PS a _ -> PS a x - NT a _ -> NT a x - AT a _ -> AT a x - PT a _ -> PT a x - --- | Check for duplicate and recursive type synonyms. --- Returns the type-synonyms in dependency order. -orderTyDecls :: [TyDecl] -> InferM (Either Error [TyDecl]) -orderTyDecls ts = - do vs <- getTVars - ds <- combine $ map (toMap vs) ts - let ordered = mkScc [ (t,[x],deps) - | (x,(t,deps)) <- Map.toList (Map.map thing ds) ] - runExceptionT (concat `fmap` mapM check ordered) - - where - toMap vs ty@(PT p _) = - let x = P.primTName p - (as,cs) = P.primTCts p - in ( thing x - , x { thing = (ty, Set.toList $ - boundNamesSet vs $ - boundNames (map P.tpName as) $ - Set.unions $ - map tnamesC cs - ) - } - ) - - - toMap _ ty@(AT a _) = - let x = P.ptName a - in ( thing x, x { thing = (ty, []) } ) - - toMap vs ty@(NT (P.Newtype x as fs) _) = - ( thing x - , x { thing = (ty, Set.toList $ - boundNamesSet vs $ - boundNames (map P.tpName as) $ - Set.unions $ - map (tnamesT . snd) (recordElements fs) - ) - } - ) - - toMap vs ty@(TS (P.TySyn x _ as t) _) = - (thing x - , x { thing = (ty, Set.toList $ - boundNamesSet vs $ - boundNames (map P.tpName as) $ - tnamesT t - ) - } - ) - - toMap vs ty@(PS (P.PropSyn x _ as ps) _) = - (thing x - , x { thing = (ty, Set.toList $ - boundNamesSet vs $ - boundNames (map P.tpName as) $ - Set.unions $ - map tnamesC ps - ) - } - ) - getN (TS x _) = thing (P.tsName x) - getN (PS x _) = thing (P.psName x) - getN (NT x _) = thing (P.nName x) - getN (AT x _) = thing (P.ptName x) - getN (PT x _) = thing (P.primTName x) - - check :: SCC TyDecl -> ExceptionT Error InferM [TyDecl] - check (AcyclicSCC x) = return [x] - - -- We don't support any recursion, for now. - -- We could support recursion between newtypes, or newtypes and tysysn. - check (CyclicSCC xs) = raise (RecursiveTypeDecls (map getN xs)) - --- | Associate type signatures with bindings and order bindings by dependency. -orderBinds :: [P.Bind Name] -> [SCC (P.Bind Name)] -orderBinds bs = mkScc [ (b, map thing defs, Set.toList uses) - | b <- bs - , let (defs,uses) = namesB b - ] - -class FromDecl d where - toBind :: d -> Maybe (P.Bind Name) - toParamFun :: d -> Maybe (P.ParameterFun Name) - toParamConstraints :: d -> [P.Located (P.Prop Name)] - toTyDecl :: d -> Maybe TyDecl - isTopDecl :: d -> Bool - -instance FromDecl (P.TopDecl Name) where - toBind (P.Decl x) = toBind (P.tlValue x) - toBind _ = Nothing - - toParamFun (P.DParameterFun d) = Just d - toParamFun _ = Nothing - - toParamConstraints (P.DParameterConstraint xs) = xs - toParamConstraints _ = [] - - toTyDecl (P.DPrimType p) = Just (PT (P.tlValue p) (thing <$> P.tlDoc p)) - toTyDecl (P.DParameterType d) = Just (AT d (P.ptDoc d)) - toTyDecl (P.TDNewtype d) = Just (NT (P.tlValue d) (thing <$> P.tlDoc d)) - toTyDecl (P.Decl x) = setDocString (thing <$> P.tlDoc x) - <$> toTyDecl (P.tlValue x) - toTyDecl _ = Nothing - - isTopDecl _ = True - -instance FromDecl (P.Decl Name) where - toBind (P.DLocated d _) = toBind d - toBind (P.DBind b) = return b - toBind _ = Nothing - - toParamFun _ = Nothing - toParamConstraints _ = [] - - toTyDecl (P.DLocated d _) = toTyDecl d - toTyDecl (P.DType x) = Just (TS x Nothing) - toTyDecl (P.DProp x) = Just (PS x Nothing) - toTyDecl _ = Nothing - - isTopDecl _ = False - -{- | Given a list of declarations, annoted with (i) the names that they -define, and (ii) the names that they use, we compute a list of strongly -connected components of the declarations. The SCCs are in dependency order. -} -mkScc :: [(a,[Name],[Name])] -> [SCC a] -mkScc ents = stronglyConnComp $ zipWith mkGr keys ents - where - keys = [ 0 :: Integer .. ] - - mkGr i (x,_,uses) = (x,i,mapMaybe (`Map.lookup` nodeMap) uses) - - -- Maps names to node ids. - nodeMap = Map.fromList $ concat $ zipWith mkNode keys ents - mkNode i (_,defs,_) = [ (d,i) | d <- defs ] - -{- | Combine a bunch of definitions into a single map. Here we check -that each name is defined only onces. -} -combineMaps :: [Map Name (Located a)] -> InferM (Map Name (Located a)) -combineMaps ms = if null bad then return (Map.unions ms) - else panic "combineMaps" $ "Multiple definitions" - : map show bad - where - bad = do m <- ms - duplicates [ a { thing = x } | (x,a) <- Map.toList m ] - -{- | Combine a bunch of definitions into a single map. Here we check -that each name is defined only onces. -} -combine :: [(Name, Located a)] -> InferM (Map Name (Located a)) -combine m = if null bad then return (Map.fromList m) - else panic "combine" $ "Multiple definitions" - : map show bad - where - bad = duplicates [ a { thing = x } | (x,a) <- m ] - --- | Identify multiple occurances of something. -duplicates :: Ord a => [Located a] -> [(a,[Range])] -duplicates = mapMaybe multiple - . groupBy ((==) `on` thing) - . sortBy (compare `on` thing) - where - multiple xs@(x : _ : _) = Just (thing x, map srcRange xs) - multiple _ = Nothing - - 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 @@ -139,6 +139,12 @@ | TypeShadowing String Name String | MissingModTParam (Located Ident) | MissingModVParam (Located Ident) + + | TemporaryError Doc + -- ^ This is for errors that don't fit other cateogories. + -- We should not use it much, and is generally to be used + -- for transient errors, which are due to incomplete + -- implementation. deriving (Show, Generic, NFData) -- | When we have multiple errors on the same location, we show only the @@ -147,6 +153,10 @@ errorImportance err = case err of BareTypeApp -> 11 -- basically a parse error + TemporaryError {} -> 11 + -- show these as usually means the user used something that doesn't work + + KindMismatch {} -> 10 TyVarWithParams {} -> 9 TypeMismatch {} -> 8 @@ -236,7 +246,9 @@ MissingModTParam {} -> err MissingModVParam {} -> err + TemporaryError {} -> err + instance FVS Error where fvs err = case err of @@ -269,6 +281,8 @@ MissingModTParam {} -> Set.empty MissingModVParam {} -> Set.empty + TemporaryError {} -> Set.empty + instance PP Warning where ppPrec = ppWithNamesPrec IntMap.empty @@ -310,11 +324,11 @@ KindMismatch mbsrc k1 k2 -> addTVarsDescsAfter names err $ nested "Incorrect type form." $ - vcat [ "Expected:" <+> cppKind k1 - , "Inferred:" <+> cppKind k2 - , kindMismatchHint k1 k2 - , maybe empty (\src -> "When checking" <+> pp src) mbsrc - ] + vcat $ + [ "Expected:" <+> cppKind k1 + , "Inferred:" <+> cppKind k2 + ] ++ kindMismatchHint k1 k2 + ++ maybe [] (\src -> ["When checking" <+> pp src]) mbsrc TooManyTypeParams extra k -> addTVarsDescsAfter names err $ @@ -341,16 +355,16 @@ RecursiveTypeDecls ts -> addTVarsDescsAfter names err $ nested "Recursive type declarations:" - (fsep $ punctuate comma $ map nm ts) + (commaSep $ map nm ts) TypeMismatch src t1 t2 -> addTVarsDescsAfter names err $ nested "Type mismatch:" $ - vcat [ "Expected type:" <+> ppWithNames names t1 - , "Inferred type:" <+> ppWithNames names t2 - , mismatchHint t1 t2 - , "When checking" <+> pp src - ] + vcat $ + [ "Expected type:" <+> ppWithNames names t1 + , "Inferred type:" <+> ppWithNames names t2 + ] ++ mismatchHint t1 t2 + ++ ["When checking" <+> pp src] UnsolvableGoals gs -> explainUnsolvable names gs @@ -380,7 +394,7 @@ nested ("The type" <+> ppWithNames names t <+> "is not sufficiently polymorphic.") $ vcat [ "It cannot depend on quantified variables:" <+> - sep (punctuate comma (map (ppWithNames names) xs)) + (commaSep (map (ppWithNames names) xs)) , "When checking" <+> pp src ] @@ -412,16 +426,17 @@ $$ "See" <+> pp (srcRange x) RepeatedTypeParameter x rs -> - addTVarsDescsAfter names err $ - "Multiple definitions for type parameter `" <.> pp x <.> "`:" - $$ nest 2 (bullets (map pp rs)) + addTVarsDescsAfter names err $ nest 2 $ + "Multiple definitions for type parameter `" <.> pp x <.> "`:" + $$ bullets (map pp rs) AmbiguousSize x t -> let sizeMsg = case t of - Just t' -> "Must be at least:" <+> ppWithNames names t' - Nothing -> empty - in addTVarsDescsAfter names err ("Ambiguous numeric type:" <+> pp (tvarDesc x) $$ sizeMsg) + Just t' -> ["Must be at least:" <+> ppWithNames names t'] + Nothing -> [] + in addTVarsDescsAfter names err + (vcat (["Ambiguous numeric type:" <+> pp (tvarDesc x)] ++ sizeMsg)) BareTypeApp -> "Unexpected bare type application." $$ @@ -436,13 +451,11 @@ MissingModVParam x -> "Missing definition for value parameter" <+> quotes (pp (thing x)) - - - + TemporaryError doc -> doc where bullets xs = vcat [ "•" <+> d | d <- xs ] - nested x y = x $$ nest 2 y + nested x y = nest 2 (x $$ y) pl 1 x = text "1" <+> text x pl n x = text (show n) <+> text x <.> text "s" @@ -451,18 +464,18 @@ kindMismatchHint k1 k2 = case (k1,k2) of - (KType,KProp) -> "Possibly due to a missing `=>`" - _ -> empty + (KType,KProp) -> [text "Possibly due to a missing `=>`"] + _ -> [] mismatchHint (TRec fs1) (TRec fs2) = - hint "Missing" missing $$ hint "Unexpected" extra + hint "Missing" missing ++ hint "Unexpected" extra where missing = displayOrder fs1 \\ displayOrder fs2 extra = displayOrder fs2 \\ displayOrder fs1 - hint _ [] = mempty - hint s [x] = text s <+> text "field" <+> pp x - hint s xs = text s <+> text "fields" <+> commaSep (map pp xs) - mismatchHint _ _ = mempty + hint _ [] = [] + hint s [x] = [text s <+> text "field" <+> pp x] + hint s xs = [text s <+> text "fields" <+> commaSep (map pp xs)] + mismatchHint _ _ = [] noUni = Set.null (Set.filter isFreeTV (fvs err)) @@ -478,18 +491,17 @@ explain g = - let useCtr = "Unsolvable constraint:" $$ - nest 2 (ppWithNames names g) + let useCtr = hang "Unsolvable constraint:" 2 (ppWithNames names g) in case tNoUser (goal g) of TCon (PC pc) ts -> let tys = [ backticks (ppWithNames names t) | t <- ts ] doc1 : _ = tys - custom msg = msg $$ - nest 2 (text "arising from" $$ - pp (goalSource g) $$ - text "at" <+> pp (goalRange g)) + custom msg = hang msg + 2 (text "arising from" $$ + pp (goalSource g) $$ + text "at" <+> pp (goalRange g)) in case pc of PEqual -> useCtr @@ -499,7 +511,7 @@ PPrime -> useCtr PHas sel -> - custom ("Type" <+> doc1 <+> "does not have field" <+> f + custom ("Type" <+> doc1 "does not have field" <+> f <+> "of type" <+> (tys !! 1)) where f = case sel of P.TupleSel n _ -> int n @@ -507,39 +519,39 @@ P.ListSel n _ -> int n PZero -> - custom ("Type" <+> doc1 <+> "does not have `zero`") + custom ("Type" <+> doc1 "does not have `zero`") PLogic -> - custom ("Type" <+> doc1 <+> "does not support logical operations.") + custom ("Type" <+> doc1 "does not support logical operations.") PRing -> - custom ("Type" <+> doc1 <+> "does not support ring operations.") + custom ("Type" <+> doc1 "does not support ring operations.") PIntegral -> - custom (doc1 <+> "is not an integral type.") + custom (doc1 "is not an integral type.") PField -> - custom ("Type" <+> doc1 <+> "does not support field operations.") + custom ("Type" <+> doc1 "does not support field operations.") PRound -> - custom ("Type" <+> doc1 <+> "does not support rounding operations.") + custom ("Type" <+> doc1 "does not support rounding operations.") PEq -> - custom ("Type" <+> doc1 <+> "does not support equality.") + custom ("Type" <+> doc1 "does not support equality.") PCmp -> - custom ("Type" <+> doc1 <+> "does not support comparisons.") + custom ("Type" <+> doc1 "does not support comparisons.") PSignedCmp -> - custom ("Type" <+> doc1 <+> "does not support signed comparisons.") + custom ("Type" <+> doc1 "does not support signed comparisons.") PLiteral -> let doc2 = tys !! 1 - in custom (doc1 <+> "is not a valid literal of type" <+> doc2) + in custom (doc1 "is not a valid literal of type" <+> doc2) PLiteralLessThan -> let doc2 = tys !! 1 - in custom ("Type" <+> doc2 <+> "does not contain all literals below" <+> (doc1 <> ".")) + in custom ("Type" <+> doc2 "does not contain all literals below" <+> (doc1 <> ".")) PFLiteral -> case ts of @@ -547,14 +559,14 @@ let frac = backticks (ppWithNamesPrec names 4 m <> "/" <> ppWithNamesPrec names 4 n) ty = tys !! 3 - in custom (frac <+> "is not a valid literal of type" <+> ty) + in custom (frac "is not a valid literal of type" ty) PValidFloat -> case ts of - ~[e,p] -> - custom ("Unsupported floating point parameters:" $$ - nest 2 ("exponent =" <+> ppWithNames names e $$ - "precision =" <+> ppWithNames names p)) + ~[e,p] -> + custom (hang "Unsupported floating point parameters:" + 2 ("exponent =" <+> ppWithNames names e $$ + "precision =" <+> ppWithNames names p)) PAnd -> useCtr 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 @@ -13,16 +13,18 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE RecursiveDo #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE Safe #-} module Cryptol.TypeCheck.Infer ( checkE , checkSigB , inferModule , inferBinds - , inferDs + , checkTopDecls ) where +import Data.Text(Text) import qualified Data.Text as Text @@ -41,7 +43,6 @@ checkPrimType, checkParameterConstraints) import Cryptol.TypeCheck.Instantiate -import Cryptol.TypeCheck.Depends import Cryptol.TypeCheck.Subst (listSubst,apSubst,(@@),isEmptySubst) import Cryptol.Utils.Ident import Cryptol.Utils.Panic(panic) @@ -50,43 +51,24 @@ import qualified Data.Map as Map import Data.Map (Map) import qualified Data.Set as Set -import Data.List(foldl',sortBy) +import Data.List(foldl',sortBy,groupBy) import Data.Either(partitionEithers) -import Data.Maybe(mapMaybe,isJust, fromMaybe) +import Data.Maybe(isJust, fromMaybe, mapMaybe) import Data.List(partition) -import Data.Graph(SCC(..)) import Data.Ratio(numerator,denominator) import Data.Traversable(forM) -import Control.Monad(zipWithM,unless,foldM) +import Data.Function(on) +import Control.Monad(zipWithM,unless,foldM,forM_) inferModule :: P.Module Name -> InferM Module inferModule m = - inferDs (P.mDecls m) $ \ds1 -> - do proveModuleTopLevel - ts <- getTSyns - nts <- getNewtypes - ats <- getAbstractTypes - pTs <- getParamTypes - pCs <- getParamConstraints - pFuns <- getParamFuns - return Module { mName = thing (P.mName m) - , mExports = P.modExports m - , mImports = map thing (P.mImports m) - , mTySyns = Map.mapMaybe onlyLocal ts - , mNewtypes = Map.mapMaybe onlyLocal nts - , mPrimTypes = Map.mapMaybe onlyLocal ats - , mParamTypes = pTs - , mParamConstraints = pCs - , mParamFuns = pFuns - , mDecls = ds1 - } - where - onlyLocal (IsLocal, x) = Just x - onlyLocal (IsExternal, _) = Nothing - - + do newModuleScope (thing (P.mName m)) (map thing (P.mImports m)) + (P.modExports m) + checkTopDecls (P.mDecls m) + proveModuleTopLevel + endModule -- | Construct a Prelude primitive in the parsed AST. mkPrim :: String -> InferM (P.Expr Name) @@ -164,9 +146,8 @@ -- Here is an example of why this might be useful: -- f ` { x = T } where type T = ... P.EWhere e ds -> - inferDs ds $ \ds1 -> do e1 <- appTys e ts tGoal - return (EWhere e1 ds1) - -- XXX: Is there a scoping issue here? I think not, but check. + do (e1,ds1) <- checkLocalDecls ds (appTys e ts tGoal) + pure (EWhere e1 ds1) P.ELocated e r -> do e' <- inRange r (appTys e ts tGoal) @@ -183,6 +164,8 @@ P.ESel {} -> mono P.EList {} -> mono P.EFromTo {} -> mono + P.EFromToBy {} -> mono + P.EFromToDownBy {} -> mono P.EFromToLessThan {} -> mono P.EInfFrom {} -> mono P.EComp {} -> mono @@ -295,6 +278,58 @@ es' <- mapM checkElem es return (EList es' a) + P.EFromToBy isStrict t1 t2 t3 mety + | isStrict -> + do l <- curRange + let fs = [("first",t1),("bound",t2),("stride",t3)] ++ + case mety of + Just ety -> [("a",ety)] + Nothing -> [] + prim <- mkPrim "fromToByLessThan" + let e' = P.EAppT prim + [ P.NamedInst P.Named{ name = Located l (packIdent x), value = y } + | (x,y) <- fs + ] + checkE e' tGoal + | otherwise -> + do l <- curRange + let fs = [("first",t1),("last",t2),("stride",t3)] ++ + case mety of + Just ety -> [("a",ety)] + Nothing -> [] + prim <- mkPrim "fromToBy" + let e' = P.EAppT prim + [ P.NamedInst P.Named{ name = Located l (packIdent x), value = y } + | (x,y) <- fs + ] + checkE e' tGoal + + P.EFromToDownBy isStrict t1 t2 t3 mety + | isStrict -> + do l <- curRange + let fs = [("first",t1),("bound",t2),("stride",t3)] ++ + case mety of + Just ety -> [("a",ety)] + Nothing -> [] + prim <- mkPrim "fromToDownByGreaterThan" + let e' = P.EAppT prim + [ P.NamedInst P.Named{ name = Located l (packIdent x), value = y } + | (x,y) <- fs + ] + checkE e' tGoal + | otherwise -> + do l <- curRange + let fs = [("first",t1),("last",t2),("stride",t3)] ++ + case mety of + Just ety -> [("a",ety)] + Nothing -> [] + prim <- mkPrim "fromToDownBy" + let e' = P.EAppT prim + [ P.NamedInst P.Named{ name = Located l (packIdent x), value = y } + | (x,y) <- fs + ] + checkE e' tGoal + P.EFromToLessThan t1 t2 mety -> do l <- curRange let fs0 = @@ -349,7 +384,24 @@ ds <- combineMaps dss e' <- withMonoTypes ds (checkE e (WithSource a TypeOfSeqElement)) return (EComp len a e' mss') + where + -- the renamer should have made these checks already? + combineMaps ms = if null bad + then return (Map.unions ms) + else panic "combineMaps" $ "Multiple definitions" + : map show bad + where + bad = do m <- ms + duplicates [ a { thing = x } | (x,a) <- Map.toList m ] + duplicates = mapMaybe multiple + . groupBy ((==) `on` thing) + . sortBy (compare `on` thing) + where + multiple xs@(x : _ : _) = Just (thing x, map srcRange xs) + multiple _ = Nothing + + P.EAppT e fs -> appTys e (map uncheckedTypeArg fs) tGoal P.EApp e1 e2 -> @@ -366,8 +418,8 @@ return (EIf e1' e2' e3') P.EWhere e ds -> - inferDs ds $ \ds1 -> do e1 <- checkE e tGoal - return (EWhere e1 ds1) + do (e1,ds1) <- checkLocalDecls ds (checkE e tGoal) + pure (EWhere e1 ds1) P.ETyped e t -> do tSig <- checkTypeOfKind t KType @@ -406,7 +458,7 @@ -- { _ | fs } ~~> \r -> { r | fs } Nothing -> - do r <- newParamName (packIdent "r") + do r <- newParamName NSValue (packIdent "r") let p = P.PVar Located { srcRange = nameLoc r, thing = r } fe = P.EFun P.emptyFunDesc [p] (P.EUpd (Just (P.EVar r)) fs) checkE fe tGoal @@ -432,7 +484,7 @@ v1 <- checkE v (WithSource (tFun ft ft) src) -- XXX: ^ may be used a different src? d <- newHasGoal s (twsType tGoal) ft - tmp <- newParamName (packIdent "rf") + tmp <- newParamName NSValue (packIdent "rf") let e' = EVar tmp pure $ hasDoSet d e' (EApp v1 (hasDoSelect d e')) `EWhere` @@ -581,10 +633,11 @@ checkFun :: - P.FunDesc Name -> [P.Pattern Name] -> P.Expr Name -> TypeWithSource -> InferM Expr + P.FunDesc Name -> [P.Pattern Name] -> + P.Expr Name -> TypeWithSource -> InferM Expr checkFun _ [] e tGoal = checkE e tGoal checkFun (P.FunDesc fun offset) ps e tGoal = - inNewScope $ + inNewScope do let descs = [ TypeOfArg (ArgDescr fun (Just n)) | n <- [ 1 + offset .. ] ] (tys,tRes) <- expectFun fun (length ps) tGoal @@ -965,68 +1018,104 @@ , dDoc = P.bDoc b } -inferDs :: FromDecl d => [d] -> ([DeclGroup] -> InferM a) -> InferM a -inferDs ds continue = either onErr checkTyDecls =<< orderTyDecls (mapMaybe toTyDecl ds) + +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- + +checkLocalDecls :: [P.Decl Name] -> InferM a -> InferM (a,[DeclGroup]) +checkLocalDecls ds0 k = + do newLocalScope + forM_ ds0 \d -> checkDecl False d Nothing + a <- k + (ds,_tySyns) <- endLocalScope + pure (a,ds) + + + +checkTopDecls :: [P.TopDecl Name] -> InferM () +checkTopDecls = mapM_ checkTopDecl where - onErr err = recordError err >> continue [] + checkTopDecl decl = + case decl of + P.Decl tl -> checkDecl True (P.tlValue tl) (thing <$> P.tlDoc tl) - isTopLevel = isTopDecl (head ds) + P.TDNewtype tl -> + do t <- checkNewtype (P.tlValue tl) (thing <$> P.tlDoc tl) + addNewtype t - checkTyDecls (AT t mbD : ts) = - do t1 <- checkParameterType t mbD - withParamType t1 (checkTyDecls ts) + P.DPrimType tl -> + do t <- checkPrimType (P.tlValue tl) (thing <$> P.tlDoc tl) + addPrimType t - checkTyDecls (TS t mbD : ts) = - do t1 <- checkTySyn t mbD - withTySyn t1 (checkTyDecls ts) + P.DParameterType ty -> + do t <- checkParameterType ty (P.ptDoc ty) + addParamType t - checkTyDecls (PS t mbD : ts) = - do t1 <- checkPropSyn t mbD - withTySyn t1 (checkTyDecls ts) + P.DParameterConstraint cs -> + do cs1 <- checkParameterConstraints cs + addParameterConstraints cs1 - checkTyDecls (NT t mbD : ts) = - do t1 <- checkNewtype t mbD - withNewtype t1 (checkTyDecls ts) + P.DParameterFun pf -> + do x <- checkParameterFun pf + addParamFun x - checkTyDecls (PT p mbD : ts) = - do p1 <- checkPrimType p mbD - withPrimType p1 (checkTyDecls ts) + P.DModule tl -> + do let P.NestedModule m = P.tlValue tl + newSubmoduleScope (thing (P.mName m)) (map thing (P.mImports m)) + (P.modExports m) + checkTopDecls (P.mDecls m) + endSubmodule - -- We checked all type synonyms, now continue with value-level definitions: - checkTyDecls [] = - do cs <- checkParameterConstraints (concatMap toParamConstraints ds) - withParameterConstraints cs $ - do xs <- mapM checkParameterFun (mapMaybe toParamFun ds) - withParamFuns xs $ checkBinds [] $ orderBinds $ mapMaybe toBind ds + P.DImport {} -> pure () + P.Include {} -> panic "checkTopDecl" [ "Unexpected `inlude`" ] - checkParameterFun x = - do (s,gs) <- checkSchema NoWildCards (P.pfSchema x) - su <- proveImplication (Just (thing (P.pfName x))) - (sVars s) (sProps s) gs - unless (isEmptySubst su) $ - panic "checkParameterFun" ["Subst not empty??"] - let n = thing (P.pfName x) - return ModVParam { mvpName = n - , mvpType = s - , mvpDoc = P.pfDoc x - , mvpFixity = P.pfFixity x - } +checkDecl :: Bool -> P.Decl Name -> Maybe Text -> InferM () +checkDecl isTopLevel d mbDoc = + case d of - checkBinds decls (CyclicSCC bs : more) = - do bs1 <- inferBinds isTopLevel True bs - foldr (\b m -> withVar (dName b) (dSignature b) m) - (checkBinds (Recursive bs1 : decls) more) - bs1 + P.DBind c -> + do ~[b] <- inferBinds isTopLevel False [c] + addDecls (NonRecursive b) - checkBinds decls (AcyclicSCC c : more) = - do ~[b] <- inferBinds isTopLevel False [c] - withVar (dName b) (dSignature b) $ - checkBinds (NonRecursive b : decls) more + P.DRec bs -> + do bs1 <- inferBinds isTopLevel True bs + addDecls (Recursive bs1) - -- We are done with all value-level definitions. - -- Now continue with anything that's in scope of the declarations. - checkBinds decls [] = continue (reverse decls) + P.DType t -> + do t1 <- checkTySyn t mbDoc + addTySyn t1 + + P.DProp t -> + do t1 <- checkPropSyn t mbDoc + addTySyn t1 + + P.DLocated d' r -> inRange r (checkDecl isTopLevel d' mbDoc) + + P.DSignature {} -> bad "DSignature" + P.DFixity {} -> bad "DFixity" + P.DPragma {} -> bad "DPragma" + P.DPatBind {} -> bad "DPatBind" + + where + bad x = panic "checkDecl" [x] + + +checkParameterFun :: P.ParameterFun Name -> InferM ModVParam +checkParameterFun x = + do (s,gs) <- checkSchema NoWildCards (P.pfSchema x) + su <- proveImplication (Just (thing (P.pfName x))) + (sVars s) (sProps s) gs + unless (isEmptySubst su) $ + panic "checkParameterFun" ["Subst not empty??"] + let n = thing (P.pfName x) + return ModVParam { mvpName = n + , mvpType = s + , mvpDoc = P.pfDoc x + , mvpFixity = P.pfFixity x + } + + tcPanic :: String -> [String] -> a tcPanic l msg = panic ("[TypeCheck] " ++ l) msg 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 @@ -48,6 +48,18 @@ } deriving (Show, Generic, NFData) +-- | A default configuration for using Z3, where +-- the solver prelude is expected to be found +-- in the given search path. +defaultSolverConfig :: [FilePath] -> SolverConfig +defaultSolverConfig searchPath = + SolverConfig + { solverPath = "z3" + , solverArgs = [ "-smt2", "-in" ] + , solverVerbose = 0 + , solverPreludePath = searchPath + } + -- | The types of variables in the environment. data VarType = ExtVar Schema -- ^ Known type @@ -303,24 +315,25 @@ addTVarsDescsAfter :: FVS t => NameMap -> t -> Doc -> Doc addTVarsDescsAfter nm t d | Set.null vs = d +-- TODO? use `hang` here instead to indent things after "where" | otherwise = d $$ text "where" $$ vcat (map desc (Set.toList vs)) where vs = fvs t desc v = ppWithNames nm v <+> text "is" <+> pp (tvInfo v) addTVarsDescsBefore :: FVS t => NameMap -> t -> Doc -> Doc -addTVarsDescsBefore nm t d = frontMsg $$ d $$ backMsg +addTVarsDescsBefore nm t d = vcat (frontMsg ++ [d] ++ backMsg) where (vs1,vs2) = Set.partition isFreeTV (fvs t) - frontMsg | null vs1 = empty - | otherwise = "Failed to infer the following types:" - $$ nest 2 (vcat (map desc1 (Set.toList vs1))) + frontMsg | null vs1 = [] + | otherwise = [hang "Failed to infer the following types:" + 2 (vcat (map desc1 (Set.toList vs1)))] desc1 v = "•" <+> ppWithNames nm v <.> comma <+> pp (tvInfo v) - backMsg | null vs2 = empty - | otherwise = "where" - $$ nest 2 (vcat (map desc2 (Set.toList vs2))) + backMsg | null vs2 = [] + | otherwise = [hang "where" + 2 (vcat (map desc2 (Set.toList vs2)))] desc2 v = ppWithNames nm v <+> text "is" <+> pp (tvInfo v) @@ -351,7 +364,7 @@ | prim == "infFromThen" -> "infinite enumeration (with step)" | prim == "fromTo" -> "finite enumeration" | prim == "fromThenTo" -> "finite enumeration" - _ -> "expression" <+> pp expr + _ -> "expression" <+> pp expr where isPrelPrim x = do PrimIdent p i <- asPrim x guard (p == preludeName) @@ -359,19 +372,21 @@ instance PP (WithNames Goal) where ppPrec _ (WithNames g names) = - (ppWithNames names (goal g)) $$ - nest 2 (text "arising from" $$ - pp (goalSource g) $$ - text "at" <+> pp (goalRange g)) + hang (ppWithNames names (goal g)) + 2 (text "arising from" $$ + pp (goalSource g) $$ + text "at" <+> pp (goalRange g)) instance PP (WithNames DelayedCt) where ppPrec _ (WithNames d names) = - sig $$ "we need to show that" $$ - nest 2 (vcat [ vars, asmps, "the following constraints hold:" - , nest 2 $ vcat - $ bullets - $ map (ppWithNames ns1) - $ dctGoals d ]) + sig $$ + hang "we need to show that" + 2 (vcat ( vars ++ asmps ++ + [ hang "the following constraints hold:" + 2 (vcat + $ bullets + $ map (ppWithNames ns1) + $ dctGoals d )])) where bullets xs = [ "•" <+> x | x <- xs ] @@ -382,12 +397,11 @@ name = dctSource d vars = case dctForall d of - [] -> empty - xs -> "for any type" <+> - fsep (punctuate comma (map (ppWithNames ns1 ) xs)) + [] -> [] + xs -> ["for any type" <+> commaSep (map (ppWithNames ns1) xs)] asmps = case dctAsmps d of - [] -> empty - xs -> "assuming" $$ - nest 2 (vcat (bullets (map (ppWithNames ns1) xs))) + [] -> [] + xs -> [hang "assuming" + 2 (vcat (bullets (map (ppWithNames ns1) xs)))] ns1 = addTNames (dctForall d) names diff --git a/src/Cryptol/TypeCheck/Interface.hs b/src/Cryptol/TypeCheck/Interface.hs new file mode 100644 --- /dev/null +++ b/src/Cryptol/TypeCheck/Interface.hs @@ -0,0 +1,73 @@ +module Cryptol.TypeCheck.Interface where + +import qualified Data.Map as Map + +import Cryptol.Utils.Ident(Namespace(..)) +import Cryptol.ModuleSystem.Interface +import Cryptol.TypeCheck.AST + + +mkIfaceDecl :: Decl -> IfaceDecl +mkIfaceDecl d = IfaceDecl + { ifDeclName = dName d + , ifDeclSig = dSignature d + , ifDeclPragmas = dPragmas d + , ifDeclInfix = dInfix d + , ifDeclFixity = dFixity d + , ifDeclDoc = dDoc d + } + +-- | Generate an Iface from a typechecked module. +genIface :: ModuleG mname -> IfaceG mname +genIface m = Iface + { ifModName = mName m + + , ifPublic = IfaceDecls + { ifTySyns = tsPub + , ifNewtypes = ntPub + , ifAbstractTypes = atPub + , ifDecls = dPub + , ifModules = mPub + } + + , ifPrivate = IfaceDecls + { ifTySyns = tsPriv + , ifNewtypes = ntPriv + , ifAbstractTypes = atPriv + , ifDecls = dPriv + , ifModules = mPriv + } + + , ifParams = IfaceParams + { ifParamTypes = mParamTypes m + , ifParamConstraints = mParamConstraints m + , ifParamFuns = mParamFuns m + } + } + where + + (tsPub,tsPriv) = + Map.partitionWithKey (\ qn _ -> qn `isExportedType` mExports m ) + (mTySyns m) + (ntPub,ntPriv) = + Map.partitionWithKey (\ qn _ -> qn `isExportedType` mExports m ) + (mNewtypes m) + + (atPub,atPriv) = + Map.partitionWithKey (\qn _ -> qn `isExportedType` mExports m) + (mPrimTypes m) + + (dPub,dPriv) = + Map.partitionWithKey (\ qn _ -> qn `isExportedBind` mExports m) + $ Map.fromList [ (qn,mkIfaceDecl d) | dg <- mDecls m + , d <- groupDecls dg + , let qn = dName d + ] + + (mPub,mPriv) = + Map.partitionWithKey (\ qn _ -> isExported NSModule qn (mExports m)) + $ mSubModules m + + + + 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 @@ -13,11 +13,30 @@ {-# LANGUAGE RecursiveDo #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BlockArguments #-} module Cryptol.TypeCheck.Monad ( module Cryptol.TypeCheck.Monad , module Cryptol.TypeCheck.InferTypes ) where +import qualified Control.Applicative as A +import qualified Control.Monad.Fail as Fail +import Control.Monad.Fix(MonadFix(..)) +import qualified Data.Map as Map +import qualified Data.Set as Set +import Data.Map (Map) +import Data.Set (Set) +import Data.List(find, foldl') +import Data.List.NonEmpty(NonEmpty((:|))) +import Data.Semigroup(sconcat) +import Data.Maybe(mapMaybe,fromMaybe) +import Data.IORef + +import GHC.Generics (Generic) +import Control.DeepSeq + +import MonadLib hiding (mapM) + import Cryptol.ModuleSystem.Name (FreshM(..),Supply,mkParameter , nameInfo, NameInfo(..),NameSource(..)) @@ -25,6 +44,7 @@ import qualified Cryptol.Parser.AST as P import Cryptol.TypeCheck.AST import Cryptol.TypeCheck.Subst +import Cryptol.TypeCheck.Interface(genIface) import Cryptol.TypeCheck.Unify(mgu, runResult, UnificationError(..)) import Cryptol.TypeCheck.InferTypes import Cryptol.TypeCheck.Error( Warning(..),Error(..) @@ -34,26 +54,9 @@ import qualified Cryptol.TypeCheck.Solver.SMT as SMT import Cryptol.TypeCheck.PP(NameMap) import Cryptol.Utils.PP(pp, (<+>), text,commaSep,brackets) -import Cryptol.Utils.Ident(Ident) +import Cryptol.Utils.Ident(Ident,Namespace(..)) import Cryptol.Utils.Panic(panic) -import qualified Control.Applicative as A -import qualified Control.Monad.Fail as Fail -import Control.Monad.Fix(MonadFix(..)) -import qualified Data.Map as Map -import qualified Data.Set as Set -import Data.Map (Map) -import Data.Set (Set) -import Data.List(find, foldl') -import Data.Maybe(mapMaybe,fromMaybe) -import MonadLib hiding (mapM) - -import Data.IORef - - -import GHC.Generics (Generic) -import Control.DeepSeq - -- | Information needed for type inference. data InferInput = InferInput { inpRange :: Range -- ^ Location of program source @@ -76,7 +79,6 @@ , inpCallStacks :: Bool -- ^ Are we tracking call stacks? - , inpSolverConfig :: SolverConfig -- ^ Options for the constraint solver , inpSearchPath :: [FilePath] -- ^ Where to look for Cryptol theory file. @@ -119,16 +121,21 @@ runInferM :: TVars a => InferInput -> InferM a -> IO (InferOutput a) runInferM info (IM m) = do counter <- newIORef 0 + let env = Map.map ExtVar (inpVars info) + <> Map.map (ExtVar . newtypeConType) (inpNewtypes info) + rec ro <- return RO { iRange = inpRange info - , iVars = Map.map ExtVar (inpVars info) - , iTVars = [] - , iTSyns = fmap mkExternal (inpTSyns info) - , iNewtypes = fmap mkExternal (inpNewtypes info) - , iAbstractTypes = mkExternal <$> inpAbstractTypes info - , iParamTypes = inpParamTypes info - , iParamFuns = inpParamFuns info - , iParamConstraints = inpParamConstraints info + , iVars = env + , iExtScope = (emptyModule ExternalScope) + { mTySyns = inpTSyns info + , mNewtypes = inpNewtypes info + , mPrimTypes = inpAbstractTypes info + , mParamTypes = inpParamTypes info + , mParamFuns = inpParamFuns info + , mParamConstraints = inpParamConstraints info + } + , iTVars = [] , iSolvedHasLazy = iSolvedHas finalRW -- RECURSION , iMonoBinds = inpMonoBinds info , iCallStacks = inpCallStacks info @@ -168,7 +175,6 @@ in pure (InferFailed (computeFreeVarNames ws es1) ws es1) - mkExternal x = (IsExternal, x) rw = RW { iErrors = [] , iWarnings = [] , iSubst = emptySubst @@ -181,6 +187,9 @@ , iSolvedHas = Map.empty , iSupply = inpSupply info + + , iScope = [] + , iBindTypes = mempty } @@ -191,38 +200,28 @@ newtype InferM a = IM { unIM :: ReaderT RO (StateT RW IO) a } -data DefLoc = IsLocal | IsExternal +data ScopeName = ExternalScope + | LocalScope + | SubModule Name + | MTopModule P.ModName + -- | Read-only component of the monad. data RO = RO - { iRange :: Range -- ^ Source code being analysed - , iVars :: Map Name VarType -- ^ Type of variable that are in scope + { iRange :: Range -- ^ Source code being analysed + , iVars :: Map Name VarType + -- ^ Type of variable that are in scope + -- These are only parameters vars that are in recursive component we + -- are checking at the moment. If a var is not there, keep looking in + -- the 'iScope' - {- NOTE: We assume no shadowing between these two, so it does not matter - where we look first. Similarly, we assume no shadowing with - the existential type variable (in RW). See 'checkTShadowing'. -} - , iTVars :: [TParam] -- ^ Type variable that are in scope - , iTSyns :: Map Name (DefLoc, TySyn) -- ^ Type synonyms that are in scope - , iNewtypes :: Map Name (DefLoc, Newtype) - -- ^ Newtype declarations in scope - -- - -- NOTE: type synonyms take precedence over newtype. The reason is - -- that we can define local type synonyms, but not local newtypes. - -- So, either a type-synonym shadows a newtype, or it was declared - -- at the top-level, but then there can't be a newtype with the - -- same name (this should be caught by the renamer). - , iAbstractTypes :: Map Name (DefLoc, AbstractType) - - , iParamTypes :: Map Name ModTParam - -- ^ Parameter types - - , iParamConstraints :: [Located Prop] - -- ^ Constraints on the type parameters - - , iParamFuns :: Map Name ModVParam - -- ^ Parameter functions + , iTVars :: [TParam] -- ^ Type variable that are in scope + , iExtScope :: ModuleG ScopeName + -- ^ These are things we know about, but are not part of the + -- modules we are currently constructing. + -- XXX: this sould probably be an interface , iSolvedHasLazy :: Map Int HasGoalSln -- ^ NOTE: This field is lazy in an important way! It is the @@ -278,9 +277,17 @@ {- ^ Tuple/record projection constraints. The 'Int' is the "name" of the constraint, used so that we can name its solution properly. -} + , iScope :: ![ModuleG ScopeName] + -- ^ Nested scopes we are currently checking, most nested first. + + , iBindTypes :: !(Map Name Schema) + -- ^ Types of variables that we know about. We don't worry about scoping + -- here because we assume the bindings all have different names. + , iSupply :: !Supply } + instance Functor InferM where fmap f (IM m) = IM (fmap f m) @@ -452,10 +459,10 @@ -------------------------------------------------------------------------------- -- | Generate a fresh variable name to be used in a local binding. -newParamName :: Ident -> InferM Name -newParamName x = +newParamName :: Namespace -> Ident -> InferM Name +newParamName ns x = do r <- curRange - liftSupply (mkParameter x r) + liftSupply (mkParameter ns x r) newName :: (NameSeeds -> (a , NameSeeds)) -> InferM a newName upd = IM $ sets $ \s -> let (x,seeds) = upd (iNameSeeds s) @@ -634,17 +641,13 @@ lookupVar x = do mb <- IM $ asks $ Map.lookup x . iVars case mb of - Just t -> return t + Just a -> pure a Nothing -> - do mbNT <- lookupNewtype x - case mbNT of - Just nt -> return (ExtVar (newtypeConType nt)) - Nothing -> - do mbParamFun <- lookupParamFun x - case mbParamFun of - Just pf -> return (ExtVar (mvpType pf)) - Nothing -> panic "lookupVar" [ "Undefined type variable" - , show x] + do mb1 <- Map.lookup x . iBindTypes <$> IM get + case mb1 of + Just a -> pure (ExtVar a) + Nothing -> panic "lookupVar" [ "Undefined vairable" + , show x ] -- | Lookup a type variable. Return `Nothing` if there is no such variable -- in scope, in which case we must be dealing with a type constant. @@ -654,14 +657,14 @@ -- | Lookup the definition of a type synonym. lookupTSyn :: Name -> InferM (Maybe TySyn) -lookupTSyn x = fmap (fmap snd . Map.lookup x) getTSyns +lookupTSyn x = Map.lookup x <$> getTSyns -- | Lookup the definition of a newtype lookupNewtype :: Name -> InferM (Maybe Newtype) -lookupNewtype x = fmap (fmap snd . Map.lookup x) getNewtypes +lookupNewtype x = Map.lookup x <$> getNewtypes lookupAbstractType :: Name -> InferM (Maybe AbstractType) -lookupAbstractType x = fmap (fmap snd . Map.lookup x) getAbstractTypes +lookupAbstractType x = Map.lookup x <$> getAbstractTypes -- | Lookup the kind of a parameter type lookupParamType :: Name -> InferM (Maybe ModTParam) @@ -693,28 +696,28 @@ -- | Returns the type synonyms that are currently in scope. -getTSyns :: InferM (Map Name (DefLoc,TySyn)) -getTSyns = IM $ asks iTSyns +getTSyns :: InferM (Map Name TySyn) +getTSyns = getScope mTySyns -- | Returns the newtype declarations that are in scope. -getNewtypes :: InferM (Map Name (DefLoc,Newtype)) -getNewtypes = IM $ asks iNewtypes +getNewtypes :: InferM (Map Name Newtype) +getNewtypes = getScope mNewtypes -- | Returns the abstract type declarations that are in scope. -getAbstractTypes :: InferM (Map Name (DefLoc,AbstractType)) -getAbstractTypes = IM $ asks iAbstractTypes +getAbstractTypes :: InferM (Map Name AbstractType) +getAbstractTypes = getScope mPrimTypes -- | Returns the parameter functions declarations getParamFuns :: InferM (Map Name ModVParam) -getParamFuns = IM $ asks iParamFuns +getParamFuns = getScope mParamFuns -- | Returns the abstract function declarations getParamTypes :: InferM (Map Name ModTParam) -getParamTypes = IM $ asks iParamTypes +getParamTypes = getScope mParamTypes -- | Constraints on the module's parameters. getParamConstraints :: InferM [Located Prop] -getParamConstraints = IM $ asks iParamConstraints +getParamConstraints = getScope mParamConstraints -- | Get the set of bound type variables that are in scope. getTVars :: InferM (Set Name) @@ -724,8 +727,8 @@ getBoundInScope :: InferM (Set TParam) getBoundInScope = do ro <- IM ask - let params = Set.fromList (map mtpParam (Map.elems (iParamTypes ro))) - bound = Set.fromList (iTVars ro) + params <- Set.fromList . map mtpParam . Map.elems <$> getParamTypes + let bound = Set.fromList (iTVars ro) return $! Set.union params bound -- | Retrieve the value of the `mono-binds` option. @@ -740,12 +743,14 @@ need to worry about where we lookup things (i.e., in the variable or type synonym environment. -} +-- XXX: this should be done in renamer checkTShadowing :: String -> Name -> InferM () checkTShadowing this new = - do ro <- IM ask + do tsyns <- getTSyns + ro <- IM ask rw <- IM get let shadowed = - do _ <- Map.lookup new (iTSyns ro) + do _ <- Map.lookup new tsyns return "type synonym" `mplus` do guard (new `elem` mapMaybe tpName (iTVars ro)) @@ -760,7 +765,6 @@ recordError (TypeShadowing this new that) - -- | The sub-computation is performed with the given type parameter in scope. withTParam :: TParam -> InferM a -> InferM a withTParam p (IM m) = @@ -772,32 +776,148 @@ withTParams :: [TParam] -> InferM a -> InferM a withTParams ps m = foldr withTParam m ps + +-- | Execute the given computation in a new top scope. +-- The sub-computation would typically be validating a module. +newScope :: ScopeName -> InferM () +newScope nm = IM $ sets_ \rw -> rw { iScope = emptyModule nm : iScope rw } + +newLocalScope :: InferM () +newLocalScope = newScope LocalScope + +newSubmoduleScope :: Name -> [Import] -> ExportSpec Name -> InferM () +newSubmoduleScope x is e = + do newScope (SubModule x) + updScope \m -> m { mImports = is, mExports = e } + +newModuleScope :: P.ModName -> [Import] -> ExportSpec Name -> InferM () +newModuleScope x is e = + do newScope (MTopModule x) + updScope \m -> m { mImports = is, mExports = e } + +-- | Update the current scope (first in the list). Assumes there is one. +updScope :: (ModuleG ScopeName -> ModuleG ScopeName) -> InferM () +updScope f = IM $ sets_ \rw -> rw { iScope = upd (iScope rw) } + where + upd r = + case r of + [] -> panic "updTopScope" [ "No top scope" ] + s : more -> f s : more + +endLocalScope :: InferM ([DeclGroup], Map Name TySyn) +endLocalScope = + IM $ sets \rw -> + case iScope rw of + x : xs | LocalScope <- mName x -> + ( (reverse (mDecls x), mTySyns x), rw { iScope = xs }) + + _ -> panic "endLocalScope" ["Missing local scope"] + +endSubmodule :: InferM () +endSubmodule = + IM $ sets_ \rw -> + case iScope rw of + x@Module { mName = SubModule m } : y : more -> rw { iScope = z : more } + where + x1 = x { mName = m } + iface = genIface x1 + me = if isParametrizedModule x1 then Map.singleton m x1 else mempty + z = y { mImports = mImports x ++ mImports y -- just for deps + , mSubModules = Map.insert m iface (mSubModules y) + + , mTySyns = mTySyns x <> mTySyns y + , mNewtypes = mNewtypes x <> mNewtypes y + , mPrimTypes = mPrimTypes x <> mPrimTypes y + , mDecls = mDecls x <> mDecls y + , mFunctors = me <> mFunctors x <> mFunctors y + } + + _ -> panic "endSubmodule" [ "Not a submodule" ] + + +endModule :: InferM Module +endModule = + IM $ sets \rw -> + case iScope rw of + [ x ] | MTopModule m <- mName x -> + ( x { mName = m, mDecls = reverse (mDecls x) } + , rw { iScope = [] } + ) + _ -> panic "endModule" [ "Not a single top module" ] + +endModuleInstance :: InferM () +endModuleInstance = + IM $ sets_ \rw -> + case iScope rw of + [ x ] | MTopModule _ <- mName x -> rw { iScope = [] } + _ -> panic "endModuleInstance" [ "Not single top module" ] + + +-- | Get an environment combining all nested scopes. +getScope :: Semigroup a => (ModuleG ScopeName -> a) -> InferM a +getScope f = + do ro <- IM ask + rw <- IM get + pure (sconcat (f (iExtScope ro) :| map f (iScope rw))) + +addDecls :: DeclGroup -> InferM () +addDecls ds = + do updScope \r -> r { mDecls = ds : mDecls r } + IM $ sets_ \rw -> rw { iBindTypes = new rw } + where + add d = Map.insert (dName d) (dSignature d) + new rw = foldr add (iBindTypes rw) (groupDecls ds) + -- | The sub-computation is performed with the given type-synonym in scope. -withTySyn :: TySyn -> InferM a -> InferM a -withTySyn t (IM m) = +addTySyn :: TySyn -> InferM () +addTySyn t = do let x = tsName t checkTShadowing "synonym" x - IM $ mapReader (\r -> r { iTSyns = Map.insert x (IsLocal,t) (iTSyns r) }) m + updScope \r -> r { mTySyns = Map.insert x t (mTySyns r) } -withNewtype :: Newtype -> InferM a -> InferM a -withNewtype t (IM m) = - IM $ mapReader - (\r -> r { iNewtypes = Map.insert (ntName t) (IsLocal,t) - (iNewtypes r) }) m +addNewtype :: Newtype -> InferM () +addNewtype t = + do updScope \r -> r { mNewtypes = Map.insert (ntName t) t (mNewtypes r) } + IM $ sets_ \rw -> rw { iBindTypes = Map.insert (ntName t) + (newtypeConType t) + (iBindTypes rw) } -withPrimType :: AbstractType -> InferM a -> InferM a -withPrimType t (IM m) = - IM $ mapReader - (\r -> r { iAbstractTypes = Map.insert (atName t) (IsLocal,t) - (iAbstractTypes r) }) m +addPrimType :: AbstractType -> InferM () +addPrimType t = + updScope \r -> + r { mPrimTypes = Map.insert (atName t) t (mPrimTypes r) } +addParamType :: ModTParam -> InferM () +addParamType a = + updScope \r -> r { mParamTypes = Map.insert (mtpName a) a (mParamTypes r) } -withParamType :: ModTParam -> InferM a -> InferM a -withParamType a (IM m) = - IM $ mapReader - (\r -> r { iParamTypes = Map.insert (mtpName a) a (iParamTypes r) }) - m +-- | The sub-computation is performed with the given abstract function in scope. +addParamFun :: ModVParam -> InferM () +addParamFun x = + do updScope \r -> r { mParamFuns = Map.insert (mvpName x) x (mParamFuns r) } + IM $ sets_ \rw -> rw { iBindTypes = Map.insert (mvpName x) (mvpType x) + (iBindTypes rw) } +-- | Add some assumptions for an entire module +addParameterConstraints :: [Located Prop] -> InferM () +addParameterConstraints ps = + updScope \r -> r { mParamConstraints = ps ++ mParamConstraints r } + + + + +-- | Perform the given computation in a new scope (i.e., the subcomputation +-- may use existential type variables). This is a different kind of scope +-- from the nested modules one. +inNewScope :: InferM a -> InferM a +inNewScope m = + do curScopes <- iExistTVars <$> IM get + IM $ sets_ $ \s -> s { iExistTVars = Map.empty : curScopes } + a <- m + IM $ sets_ $ \s -> s { iExistTVars = curScopes } + return a + + -- | The sub-computation is performed with the given variable in scope. withVarType :: Name -> VarType -> InferM a -> InferM a withVarType x s (IM m) = @@ -809,19 +929,6 @@ withVar :: Name -> Schema -> InferM a -> InferM a withVar x s = withVarType x (ExtVar s) --- | The sub-computation is performed with the given abstract function in scope. -withParamFuns :: [ModVParam] -> InferM a -> InferM a -withParamFuns xs (IM m) = - IM $ mapReader (\r -> r { iParamFuns = foldr add (iParamFuns r) xs }) m - where - add x = Map.insert (mvpName x) x - --- | Add some assumptions for an entire module -withParameterConstraints :: [Located Prop] -> InferM a -> InferM a -withParameterConstraints ps (IM m) = - IM $ mapReader (\r -> r { iParamConstraints = ps ++ iParamConstraints r }) m - - -- | The sub-computation is performed with the given variables in scope. withMonoType :: (Name,Located Type) -> InferM a -> InferM a withMonoType (x,lt) = withVar x (Forall [] [] (thing lt)) @@ -829,25 +936,6 @@ -- | The sub-computation is performed with the given variables in scope. withMonoTypes :: Map Name (Located Type) -> InferM a -> InferM a withMonoTypes xs m = foldr withMonoType m (Map.toList xs) - --- | The sub-computation is performed with the given type synonyms --- and variables in scope. -withDecls :: ([TySyn], Map Name Schema) -> InferM a -> InferM a -withDecls (ts,vs) m = foldr withTySyn (foldr add m (Map.toList vs)) ts - where - add (x,t) = withVar x t - --- | Perform the given computation in a new scope (i.e., the subcomputation --- may use existential type variables). -inNewScope :: InferM a -> InferM a -inNewScope m = - do curScopes <- iExistTVars <$> IM get - IM $ sets_ $ \s -> s { iExistTVars = Map.empty : curScopes } - a <- m - IM $ sets_ $ \s -> s { iExistTVars = curScopes } - return a - - -------------------------------------------------------------------------------- -- Kind checking 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 @@ -17,18 +17,30 @@ , ShowParseable(..) ) where +import Data.Void +import Prettyprinter + import Cryptol.TypeCheck.AST import Cryptol.Utils.Ident (Ident,unpackIdent) import Cryptol.Utils.RecordMap (canonicalFields) import Cryptol.Parser.AST ( Located(..)) import Cryptol.ModuleSystem.Name -import Text.PrettyPrint hiding ((<>)) -import qualified Text.PrettyPrint as PP ((<>)) + +infixl 5 $$ +($$) :: Doc a -> Doc a -> Doc a +($$) x y = sep [x, y] + +text :: String -> Doc a +text = pretty + +int :: Int -> Doc a +int = pretty + -- ShowParseable prints out a cryptol program in a way that it's parseable by Coq (and likely other things) -- Used mainly for reasoning about the semantics of cryptol programs in Coq (https://github.com/GaloisInc/cryptol-semantics) class ShowParseable t where - showParseable :: t -> Doc + showParseable :: t -> Doc Void instance ShowParseable Expr where showParseable (ELocated _ e) = showParseable e -- TODO? emit range information @@ -53,7 +65,7 @@ showParseable (EProofApp e) = showParseable e --"(EProofApp " ++ showParseable e ++ ")" instance (ShowParseable a, ShowParseable b) => ShowParseable (a,b) where - showParseable (x,y) = parens (showParseable x PP.<> comma PP.<> showParseable y) + showParseable (x,y) = parens (showParseable x <> comma <> showParseable y) instance ShowParseable Int where showParseable i = int i @@ -105,11 +117,11 @@ showParseable l = showParseable (thing l) instance ShowParseable TParam where - showParseable tp = parens (text (show (tpUnique tp)) PP.<> comma PP.<> maybeNameDoc (tpName tp)) + showParseable tp = parens (text (show (tpUnique tp)) <> comma <> maybeNameDoc (tpName tp)) -maybeNameDoc :: Maybe Name -> Doc -maybeNameDoc Nothing = doubleQuotes empty +maybeNameDoc :: Maybe Name -> Doc Void +maybeNameDoc Nothing = dquotes mempty maybeNameDoc (Just n) = showParseable (nameIdent n) instance ShowParseable Name where - showParseable n = parens (text (show (nameUnique n)) PP.<> comma PP.<> showParseable (nameIdent n)) + showParseable n = parens (text (show (nameUnique n)) <> comma <> showParseable (nameIdent n)) diff --git a/src/Cryptol/TypeCheck/SimpType.hs b/src/Cryptol/TypeCheck/SimpType.hs --- a/src/Cryptol/TypeCheck/SimpType.hs +++ b/src/Cryptol/TypeCheck/SimpType.hs @@ -182,7 +182,6 @@ tCeilDiv :: Type -> Type -> Type tCeilDiv x y | Just t <- tOp TCCeilDiv (op2 nCeilDiv) [x,y] = t - | tIsInf x = bad | tIsInf y = bad | Just 0 <- tIsNum y = bad | otherwise = tf2 TCCeilDiv x y @@ -191,7 +190,6 @@ tCeilMod :: Type -> Type -> Type tCeilMod x y | Just t <- tOp TCCeilMod (op2 nCeilMod) [x,y] = t - | tIsInf x = bad | tIsInf y = bad | Just 0 <- tIsNum x = bad | otherwise = tf2 TCCeilMod x y @@ -264,6 +262,12 @@ maxK (Nat 0) t = t maxK (Nat k) t + -- max 1 t ~> t, if t = a ^ b && a >= 1 + | k == 1 + , TCon (TF TCExp) [a,_] <- t' + , Just base <- tIsNat' a + , base >= Nat 1 = t + | TCon (TF TCAdd) [a,b] <- t' , Just n <- tIsNum a = if k <= n then t @@ -285,6 +289,13 @@ tWidth :: Type -> Type tWidth x | Just t <- tOp TCWidth (total (op1 nWidth)) [x] = t + + -- width (2^n - 1) = n + | TCon (TF TCSub) [a,b] <- tNoUser x + , Just 1 <- tIsNum b + , TCon (TF TCExp) [p,q] <- tNoUser a + , Just 2 <- tIsNum p = q + | otherwise = tf1 TCWidth x tLenFromThenTo :: Type -> Type -> Type -> Type diff --git a/src/Cryptol/TypeCheck/SimpleSolver.hs b/src/Cryptol/TypeCheck/SimpleSolver.hs --- a/src/Cryptol/TypeCheck/SimpleSolver.hs +++ b/src/Cryptol/TypeCheck/SimpleSolver.hs @@ -30,8 +30,7 @@ SolvedIf ps -> dbg msg $ pAnd (map (simplify ctxt) ps) where msg = case ps of [] -> text "solved:" <+> pp p - _ -> pp p <+> text "~~~>" <+> - vcat (punctuate comma (map pp ps)) + _ -> pp p <+> text "~~~>" <+> commaSep (map pp ps) where dbg msg x diff --git a/src/Cryptol/TypeCheck/Solver/InfNat.hs b/src/Cryptol/TypeCheck/Solver/InfNat.hs --- a/src/Cryptol/TypeCheck/Solver/InfNat.hs +++ b/src/Cryptol/TypeCheck/Solver/InfNat.hs @@ -122,23 +122,22 @@ nMod (Nat x) Inf = Just (Nat x) -- inf * 0 + x = 0 + x -- | @nCeilDiv msgLen blockSize@ computes the least @n@ such that --- @msgLen <= blockSize * n@. It is undefined when @blockSize = 0@. --- It is also undefined when either input is infinite; perhaps this --- could be relaxed later. +-- @msgLen <= blockSize * n@. It is undefined when @blockSize = 0@, +-- or when @blockSize = inf@. @inf@ divided by any positive +-- finite value is @inf@. nCeilDiv :: Nat' -> Nat' -> Maybe Nat' +nCeilDiv _ Inf = Nothing nCeilDiv _ (Nat 0) = Nothing -nCeilDiv Inf _ = Nothing -nCeilDiv (Nat _) Inf = Nothing +nCeilDiv Inf (Nat _) = Just Inf nCeilDiv (Nat x) (Nat y) = Just (Nat (- div (- x) y)) -- | @nCeilMod msgLen blockSize@ computes the least @k@ such that --- @blockSize@ divides @msgLen + k@. It is undefined when @blockSize = 0@. --- It is also undefined when either input is infinite; perhaps this --- could be relaxed later. +-- @blockSize@ divides @msgLen + k@. It is undefined when @blockSize = 0@ +-- or @blockSize = inf@. @inf@ modulus any positive finite value is @0@. nCeilMod :: Nat' -> Nat' -> Maybe Nat' +nCeilMod _ Inf = Nothing nCeilMod _ (Nat 0) = Nothing -nCeilMod Inf _ = Nothing -nCeilMod (Nat _) Inf = Nothing +nCeilMod Inf (Nat _) = Just (Nat 0) nCeilMod (Nat x) (Nat y) = Just (Nat (mod (- x) y)) -- | Rounds up. diff --git a/src/Cryptol/TypeCheck/Solver/Numeric/Fin.hs b/src/Cryptol/TypeCheck/Solver/Numeric/Fin.hs --- a/src/Cryptol/TypeCheck/Solver/Numeric/Fin.hs +++ b/src/Cryptol/TypeCheck/Solver/Numeric/Fin.hs @@ -56,7 +56,7 @@ i2 = typeInterval varInfo t2 - (TCDiv, [t1,_]) -> SolvedIf [ pFin t1 ] + (TCDiv, [_,_]) -> SolvedIf [] (TCMod, [_,_]) -> SolvedIf [] -- fin (x ^ y) @@ -85,7 +85,7 @@ (TCMax, [t1,t2]) -> SolvedIf [ pFin t1, pFin t2 ] (TCWidth, [t1]) -> SolvedIf [ pFin t1 ] - (TCCeilDiv, [_,_]) -> SolvedIf [] + (TCCeilDiv, [t1,_]) -> SolvedIf [ pFin t1 ] (TCCeilMod, [_,_]) -> SolvedIf [] (TCLenFromThenTo,[_,_,_]) -> SolvedIf [] 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 @@ -15,10 +15,12 @@ module Cryptol.TypeCheck.Solver.SMT ( -- * Setup Solver + , SolverConfig , withSolver , startSolver , stopSolver , isNumeric + , resetSolver -- * Debugging , debugBlock @@ -53,7 +55,7 @@ import Cryptol.TypeCheck.TypePat hiding ((~>),(~~>)) import Cryptol.TypeCheck.Subst(Subst) import Cryptol.Utils.Panic -import Cryptol.Utils.PP -- ( Doc ) +import Cryptol.Utils.PP ( Doc, pp ) @@ -67,18 +69,22 @@ -- ^ For debugging } +setupSolver :: Solver -> SolverConfig -> IO () +setupSolver s cfg = do + _ <- SMT.setOptionMaybe (solver s) ":global-decls" "false" + loadTcPrelude s (solverPreludePath cfg) + -- | Start a fresh solver instance -startSolver :: SolverConfig -> IO Solver -startSolver SolverConfig { .. } = - do logger <- if solverVerbose > 0 then SMT.newLogger 0 +startSolver :: IO () -> SolverConfig -> IO Solver +startSolver onExit sCfg = + do logger <- if (solverVerbose sCfg) > 0 then SMT.newLogger 0 else return quietLogger - let smtDbg = if solverVerbose > 1 then Just logger else Nothing - solver <- SMT.newSolver solverPath solverArgs smtDbg - _ <- SMT.setOptionMaybe solver ":global-decls" "false" - -- SMT.setLogic solver "QF_LIA" - let sol = Solver { .. } - loadTcPrelude sol solverPreludePath + let smtDbg = if (solverVerbose sCfg) > 1 then Just logger else Nothing + solver <- SMT.newSolverNotify + (solverPath sCfg) (solverArgs sCfg) smtDbg (Just (const onExit)) + let sol = Solver solver logger + setupSolver sol sCfg return sol where @@ -93,9 +99,14 @@ stopSolver :: Solver -> IO () stopSolver s = void $ SMT.stop (solver s) +resetSolver :: Solver -> SolverConfig -> IO () +resetSolver s sCfg = do + _ <- SMT.simpleCommand (solver s) ["reset"] + setupSolver s sCfg + -- | Execute a computation with a fresh solver instance. -withSolver :: SolverConfig -> (Solver -> IO a) -> IO a -withSolver cfg = bracket (startSolver cfg) stopSolver +withSolver :: IO () -> SolverConfig -> (Solver -> IO a) -> IO a +withSolver onExit cfg = bracket (startSolver onExit cfg) stopSolver -- | Load the definitions used for type checking. loadTcPrelude :: Solver -> [FilePath] {- ^ Search in this paths -} -> IO () diff --git a/src/Cryptol/TypeCheck/Solver/Selector.hs b/src/Cryptol/TypeCheck/Solver/Selector.hs --- a/src/Cryptol/TypeCheck/Solver/Selector.hs +++ b/src/Cryptol/TypeCheck/Solver/Selector.hs @@ -15,7 +15,7 @@ , newParamName ) import Cryptol.TypeCheck.Subst (listParamSubst, apSubst) -import Cryptol.Utils.Ident (Ident, packIdent) +import Cryptol.Utils.Ident (Ident, packIdent,Namespace(..)) import Cryptol.Utils.Panic(panic) import Cryptol.Utils.RecordMap @@ -163,9 +163,9 @@ -- xs.s ~~> [ x.s | x <- xs ] -- { xs | s = ys } ~~> [ { x | s = y } | x <- xs | y <- ys ] liftSeq len el = - do x1 <- newParamName (packIdent "x") - x2 <- newParamName (packIdent "x") - y2 <- newParamName (packIdent "y") + do x1 <- newParamName NSValue (packIdent "x") + x2 <- newParamName NSValue (packIdent "x") + y2 <- newParamName NSValue (packIdent "y") case tNoUser innerT of TCon _ [_,eli] -> do d <- mkSelSln s el eli @@ -187,8 +187,8 @@ -- f.s ~~> \x -> (f x).s -- { f | s = g } ~~> \x -> { f x | s = g x } liftFun t1 t2 = - do x1 <- newParamName (packIdent "x") - x2 <- newParamName (packIdent "x") + do x1 <- newParamName NSValue (packIdent "x") + x2 <- newParamName NSValue (packIdent "x") case tNoUser innerT of TCon _ [_,inT] -> do d <- mkSelSln s t2 inT diff --git a/src/Cryptol/TypeCheck/Subst.hs b/src/Cryptol/TypeCheck/Subst.hs --- a/src/Cryptol/TypeCheck/Subst.hs +++ b/src/Cryptol/TypeCheck/Subst.hs @@ -336,6 +336,14 @@ (cons k) } +instance TVars a => TVars (Map.Map k a) where + -- NB, strict map + apSubst su m = Map.map (apSubst su) m + +instance TVars TySyn where + apSubst su (TySyn nm params props t doc) = + (\props' t' -> TySyn nm params props' t' doc) + !$ apSubst su props !$ apSubst su t {- | This instance does not need to worry about bound variable capture, because we rely on the 'Subst' datatype invariant to ensure diff --git a/src/Cryptol/TypeCheck/TCon.hs b/src/Cryptol/TypeCheck/TCon.hs --- a/src/Cryptol/TypeCheck/TCon.hs +++ b/src/Cryptol/TypeCheck/TCon.hs @@ -41,9 +41,9 @@ builtInType nm = case M.nameInfo nm of M.Declared m _ - | m == preludeName -> Map.lookup (M.nameIdent nm) builtInTypes - | m == floatName -> Map.lookup (M.nameIdent nm) builtInFloat - | m == arrayName -> Map.lookup (M.nameIdent nm) builtInArray + | m == M.TopModule preludeName -> Map.lookup (M.nameIdent nm) builtInTypes + | m == M.TopModule floatName -> Map.lookup (M.nameIdent nm) builtInFloat + | m == M.TopModule arrayName -> Map.lookup (M.nameIdent nm) builtInArray _ -> Nothing where 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 @@ -2,6 +2,11 @@ {-# Language FlexibleInstances, FlexibleContexts #-} {-# Language PatternGuards #-} {-# Language OverloadedStrings #-} +{-| This module contains types related to typechecking and the output of the +typechecker. In particular, it should contain the types needed by +interface files (see 'Crytpol.ModuleSystem.Interface'), which are (kind of) +the output of the typechker. +-} module Cryptol.TypeCheck.Type ( module Cryptol.TypeCheck.Type , module Cryptol.TypeCheck.TCon @@ -32,8 +37,40 @@ infix 4 =#=, >== infixr 5 `tFun` +-- | A type parameter of a module. +data ModTParam = ModTParam + { mtpName :: Name + , mtpKind :: Kind + , mtpNumber :: !Int -- ^ The number of the parameter in the module + -- This is used when we move parameters from the module + -- level to individual declarations + -- (type synonyms in particular) + , mtpDoc :: Maybe Text + } deriving (Show,Generic,NFData) +mtpParam :: ModTParam -> TParam +mtpParam mtp = TParam { tpUnique = nameUnique (mtpName mtp) + , tpKind = mtpKind mtp + , tpFlav = TPModParam (mtpName mtp) + , tpInfo = desc + } + where desc = TVarInfo { tvarDesc = TVFromModParam (mtpName mtp) + , tvarSource = nameLoc (mtpName mtp) + } + +-- | A value parameter of a module. +data ModVParam = ModVParam + { mvpName :: Name + , mvpType :: Schema + , mvpDoc :: Maybe Text + , mvpFixity :: Maybe Fixity + } deriving (Show,Generic,NFData) + + + + + -- | The types of polymorphic values. data Schema = Forall { sVars :: [TParam], sProps :: [Prop], sType :: Type } deriving (Eq, Show, Generic, NFData) @@ -893,17 +930,17 @@ instance PP (WithNames Schema) where ppPrec _ (WithNames s ns) | null (sVars s) && null (sProps s) = body - | otherwise = hang (vars <+> props) 2 body + | otherwise = nest 2 (sep (vars ++ props ++ [body])) where body = ppWithNames ns1 (sType s) vars = case sVars s of - [] -> empty - vs -> braces $ commaSep $ map (ppWithNames ns1) vs + [] -> [] + vs -> [nest 1 (braces (commaSepFill (map (ppWithNames ns1) vs)))] props = case sProps s of - [] -> empty - ps -> parens (commaSep (map (ppWithNames ns1) ps)) <+> text "=>" + [] -> [] + ps -> [nest 1 (parens (commaSepFill (map (ppWithNames ns1) ps))) <+> text "=>"] ns1 = addTNames (sVars s) ns @@ -912,17 +949,20 @@ instance PP (WithNames TySyn) where ppPrec _ (WithNames ts ns) = - text "type" <+> ctr <+> lhs <+> char '=' <+> ppWithNames ns1 (tsDef ts) + 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" - _ -> empty + 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 + [ppWithNames ns1 x, pp (nameIdent n), ppWithNames ns1 y] (_, ps) -> - pp n <+> sep (map (ppWithNames ns1) ps) + [pp n] ++ map (ppWithNames ns1) ps instance PP Newtype where ppPrec = ppWithNamesPrec IntMap.empty @@ -948,8 +988,8 @@ ppPrec prec ty0@(WithNames ty nmMap) = case ty of TVar a -> ppWithNames nmMap a - TNewtype nt ts -> optParens (prec > 3) $ pp (ntName nt) <+> fsep (map (go 5) ts) - TRec fs -> braces $ fsep $ punctuate comma + TNewtype nt ts -> optParens (prec > 3) $ fsep (pp (ntName nt) : map (go 5) ts) + TRec fs -> ppRecord [ pp l <+> text ":" <+> go 0 t | (l,t) <- displayFields fs ] _ | Just tinf <- isTInfix ty0 -> optParens (prec > 2) @@ -957,14 +997,13 @@ TUser c ts t -> withNameDisp $ \disp -> - case nameInfo c of - Declared m _ - | NotInScope <- getNameFormat m (nameIdent c) disp -> + case asOrigName c of + Just og | NotInScope <- getNameFormat og disp -> go prec t -- unfold type synonym if not in scope _ -> case ts of [] -> pp c - _ -> optParens (prec > 3) $ pp c <+> fsep (map (go 5) ts) + _ -> optParens (prec > 3) $ fsep (pp c : map (go 5) ts) TCon (TC tc) ts -> case (tc,ts) of @@ -983,9 +1022,9 @@ (TCFun, [t1,t2]) -> optParens (prec > 1) $ go 2 t1 <+> text "->" <+> go 1 t2 - (TCTuple _, fs) -> parens $ fsep $ punctuate comma $ map (go 0) fs + (TCTuple _, fs) -> ppTuple $ map (go 0) fs - (_, _) -> optParens (prec > 3) $ pp tc <+> fsep (map (go 5) ts) + (_, _) -> optParens (prec > 3) $ fsep (pp tc : (map (go 5) ts)) TCon (PC pc) ts -> case (pc,ts) of @@ -996,7 +1035,7 @@ (PPrime, [t1]) -> optParens (prec > 3) $ text "prime" <+> (go 5 t1) (PHas x, [t1,t2]) -> ppSelector x <+> text "of" <+> go 0 t1 <+> text "is" <+> go 0 t2 - (PAnd, [t1,t2]) -> parens (commaSep (map (go 0) (t1 : pSplitAnd t2))) + (PAnd, [t1,t2]) -> nest 1 (parens (commaSepFill (map (go 0) (t1 : pSplitAnd t2)))) (PRing, [t1]) -> pp pc <+> go 5 t1 (PField, [t1]) -> pp pc <+> go 5 t1 @@ -1008,10 +1047,9 @@ (PLiteral, [t1,t2]) -> pp pc <+> go 5 t1 <+> go 5 t2 (PLiteralLessThan, [t1,t2]) -> pp pc <+> go 5 t1 <+> go 5 t2 - (_, _) -> optParens (prec > 3) $ pp pc <+> fsep (map (go 5) ts) + (_, _) -> optParens (prec > 3) $ fsep (pp pc : map (go 5) ts) - TCon f ts -> optParens (prec > 3) - $ pp f <+> fsep (map (go 5) ts) + TCon f ts -> optParens (prec > 3) $ fsep (pp f : map (go 5) ts) where go p t = ppWithNamesPrec nmMap p t @@ -1076,7 +1114,7 @@ TypeParamInstPos f n -> mk (sh f ++ "_" ++ show n) DefinitionOf x -> case nameInfo x of - Declared m SystemName | m == exprModName -> mk "it" + Declared m SystemName | m == TopModule exprModName -> mk "it" _ -> using x LenOfCompGen -> mk "n" GeneratorOfListComp -> "seq" @@ -1100,19 +1138,18 @@ ppPrec n t = ppWithNamesPrec IntMap.empty n t instance PP TVarInfo where - ppPrec _ tvinfo = pp (tvarDesc tvinfo) <+> loc + ppPrec _ tvinfo = hsep $ [pp (tvarDesc tvinfo)] ++ loc where - loc = if rng == emptyRange then empty else "at" <+> pp rng + loc = if rng == emptyRange then [] else ["at" <+> pp rng] rng = tvarSource tvinfo instance PP ArgDescr where - ppPrec _ ad = which <+> "argument" <+> ofFun + ppPrec _ ad = hsep ([which, "argument"] ++ ofFun) where which = maybe "function" ordinal (argDescrNumber ad) ofFun = case argDescrFun ad of - Nothing -> empty - Just f -> "of" <+> pp f - + Nothing -> [] + Just f -> ["of" <+> pp f] instance PP TypeSource where diff --git a/src/Cryptol/TypeCheck/TypeOf.hs b/src/Cryptol/TypeCheck/TypeOf.hs --- a/src/Cryptol/TypeCheck/TypeOf.hs +++ b/src/Cryptol/TypeCheck/TypeOf.hs @@ -54,8 +54,12 @@ polymorphic = case fastSchemaOf tyenv expr of Forall [] [] ty -> ty - _ -> panic "Cryptol.TypeCheck.TypeOf.fastTypeOf" - [ "unexpected polymorphic type" ] + s@Forall {} -> panic "Cryptol.TypeCheck.TypeOf.fastTypeOf" + [ "unexpected polymorphic type in expression:" + , pretty expr + , "with schema:" + , pretty s + ] fastSchemaOf :: Map Name Schema -> Expr -> Schema fastSchemaOf tyenv expr = @@ -124,13 +128,32 @@ -- | Yields the return type of the selector on the given argument type. typeSelect :: Type -> Selector -> Type + +-- Selectors push inside the definition of type aliases typeSelect (TUser _ _ ty) sel = typeSelect ty sel + +-- Tuple selector applied to a tuple typeSelect (tIsTuple -> Just ts) (TupleSel i _) | i < length ts = ts !! i + +-- Record selector applied to a record typeSelect (TRec fields) (RecordSel n _) | Just ty <- lookupField n fields = ty + +-- Record selector applied to a newtype +typeSelect (TNewtype nt args) (RecordSel n _) + | Just ty <- lookupField n (ntFields nt) + = plainSubst (listParamSubst (zip (ntParams nt) args)) ty + +-- List selector applied to a sequence typeSelect (tIsSeq -> Just (_, a)) ListSel{} = a + +-- Tuple selectors and record selectors lift pointwise over sequences typeSelect (tIsSeq -> Just (n, a)) sel@TupleSel{} = tSeq n (typeSelect a sel) typeSelect (tIsSeq -> Just (n, a)) sel@RecordSel{} = tSeq n (typeSelect a sel) + +-- Selectors lift pointwise over functions +typeSelect (tIsFun -> Just (a, b)) sel = tFun a (typeSelect b sel) + typeSelect ty _ = panic "Cryptol.TypeCheck.TypeOf.typeSelect" - [ "cannot apply selector to value of type", render (pp ty) ] + [ "cannot apply selector to value of type", show (pp ty) ] 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 @@ -7,10 +7,17 @@ -- Portability : portable {-# LANGUAGE DeriveGeneric, OverloadedStrings #-} +{-# LANGUAGE DeriveAnyClass #-} module Cryptol.Utils.Ident ( -- * Module names - ModName + ModPath(..) + , apPathRoot + , modPathCommon + , topModuleFor + , modPathSplit + + , ModName , modNameToText , textToModName , modNameChunks @@ -41,6 +48,13 @@ , identText , modParamIdent + -- * Namespaces + , Namespace(..) + , allNamespaces + + -- * Original names + , OrigName(..) + -- * Identifiers for primitives , PrimIdent(..) , prelPrim @@ -58,7 +72,64 @@ import GHC.Generics (Generic) --- | Module names are just text. +-------------------------------------------------------------------------------- + +-- | Namespaces for names +data Namespace = NSValue | NSType | NSModule + deriving (Generic,Show,NFData,Eq,Ord,Enum,Bounded) + +allNamespaces :: [Namespace] +allNamespaces = [ minBound .. maxBound ] + +-- | Idnetifies a possibly nested module +data ModPath = TopModule ModName + | Nested ModPath Ident + deriving (Eq,Ord,Show,Generic,NFData) + +apPathRoot :: (ModName -> ModName) -> ModPath -> ModPath +apPathRoot f path = + case path of + TopModule m -> TopModule (f m) + Nested p q -> Nested (apPathRoot f p) q + +topModuleFor :: ModPath -> ModName +topModuleFor m = + case m of + TopModule x -> x + Nested p _ -> topModuleFor p + +-- | Compute a common prefix between two module paths, if any. +-- This is basically "anti-unification" of the two paths, where we +-- compute the longest common prefix, and the remaining differences for +-- each module. +modPathCommon :: ModPath -> ModPath -> Maybe (ModPath, [Ident], [Ident]) +modPathCommon p1 p2 + | top1 == top2 = Just (findCommon (TopModule top1) as bs) + | otherwise = Nothing + where + (top1,as) = modPathSplit p1 + (top2,bs) = modPathSplit p2 + + findCommon com xs ys = + case (xs,ys) of + (x:xs',y:ys') | x == y -> findCommon (Nested com x) xs' ys' + _ -> (com, xs, ys) + +modPathSplit :: ModPath -> (ModName, [Ident]) +modPathSplit p0 = (top,reverse xs) + where + (top,xs) = go p0 + go p = + case p of + TopModule a -> (a, []) + Nested b i -> (a, i:bs) + where (a,bs) = go b + + + + +-------------------------------------------------------------------------------- +-- | Top-level Module names are just text. data ModName = ModName T.Text deriving (Eq,Ord,Show,Generic) @@ -135,6 +206,15 @@ exprModName :: ModName exprModName = packModName [""] + + +-------------------------------------------------------------------------------- +-- | Identifies an entitiy +data OrigName = OrigName + { ogNamespace :: Namespace + , ogModule :: ModPath + , ogName :: Ident + } deriving (Eq,Ord,Show,Generic,NFData) -------------------------------------------------------------------------------- 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 @@ -18,23 +18,21 @@ import Control.DeepSeq import Control.Monad (mplus) import Data.Maybe (fromMaybe) -import qualified Data.Semigroup as S import Data.String (IsString(..)) import qualified Data.Text as T +import Data.Void (Void) import GHC.Generics (Generic) -import qualified Text.PrettyPrint as PJ - -import Prelude () -import Prelude.Compat - +import qualified Prettyprinter as PP +import qualified Prettyprinter.Render.String as PP -- | How to pretty print things when evaluating data PPOpts = PPOpts - { useAscii :: Bool - , useBase :: Int - , useInfLength :: Int - , useFPBase :: Int - , useFPFormat :: PPFloatFormat + { useAscii :: Bool + , useBase :: Int + , useInfLength :: Int + , useFPBase :: Int + , useFPFormat :: PPFloatFormat + , useFieldOrder :: FieldOrder } deriving Show @@ -51,11 +49,14 @@ | AutoExponent -- ^ Only show exponent when needed deriving Show +data FieldOrder = DisplayOrder | CanonicalOrder deriving (Bounded, Enum, Eq, Ord, Read, Show) + defaultPPOpts :: PPOpts defaultPPOpts = PPOpts { useAscii = False, useBase = 10, useInfLength = 5 , useFPBase = 16 , useFPFormat = FloatFree AutoExponent + , useFieldOrder = DisplayOrder } @@ -66,21 +67,21 @@ that the display has no opinion on how this name should be displayed, and some other display should be tried out. -} data NameDisp = EmptyNameDisp - | NameDisp (ModName -> Ident -> Maybe NameFormat) + | NameDisp (OrigName -> Maybe NameFormat) deriving (Generic, NFData) instance Show NameDisp where show _ = "" -instance S.Semigroup NameDisp where - NameDisp f <> NameDisp g = NameDisp (\m n -> f m n `mplus` g m n) +instance Semigroup NameDisp where + NameDisp f <> NameDisp g = NameDisp (\n -> f n `mplus` g n) EmptyNameDisp <> EmptyNameDisp = EmptyNameDisp EmptyNameDisp <> x = x x <> _ = x instance Monoid NameDisp where mempty = EmptyNameDisp - mappend = (S.<>) + mappend = (<>) data NameFormat = UnQualified | Qualified !ModName @@ -88,21 +89,13 @@ deriving (Show) -- | Never qualify names from this module. -neverQualifyMod :: ModName -> NameDisp -neverQualifyMod mn = NameDisp $ \ mn' _ -> - if mn == mn' then Just UnQualified - else Nothing - -alwaysQualify :: NameDisp -alwaysQualify = NameDisp $ \ mn _ -> Just (Qualified mn) +neverQualifyMod :: ModPath -> NameDisp +neverQualifyMod mn = NameDisp $ \n -> + if ogModule n == mn then Just UnQualified else Nothing neverQualify :: NameDisp -neverQualify = NameDisp $ \ _ _ -> Just UnQualified +neverQualify = NameDisp $ \ _ -> Just UnQualified -fmtModName :: ModName -> NameFormat -> T.Text -fmtModName _ UnQualified = T.empty -fmtModName _ (Qualified mn) = modNameToText mn -fmtModName mn NotInScope = modNameToText mn -- | Compose two naming environments, preferring names from the left -- environment. @@ -111,9 +104,9 @@ -- | Get the format for a name. When 'Nothing' is returned, the name is not -- currently in scope. -getNameFormat :: ModName -> Ident -> NameDisp -> NameFormat -getNameFormat m i (NameDisp f) = fromMaybe NotInScope (f m i) -getNameFormat _ _ EmptyNameDisp = NotInScope +getNameFormat :: OrigName -> NameDisp -> NameFormat +getNameFormat m (NameDisp f) = fromMaybe NotInScope (f m) +getNameFormat _ EmptyNameDisp = NotInScope -- | Produce a document in the context of the current 'NameDisp'. withNameDisp :: (NameDisp -> Doc) -> Doc @@ -126,29 +119,27 @@ -- Documents ------------------------------------------------------------------- -newtype Doc = Doc (NameDisp -> PJ.Doc) deriving (Generic, NFData) +newtype Doc = Doc (NameDisp -> PP.Doc Void) deriving (Generic, NFData) -instance S.Semigroup Doc where - (<>) = liftPJ2 (PJ.<>) +instance Semigroup Doc where + (<>) = liftPP2 (<>) instance Monoid Doc where - mempty = liftPJ PJ.empty - mappend = (S.<>) + mempty = liftPP mempty + mappend = (<>) -runDoc :: NameDisp -> Doc -> PJ.Doc +runDoc :: NameDisp -> Doc -> PP.Doc Void runDoc names (Doc f) = f names instance Show Doc where - show d = show (runDoc mempty d) + show d = PP.renderString (PP.layoutPretty opts (runDoc mempty d)) + where opts = PP.defaultLayoutOptions{ PP.layoutPageWidth = PP.AvailablePerLine 100 0.666 } instance IsString Doc where fromString = text -render :: Doc -> String -render d = PJ.render (runDoc mempty d) - renderOneLine :: Doc -> String -renderOneLine d = PJ.renderStyle (PJ.style { PJ.mode = PJ.OneLineMode }) (runDoc mempty d) +renderOneLine d = PP.renderString (PP.layoutCompact (runDoc mempty d)) class PP a where ppPrec :: Int -> a -> Doc @@ -163,6 +154,11 @@ -- | Print a name as an infix operator: @a + b@ ppInfixName :: a -> Doc +instance PPName ModName where + ppNameFixity _ = Nothing + ppPrefixName = pp + ppInfixName = pp + pp :: PP a => a -> Doc pp = ppPrec 0 @@ -170,7 +166,7 @@ pretty = show . pp optParens :: Bool -> Doc -> Doc -optParens b body | b = parens body +optParens b body | b = nest 1 (parens body) | otherwise = body @@ -182,10 +178,6 @@ , ieFixity :: Fixity -- ^ operator fixity } -commaSep :: [Doc] -> Doc -commaSep = fsep . punctuate comma - - -- | Pretty print an infix expression of some sort. ppInfix :: (PP thing, PP op) => Int -- ^ Non-infix leaves are printed with this precedence @@ -227,94 +219,123 @@ -- Wrapped Combinators --------------------------------------------------------- -liftPJ :: PJ.Doc -> Doc -liftPJ d = Doc (const d) +liftPP :: PP.Doc Void -> Doc +liftPP d = Doc (const d) -liftPJ1 :: (PJ.Doc -> PJ.Doc) -> Doc -> Doc -liftPJ1 f (Doc d) = Doc (\env -> f (d env)) +liftPP1 :: (PP.Doc Void -> PP.Doc Void) -> Doc -> Doc +liftPP1 f (Doc d) = Doc (\env -> f (d env)) -liftPJ2 :: (PJ.Doc -> PJ.Doc -> PJ.Doc) -> (Doc -> Doc -> Doc) -liftPJ2 f (Doc a) (Doc b) = Doc (\e -> f (a e) (b e)) +liftPP2 :: (PP.Doc Void -> PP.Doc Void -> PP.Doc Void) -> (Doc -> Doc -> Doc) +liftPP2 f (Doc a) (Doc b) = Doc (\e -> f (a e) (b e)) -liftSep :: ([PJ.Doc] -> PJ.Doc) -> ([Doc] -> Doc) +liftSep :: ([PP.Doc Void] -> PP.Doc Void) -> ([Doc] -> Doc) liftSep f ds = Doc (\e -> f [ d e | Doc d <- ds ]) -infixl 6 <.>, <+> +infixl 6 <.>, <+>, (<.>) :: Doc -> Doc -> Doc -(<.>) = liftPJ2 (PJ.<>) +(<.>) = liftPP2 (PP.<>) (<+>) :: Doc -> Doc -> Doc -(<+>) = liftPJ2 (PJ.<+>) +(<+>) = liftPP2 (PP.<+>) +() :: Doc -> Doc -> Doc +Doc x Doc y = Doc (\e -> x e <> PP.softline <> y e) + infixl 5 $$ ($$) :: Doc -> Doc -> Doc -($$) = liftPJ2 (PJ.$$) +($$) x y = vsep [x,y] sep :: [Doc] -> Doc -sep = liftSep PJ.sep +sep = liftSep PP.sep fsep :: [Doc] -> Doc -fsep = liftSep PJ.fsep +fsep = liftSep PP.fillSep hsep :: [Doc] -> Doc -hsep = liftSep PJ.hsep +hsep = liftSep PP.hsep hcat :: [Doc] -> Doc -hcat = liftSep PJ.hcat +hcat = liftSep PP.hcat vcat :: [Doc] -> Doc -vcat = liftSep PJ.vcat +vcat = liftSep PP.vcat +vsep :: [Doc] -> Doc +vsep = liftSep PP.vsep + +group :: Doc -> Doc +group = liftPP1 PP.group + +-- NB, this is the semantics of "hang" as defined +-- by the HugesPJ printer, not the "hang" from prettyprinter, +-- which is subtly different. hang :: Doc -> Int -> Doc -> Doc -hang (Doc p) i (Doc q) = Doc (\e -> PJ.hang (p e) i (q e)) +hang (Doc p) i (Doc q) = Doc (\e -> PP.hang i (PP.vsep [p e, q e])) nest :: Int -> Doc -> Doc -nest n = liftPJ1 (PJ.nest n) +nest n = liftPP1 (PP.nest n) +indent :: Int -> Doc -> Doc +indent n = liftPP1 (PP.indent n) + +align :: Doc -> Doc +align = liftPP1 PP.align + parens :: Doc -> Doc -parens = liftPJ1 PJ.parens +parens = liftPP1 PP.parens braces :: Doc -> Doc -braces = liftPJ1 PJ.braces +braces = liftPP1 PP.braces brackets :: Doc -> Doc -brackets = liftPJ1 PJ.brackets +brackets = liftPP1 PP.brackets quotes :: Doc -> Doc -quotes = liftPJ1 PJ.quotes +quotes = liftPP1 PP.squotes -backticks :: Doc -> Doc -backticks d = hcat [ "`", d, "`" ] +commaSep :: [Doc] -> Doc +commaSep xs = Doc (\e -> PP.sep (PP.punctuate PP.comma [ d e | Doc d <- xs ])) -punctuate :: Doc -> [Doc] -> [Doc] -punctuate p = go +-- | Print a comma-separated list. Lay out each item on a single line +-- if it will fit. If an item requires multiple lines, then start it +-- on its own line. +commaSepFill :: [Doc] -> Doc +commaSepFill xs = Doc (\e -> fillSep (PP.punctuate PP.comma [ d e | Doc d <- xs ])) where - go (d:ds) | null ds = [d] - | otherwise = d <.> p : go ds - go [] = [] + fillSep [] = mempty + fillSep (d0 : ds) = foldl (\a d -> a <> PP.group (PP.line <> d)) d0 ds +ppList :: [Doc] -> Doc +ppList xs = group (nest 1 (brackets (commaSepFill xs))) + +ppTuple :: [Doc] -> Doc +ppTuple xs = group (nest 1 (parens (commaSep xs))) + +ppRecord :: [Doc] -> Doc +ppRecord xs = group (nest 1 (braces (commaSep xs))) + +backticks :: Doc -> Doc +backticks d = hcat [ "`", d, "`" ] + text :: String -> Doc -text s = liftPJ (PJ.text s) +text s = liftPP (PP.pretty s) char :: Char -> Doc -char c = liftPJ (PJ.char c) +char c = liftPP (PP.pretty c) integer :: Integer -> Doc -integer i = liftPJ (PJ.integer i) +integer i = liftPP (PP.pretty i) int :: Int -> Doc -int i = liftPJ (PJ.int i) +int i = liftPP (PP.pretty i) comma :: Doc -comma = liftPJ PJ.comma - -empty :: Doc -empty = liftPJ PJ.empty +comma = liftPP PP.comma colon :: Doc -colon = liftPJ PJ.colon +colon = liftPP PP.colon instance PP T.Text where ppPrec _ str = text (T.unpack str) @@ -325,6 +346,7 @@ instance PP ModName where ppPrec _ = text . T.unpack . modNameToText + instance PP Assoc where ppPrec _ LeftAssoc = text "left-associative" ppPrec _ RightAssoc = text "right-associative" @@ -333,3 +355,31 @@ instance PP Fixity where ppPrec _ (Fixity assoc level) = text "precedence" <+> int level <.> comma <+> pp assoc + +instance PP ModPath where + ppPrec _ p = + case p of + TopModule m -> pp m + Nested q t -> pp q <.> "::" <.> pp t + +instance PP OrigName where + ppPrec _ og = + withNameDisp $ \disp -> + case getNameFormat og disp of + UnQualified -> pp (ogName og) + Qualified m -> ppQual (TopModule m) (pp (ogName og)) + NotInScope -> ppQual (ogModule og) (pp (ogName og)) + where + ppQual mo x = + case mo of + TopModule m + | m == exprModName -> x + | otherwise -> pp m <.> "::" <.> x + Nested m y -> ppQual m (pp y <.> "::" <.> x) + +instance PP Namespace where + ppPrec _ ns = + case ns of + NSValue -> "/*value*/" + NSType -> "/*type*/" + NSModule -> "/*module*/"