diff --git a/CHANGES.md b/CHANGES.md
--- a/CHANGES.md
+++ b/CHANGES.md
@@ -1,3 +1,53 @@
+# 2.11.0
+
+## Language changes
+
+* The `newtype` construct, which has existed in the interpreter in an
+ incomplete and undocumented form for quite a while, is now fullly
+ supported. The construct is documented in section 1.22 of [Programming
+ Cryptol](https://cryptol.net/files/ProgrammingCryptol.pdf). Note,
+ however, that the `cryptol-remote-api` RPC server currently does not
+ include full support for referring to `newtype` names, though it can
+ work with implementations that use `newtype` internally.
+
+## New features
+
+* By default, the interpreter will now track source locations of
+ expressions being evaluated, and retain call stack information.
+ This information is incorporated into error messages arising from
+ runtime errors. This additional bookkeeping incurs significant
+ runtime overhead, but may be disabled using the `--no-call-stacks`
+ command-line option.
+
+* The `:exhaust` command now works for floating-point types and the
+ `:check` command now uses more representative sampling of
+ floating-point input values to test.
+
+* The `cryptol-remote-api` RPC server now has methods corresponding to
+ the `:prove` and `:sat` commands in the REPL.
+
+* The `cryptol-eval-server` executable is a new, stateless server
+ providing a subset of the functionality of `cryptol-remote-api`
+ dedicated entirely to invoking Cryptol functions on concrete inputs.
+
+## Internal changes
+
+* A single running instance of the SMT solver used for type checking
+ (Z3) is now used to check a larger number of type correctness queries.
+ This means that fewer solver instances are invoked, and type checking
+ should generally be faster.
+
+* The Cryptol interpreter now builds against `libBF` version 0.6, which
+ fixes a few bugs in the evaluation of floating-point operations.
+
+## Bug fixes
+
+* Closed issues #118, #398, #426, #470, #491, #567, #594, #639, #656,
+ #698, #743, #810, #858, #870, #905, #915, #917, #962, #973, #975,
+ #980, #984, #986, #990, #996, #997, #1002, #1006, #1009, #1012, #1024,
+ #1030, #1035, #1036, #1039, #1040, #1044, #1045, #1049, #1050, #1051,
+ #1052, #1063, #1092, #1093, #1094, and #1100.
+
# 2.10.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.10.0
+Version: 2.11.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,7 @@
source-repository this
type: git
location: https://github.com/GaloisInc/cryptol.git
- tag: 2.10.0
+ tag: 2.11.0
flag static
@@ -56,7 +56,7 @@
GraphSCC >= 1.0.4,
heredoc >= 0.2,
integer-gmp >= 1.0 && < 1.1,
- libBF >= 0.5.1,
+ libBF >= 0.6 && < 0.7,
MemoTrie >= 0.6 && < 0.7,
monad-control >= 1.0,
monadLib >= 3.7.2,
@@ -64,7 +64,7 @@
pretty >= 1.1,
process >= 1.2,
random >= 1.0.1,
- sbv >= 8.6 && < 8.8,
+ sbv >= 8.6 && < 8.13,
simple-smt >= 0.7.1,
stm >= 2.4,
strict,
@@ -74,7 +74,7 @@
mtl >= 2.2.1,
time >= 1.6.0.1,
panic >= 0.3,
- what4 >= 1.0 && < 1.1
+ what4 >= 1.1 && < 1.2
Build-tool-depends: alex:alex, happy:happy
hs-source-dirs: src
@@ -164,12 +164,12 @@
Cryptol.Backend.Monad,
Cryptol.Backend.SBV,
Cryptol.Backend.What4,
- Cryptol.Backend.What4.SFloat,
Cryptol.Eval,
Cryptol.Eval.Concrete,
Cryptol.Eval.Env,
Cryptol.Eval.Generic,
+ Cryptol.Eval.Prims,
Cryptol.Eval.Reference,
Cryptol.Eval.SBV,
Cryptol.Eval.Type,
@@ -232,7 +232,8 @@
ghc-options: -Wno-redundant-constraints
if os(linux) && flag(static)
- ld-options: -static -pthread
+ ld-options: -static -pthread
+ ghc-options: -optl-fuse-ld=bfd
executable cryptol-html
Default-language:
@@ -242,6 +243,27 @@
build-depends: base, text, cryptol, blaze-html
GHC-options: -Wall
+ if os(linux) && flag(static)
+ ld-options: -static -pthread
+ ghc-options: -optl-fuse-ld=bfd
+
+executable check-exercises
+ Default-language:
+ Haskell2010
+ Main-is: CheckExercises.hs
+ hs-source-dirs: cryptol
+ build-depends: ansi-terminal
+ , base
+ , containers
+ , directory
+ , extra
+ , filepath
+ , mtl
+ , optparse-applicative
+ , process
+ , temporary
+ , text
+ GHC-options: -Wall
benchmark cryptol-bench
type: exitcode-stdio-1.0
main-is: Main.hs
@@ -251,7 +273,8 @@
if impl(ghc >= 8.0.1)
ghc-options: -Wno-redundant-constraints
if os(linux) && flag(static)
- ld-options: -static -pthread
+ ld-options: -static -pthread
+ ghc-options: -optl-fuse-ld=bfd
build-depends: base
, criterion
, cryptol
diff --git a/cryptol/CheckExercises.hs b/cryptol/CheckExercises.hs
new file mode 100644
--- /dev/null
+++ b/cryptol/CheckExercises.hs
@@ -0,0 +1,371 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module Main(main) where
+
+import Control.Monad.State
+import Options.Applicative
+import Data.Char (isSpace, isAlpha)
+import Data.Foldable (traverse_)
+import Data.List (isInfixOf, isPrefixOf, stripPrefix)
+import Data.Maybe (fromMaybe)
+import qualified Data.Sequence as Seq
+import Numeric.Natural
+import qualified System.Process as P
+import System.Directory
+import System.Exit
+import System.IO.Temp
+import Data.Foldable (toList)
+
+data Opts = Opts { latexFile :: FilePath
+ -- ^ The latex file we are going to check
+ , cryptolExe :: Maybe FilePath
+ -- ^ Path to cryptol executable (default: cabal v2-exec cryptol)
+ , tempDir :: Maybe FilePath
+ -- ^ Path to store temporary files and log files
+ }
+ deriving Show
+
+optsParser :: Parser Opts
+optsParser = Opts
+ <$> strArgument ( help "path to latex file"
+ <> metavar "PATH"
+ )
+ <*> ( optional $ strOption
+ ( long "exe"
+ <> short 'e'
+ <> metavar "PATH"
+ <> help "Path to cryptol executable (defaults to 'cabal v2-exec cryptol')"
+ ) )
+ <*> ( optional $ strOption
+ ( long "log-dir"
+ <> short 'l'
+ <> metavar "PATH"
+ <> help "Directory for log files in case of failure (defaults to .)"
+ ) )
+
+-- | Trim whitespace off both ends of a string
+trim :: String -> String
+trim = f . f
+ where f = reverse . dropWhile isSpace
+
+----------------------------------------------------------------------
+-- LaTeX processing state monad
+--
+-- We process the text-by-line. The behavior of the state monad on a line is
+-- governed by the mode it is currently in. The current mode dictates how to
+-- interpret each line, and which mode to transition to next.
+--
+-- There are four modes: AwaitingReplMode, ReplinMode, ReploutMode, and
+-- ReplPromptMode. Below we describe the behavior of each mode.
+--
+-- AwaitingReplMode: When in this mode, we are anticipating "replin" or
+-- "replout" lines; that is, lines that will be issued as input to the repl or
+-- expected as output from the repl.. When we see a \begin{replinVerb}, we
+-- transition to ReplinMode. When we see a \begin{reploutVerb}, we transition to
+-- ReploutMode. When we see a \begin{replPromptVerb}, we transition to
+-- ReplPromptMode. When we see an inline \replin{..} command, we add the content
+-- to the list of replin lines without changing modes. When we see an inline
+-- \replout{..} command, we add the content to the list of replout lines without
+-- changing modes.
+--
+-- ReplinMode: When in this mode, we are inside of a "\begin{replinVerb}"
+-- section. When we see a \end{replinVerb} line, we transition to
+-- AwaitingReplMode. Otherwise, we simply add the entire line to the list of
+-- replin lines.
+--
+-- ReploutMode: Like ReplinMode, except we add each line to the expected output.
+--
+-- ReplPromptMode: A combination of ReplinMode and ReploutMode. Each line is
+-- either added to input or expected output. If the line starts with a prompt
+-- like "Cryptol>" or "Float>", it is added to expected input. Otherwise it is
+-- added to expected output.
+
+data PMode = AwaitingReplMode
+ | ReplinMode
+ | ReploutMode
+ | ReplPromptMode
+ deriving (Eq, Show)
+
+data Line = Line { lineNum :: Natural
+ , lineText :: String
+ }
+ deriving (Eq, Show)
+
+-- | REPL input and expected output, with line number annotations.
+data ReplData = ReplData { rdReplin :: Seq.Seq Line
+ , rdReplout :: Seq.Seq Line
+ }
+ deriving (Eq, Show)
+
+-- | Latex processing state
+data PState = PState { pMode :: PMode
+ -- ^ current mode
+ , pCompletedReplData :: Seq.Seq ReplData
+ -- ^ list of all completed REPL input/output pairs to be
+ -- validated (thus far)
+ , pReplin :: Seq.Seq Line
+ -- ^ list of replin lines (so far) for unfinished ReplData
+ , pReplout :: Seq.Seq Line
+ -- ^ list of replout lines (so far) for unfinished ReplData
+ , pCurrentLine :: Natural
+ }
+ deriving (Eq, Show)
+
+initPState :: PState
+initPState = PState AwaitingReplMode Seq.empty Seq.empty Seq.empty 1
+
+-- | P monad for reading in lines
+type P = State PState
+
+first3 :: (a -> a') -> (a, b, c) -> (a', b, c)
+first3 f (a, b, c) = (f a, b, c)
+
+-- | Like 'stripPrefix', but takes a list of prefixes rather than a single
+-- prefix. Returns the first prefix that matches the start of the list along
+-- with the remainder of the list.
+stripPrefixOneOf :: Eq a => [[a]] -> [a] -> Maybe ([a], [a])
+stripPrefixOneOf [] _ = Nothing
+stripPrefixOneOf (p:ps) as = case stripPrefix p as of
+ Nothing -> stripPrefixOneOf ps as
+ Just as' -> Just (p, as')
+
+-- | Like 'stripInfix', but takes a list of infixes. Returns the infix that
+-- matches at the earliest index.
+stripInfixOneOf :: Eq a => [[a]] -> [a] -> Maybe ([a], [a], [a])
+stripInfixOneOf needles haystack
+ | Just (needle, suffix) <- stripPrefixOneOf needles haystack
+ = Just ([], needle, suffix)
+stripInfixOneOf _ [] = Nothing
+stripInfixOneOf needles (x:xs) = first3 (x:) <$> stripInfixOneOf needles xs
+
+data InlineRepl = InlineReplin | InlineReplout
+
+-- | Extracts the first inline repl command returns the type of command, its
+-- contents, and the remainder of the string.
+inlineRepl :: String -> Maybe (InlineRepl, String, String)
+inlineRepl s
+ | Just (_, ir, s1) <- stripInfixOneOf [ "\\replin|"
+ , "\\replout|"
+ , "\\hidereplin|"
+ , "\\hidereplout|"] s
+ , (s2, s3) <- break (=='|') s1 = case ir of
+ "\\replin|" -> Just (InlineReplin, s2, s3)
+ "\\replout|" -> Just (InlineReplout, s2, s3)
+ "\\hidereplin|" -> Just (InlineReplin, s2, s3)
+ "\\hidereplout|" -> Just (InlineReplout, s2, s3)
+ _ -> error "PANIC: CheckExercises.inlineRepl"
+ | otherwise = Nothing
+
+addReplData :: P ()
+addReplData = do
+ replin <- gets pReplin
+ replout <- gets pReplout
+ completedReplData <- gets pCompletedReplData
+ let completedReplData' = completedReplData Seq.|> ReplData replin replout
+ when (not (Seq.null replin && Seq.null replout)) $
+ modify' $ \st -> st { pCompletedReplData = completedReplData'
+ , pReplin = Seq.empty
+ , pReplout = Seq.empty
+ }
+
+addReplin :: String -> P ()
+addReplin s = do
+ ln <- gets pCurrentLine
+ replin <- gets pReplin
+ modify' $ \st -> st { pReplin = replin Seq.|> Line ln s }
+
+addReplout :: String -> P ()
+addReplout s = do
+ ln <- gets pCurrentLine
+ replout <- gets pReplout
+ modify' $ \st -> st { pReplout = replout Seq.|> Line ln s }
+
+nextLine :: P ()
+nextLine = modify' $ \st -> st { pCurrentLine = pCurrentLine st + 1 }
+
+stripPrompt :: String -> Maybe String
+stripPrompt s = case span isAlpha s of
+ (_:_, '>':s') -> Just s'
+ _ -> Nothing
+
+-- | The main function for our monad. Input is a single line.
+processLine :: String -> P ()
+processLine s = do
+ let s_nocomment = takeWhile (not . (== '%')) s
+ s_nowhitespace = filter (not . isSpace) s_nocomment
+ m <- gets pMode
+ ln <- gets pCurrentLine
+ case m of
+ AwaitingReplMode
+ | "\\begin{replinVerb}" `isInfixOf` s_nowhitespace -> do
+ modify' $ \st -> st { pMode = ReplinMode }
+ nextLine
+ | "\\begin{reploutVerb}" `isInfixOf` s_nowhitespace -> do
+ modify' $ \st -> st { pMode = ReploutMode }
+ nextLine
+ | "\\begin{replPrompt}" `isInfixOf` s_nowhitespace -> do
+ modify' $ \st -> st { pMode = ReplPromptMode }
+ nextLine
+ | "\\restartrepl" `isInfixOf` s_nowhitespace -> do
+ -- This is a command that acts as the barrier between discrete
+ -- input/output pairs. When we see it, we commit the current pair,
+ -- begin a brand new pair, and advance to the next line.
+ addReplData
+ nextLine
+ | Just (InlineReplin, cmd, rst) <- inlineRepl s -> do
+ addReplin cmd
+ processLine rst
+ | Just (InlineReplout, cmd, rst) <- inlineRepl s -> do
+ addReplout cmd
+ processLine rst
+ | otherwise -> nextLine
+ ReplinMode
+ | "\\end{replinVerb}" `isInfixOf` s_nowhitespace -> do
+ -- Switching from ingesting repl input to awaiting repl input.
+ modify' $ \st -> st { pMode = AwaitingReplMode }
+ nextLine
+ | otherwise -> do
+ -- Ingest the current line, and stay in ReplinMode.
+ replin <- gets pReplin
+ let replin' = replin Seq.|> Line ln s -- use the full input since %
+ -- isn't a comment in verbatim
+ -- mode.
+ modify' $ \st -> st { pReplin = replin' }
+ nextLine
+ ReploutMode
+ | "\\end{reploutVerb}" `isInfixOf` s_nowhitespace -> do
+ -- Switching from ingesting repl output to awaiting repl output.
+ modify' $ \st -> st { pMode = AwaitingReplMode }
+ nextLine
+ | otherwise -> do
+ -- Ingest the current line, and stay in ReploutMode.
+ replout <- gets pReplout
+ let replout' = replout Seq.|> Line ln s -- use the full input since %
+ -- isn't a comment in verbatim
+ -- mode.
+ modify' $ \st -> st { pReplout = replout' }
+ nextLine
+ ReplPromptMode
+ | "\\end{replPrompt}" `isInfixOf` s_nowhitespace -> do
+ -- Switching from ingesting repl input/output to awaiting repl
+ -- input.
+ modify' $ \st -> st { pMode = AwaitingReplMode }
+ nextLine
+ | Just input <- stripPrompt (trim s) -> do
+ replin <- gets pReplin
+ let input' = trim input
+ replin' = replin Seq.|> Line ln input' -- use the full input since
+ -- % isn't a comment in
+ -- verbatim mode.
+ modify $ \st -> st { pReplin = replin' }
+ nextLine
+ | otherwise -> do
+ replout <- gets pReplout
+ let replout' = replout Seq.|> Line ln s -- use the full input since %
+ -- isn't a comment in verbatim
+ -- mode.
+ modify $ \st -> st { pReplout = replout' }
+ nextLine
+
+main :: IO ()
+main = do
+ opts <- execParser p
+ allLines <- lines <$> readFile (latexFile opts)
+ let PState {..} = flip execState initPState $ do
+ -- Process every line
+ traverse_ processLine allLines
+ -- Insert the final ReplData upon completion
+ addReplData
+ let allReplData = toList pCompletedReplData
+ dir = fromMaybe "." (tempDir opts)
+
+ forM_ allReplData $ \rd -> do
+ let inText = unlines $ fmap (trim . lineText) $ toList $ rdReplin rd
+ inFileNameTemplate = "in.icry"
+ inFile <- writeTempFile dir inFileNameTemplate inText
+
+ let exe = fromMaybe "./cry run" (cryptolExe opts)
+
+ if Seq.null (rdReplout rd)
+ then do let cryCmd = (P.shell (exe ++ " --interactive-batch " ++ inFile ++ " -e"))
+ (cryEC, cryOut, _) <- P.readCreateProcessWithExitCode cryCmd ""
+
+
+ Line lnReplinStart _ Seq.:<| _ <- return $ rdReplin rd
+ _ Seq.:|> Line lnReplinEnd _ <- return $ rdReplin rd
+ case cryEC of
+ ExitFailure _ -> do
+ putStrLn $ "REPL error (replin lines " ++
+ show lnReplinStart ++ "-" ++ show lnReplinEnd ++ ")."
+ putStr cryOut
+ exitFailure
+ ExitSuccess -> do
+ -- remove temporary input file
+ removeFile inFile
+ else do let outExpectedText = unlines $ filter (not . null) $
+ fmap (trim . lineText) $ toList $ rdReplout rd
+ outExpectedFileNameTemplate = "out-expected.icry"
+ outFileNameTemplate = "out.icry"
+ cryCmd = (P.shell (exe ++ " --interactive-batch " ++ inFile))
+ outExpectedFile <- writeTempFile dir outExpectedFileNameTemplate outExpectedText
+ outFile <- emptyTempFile dir outFileNameTemplate
+
+ (_, cryOut, _) <- P.readCreateProcessWithExitCode cryCmd ""
+
+ -- remove temporary input file
+ removeFile inFile
+
+ let outText = unlines $ filter (not . null) $ trim <$> (dropWhile ("Loading module" `isPrefixOf`) $ lines cryOut)
+
+ writeFile outFile outText
+
+ let diffCmd = (P.shell ("diff -u " ++ outExpectedFile ++ " " ++ outFile))
+
+ (diffEC, diffOut, _) <- P.readCreateProcessWithExitCode diffCmd ""
+ case diffEC of
+ ExitSuccess -> do
+ -- Remove temporary output files
+ removeFile outExpectedFile
+ removeFile outFile
+ ExitFailure _ -> do
+ Line lnReplinStart _ Seq.:<| _ <- return $ rdReplin rd
+ _ Seq.:|> Line lnReplinEnd _ <- return $ rdReplin rd
+ Line lnReploutStart _ Seq.:<| _ <- return $ rdReplout rd
+ _ Seq.:|> Line lnReploutEnd _ <- return $ rdReplout rd
+
+ putStrLn $ "REPL output mismatch in " ++ latexFile opts
+ putStrLn $ " (replin lines " ++
+ show lnReplinStart ++ "-" ++ show lnReplinEnd ++
+ ", replout lines " ++ show lnReploutStart ++ "-" ++
+ show lnReploutEnd ++ ")."
+ putStrLn $ "Diff output:"
+ putStr diffOut
+
+ let outExpectedFileName = dir ++ "/" ++ outExpectedFileNameTemplate
+ outFileName = dir ++ "/" ++ outFileNameTemplate
+
+ putStrLn ""
+ putStrLn $ "Expected output written to: " ++ outExpectedFileName
+ putStrLn $ "Actual output written to: " ++ outFileName
+
+ -- Write to log files
+ writeFile outExpectedFileName outExpectedText
+ writeFile outFileName outText
+
+ -- Remove temporary output files and exit
+ removeFile outExpectedFile
+ removeFile outFile
+ exitFailure
+
+ putStrLn $ "Successfully checked " ++ show (length allReplData) ++ " repl examples in " ++ latexFile opts
+
+ return ()
+
+ where p = info (optsParser <**> helper)
+ ( fullDesc
+ <> progDesc "Test the exercises in a cryptol LaTeX file"
+ <> header "check-exercises -- test cryptol exercises"
+ )
diff --git a/cryptol/Main.hs b/cryptol/Main.hs
--- a/cryptol/Main.hs
+++ b/cryptol/Main.hs
@@ -26,7 +26,6 @@
import Cryptol.Version (displayVersion)
import Control.Monad (when)
-import Data.Maybe (isJust)
import GHC.IO.Encoding (setLocaleEncoding, utf8)
import System.Console.GetOpt
(OptDescr(..),ArgOrder(..),ArgDescr(..),getOpt,usageInfo)
@@ -47,7 +46,8 @@
{ optLoad :: [FilePath]
, optVersion :: Bool
, optHelp :: Bool
- , optBatch :: Maybe FilePath
+ , optBatch :: ReplMode
+ , optCallStacks :: Bool
, optCommands :: [String]
, optColorMode :: ColorMode
, optCryptolrc :: Cryptolrc
@@ -61,7 +61,8 @@
{ optLoad = []
, optVersion = False
, optHelp = False
- , optBatch = Nothing
+ , optBatch = InteractiveRepl
+ , optCallStacks = True
, optCommands = []
, optColorMode = AutoColor
, optCryptolrc = CryrcDefault
@@ -75,6 +76,9 @@
[ Option "b" ["batch"] (ReqArg setBatchScript "FILE")
"run the script provided and exit"
+ , Option "" ["interactive-batch"] (ReqArg setInteractiveBatchScript "FILE")
+ "run the script provided and exit, but behave as if running an interactive session"
+
, Option "e" ["stop-on-error"] (NoArg setStopOnError)
"stop script execution as soon as an error occurs."
@@ -95,6 +99,9 @@
, Option "h" ["help"] (NoArg setHelp)
"display this message"
+ , Option "" ["no-call-stacks"] (NoArg setNoCallStacks)
+ "Disable tracking of call stack information, which reduces interpreter overhead"
+
, Option "" ["no-unicode-logo"] (NoArg setNoUnicodeLogo)
"Don't use unicode characters in the REPL logo"
@@ -124,8 +131,12 @@
-- | Set a batch script to be run.
setBatchScript :: String -> OptParser Options
-setBatchScript path = modify $ \ opts -> opts { optBatch = Just path }
+setBatchScript path = modify $ \ opts -> opts { optBatch = Batch path }
+-- | Set an interactive batch script
+setInteractiveBatchScript :: String -> OptParser Options
+setInteractiveBatchScript path = modify $ \ opts -> opts { optBatch = InteractiveBatch path }
+
-- | Set the color mode of the terminal output.
setColorMode :: String -> OptParser Options
setColorMode "auto" = modify $ \ opts -> opts { optColorMode = AutoColor }
@@ -149,6 +160,10 @@
setCryrcDisabled :: OptParser Options
setCryrcDisabled = modify $ \ opts -> opts { optCryptolrc = CryrcDisabled }
+-- | Disable call stack tracking
+setNoCallStacks :: OptParser Options
+setNoCallStacks = modify $ \opts -> opts { optCallStacks = False }
+
-- | Add another file to read as a @.cryptolrc@ file, unless @.cryptolrc@
-- files have been disabled
addCryrc :: String -> OptParser Options
@@ -180,9 +195,15 @@
, "addition to the default locations"
]
)
+ , ( "EDITOR"
+ , [ "Sets the editor executable to use when opening an editor"
+ , "via the `:edit` command"
+ ]
+ )
, ( "SBV_{ABC,BOOLECTOR,CVC4,MATHSAT,YICES,Z3}_OPTIONS"
, [ "A string of command-line arguments to be passed to the"
, "corresponding solver invoked for `:sat` and `:prove`"
+ , "when using a prover via SBV"
]
)
]
@@ -206,6 +227,7 @@
(opts', mCleanup) <- setupCmdScript opts
status <- repl (optCryptolrc opts')
(optBatch opts')
+ (optCallStacks opts')
(optStopOnError opts')
(setupREPL opts')
case mCleanup of
@@ -225,9 +247,9 @@
(path, h) <- openTempFile tmpdir "cmds.icry"
hPutStr h (unlines cmds)
hClose h
- when (isJust (optBatch opts)) $
+ when (optBatch opts /= InteractiveRepl) $
putStrLn "[warning] --command argument specified; ignoring batch file"
- return (opts { optBatch = Just path }, Just path)
+ return (opts { optBatch = InteractiveBatch path }, Just path)
setupREPL :: Options -> REPL ()
setupREPL opts = do
@@ -261,9 +283,10 @@
setUpdateREPLTitle (shouldSetREPLTitle >>= \b -> when b setREPLTitle)
updateREPLTitle
case optBatch opts of
- Nothing -> return ()
-- add the directory containing the batch file to the module search path
- Just file -> prependSearchPath [ takeDirectory file ]
+ Batch file -> prependSearchPath [ takeDirectory file ]
+ _ -> return ()
+
case optLoad opts of
[] -> loadPrelude `REPL.catch` \x -> io $ print $ pp x
[l] -> loadCmd l `REPL.catch` \x -> do
diff --git a/cryptol/REPL/Haskeline.hs b/cryptol/REPL/Haskeline.hs
--- a/cryptol/REPL/Haskeline.hs
+++ b/cryptol/REPL/Haskeline.hs
@@ -29,7 +29,6 @@
import Data.Char (isAlphaNum, isSpace)
import Data.Function (on)
import Data.List (isPrefixOf,nub,sortBy,sort)
-import Data.Maybe(isJust)
import qualified Data.Set as Set
import qualified Data.Text as T (unpack)
import System.Console.ANSI (setTitle, hSupportsANSI)
@@ -44,42 +43,57 @@
import Prelude.Compat
+data ReplMode
+ = InteractiveRepl -- ^ Interactive terminal session
+ | Batch FilePath -- ^ Execute from a batch file
+ | InteractiveBatch FilePath
+ -- ^ Execute from a batch file, but behave as though
+ -- lines are entered in an interactive session.
+ deriving (Show, Eq)
+
-- | One REPL invocation, either from a file or from the terminal.
-crySession :: Maybe FilePath -> Bool -> REPL CommandExitCode
-crySession mbBatch stopOnError =
+crySession :: ReplMode -> Bool -> REPL CommandExitCode
+crySession replMode stopOnError =
do settings <- io (setHistoryFile (replSettings isBatch))
- let act = runInputTBehavior behavior settings (withInterrupt loop)
+ let act = runInputTBehavior behavior settings (withInterrupt (loop 1))
if isBatch then asBatch act else act
where
- (isBatch,behavior) = case mbBatch of
- Nothing -> (False,defaultBehavior)
- Just path -> (True,useFile path)
+ (isBatch,behavior) = case replMode of
+ InteractiveRepl -> (False, defaultBehavior)
+ Batch path -> (True, useFile path)
+ InteractiveBatch path -> (False, useFile path)
- loop :: InputT REPL CommandExitCode
- loop =
+ loop :: Int -> InputT REPL CommandExitCode
+ loop lineNum =
do ln <- getInputLines =<< MTL.lift getPrompt
case ln of
NoMoreLines -> return CommandOk
Interrupted
| isBatch && stopOnError -> return CommandError
- | otherwise -> loop
- NextLine line
- | all isSpace line -> loop
- | otherwise -> doCommand line
+ | otherwise -> loop lineNum
+ NextLine ls
+ | all (all isSpace) ls -> loop (lineNum + length ls)
+ | otherwise -> doCommand lineNum ls
- doCommand txt =
- case parseCommand findCommandExact txt of
- Nothing | isBatch && stopOnError -> return CommandError
- | otherwise -> loop -- say somtething?
+ run lineNum cmd =
+ case replMode of
+ InteractiveRepl -> runCommand lineNum Nothing cmd
+ InteractiveBatch _ -> runCommand lineNum Nothing cmd
+ Batch path -> runCommand lineNum (Just path) cmd
+
+ doCommand lineNum txt =
+ case parseCommand findCommandExact (unlines txt) of
+ Nothing | isBatch && stopOnError -> return CommandError
+ | otherwise -> loop (lineNum + length txt) -- say somtething?
Just cmd -> join $ MTL.lift $
- do status <- handleInterrupt (handleCtrlC CommandError) (runCommand cmd)
+ do status <- handleInterrupt (handleCtrlC CommandError) (run lineNum cmd)
case status of
CommandError | isBatch && stopOnError -> return (return status)
_ -> do goOn <- shouldContinue
- return (if goOn then loop else return status)
+ return (if goOn then loop (lineNum + length txt) else return status)
-data NextLine = NextLine String | NoMoreLines | Interrupted
+data NextLine = NextLine [String] | NoMoreLines | Interrupted
getInputLines :: String -> InputT REPL NextLine
getInputLines = handleInterrupt (MTL.lift (handleCtrlC Interrupted)) . loop []
@@ -91,7 +105,7 @@
Nothing -> return NoMoreLines
Just l
| not (null l) && last l == '\\' -> loop (init l : ls) newPropmpt
- | otherwise -> return $ NextLine $ unlines $ reverse $ l : ls
+ | otherwise -> return $ NextLine $ reverse $ l : ls
loadCryRC :: Cryptolrc -> REPL CommandExitCode
loadCryRC cryrc =
@@ -106,25 +120,32 @@
let file = dir ".cryptolrc"
present <- io (doesFileExist file)
if present
- then crySession (Just file) True
+ then crySession (Batch file) True
else check others
loadMany [] = return CommandOk
- loadMany (f : fs) = do status <- crySession (Just f) True
+ loadMany (f : fs) = do status <- crySession (Batch f) True
case status of
CommandOk -> loadMany fs
_ -> return status
-- | Haskeline-specific repl implementation.
-repl :: Cryptolrc -> Maybe FilePath -> Bool -> REPL () -> IO CommandExitCode
-repl cryrc mbBatch stopOnError begin =
- runREPL (isJust mbBatch) stdoutLogger $
- do status <- loadCryRC cryrc
- case status of
- CommandOk -> begin >> crySession mbBatch stopOnError
- _ -> return status
+repl :: Cryptolrc -> ReplMode -> Bool -> Bool -> REPL () -> IO CommandExitCode
+repl cryrc replMode callStacks stopOnError begin =
+ runREPL isBatch callStacks stdoutLogger replAction
+ where
+ -- this flag is used to suppress the logo and prompts
+ isBatch = case replMode of
+ InteractiveRepl -> False
+ Batch _ -> True
+ InteractiveBatch _ -> True
+ replAction =
+ do status <- loadCryRC cryrc
+ case status of
+ CommandOk -> begin >> crySession replMode stopOnError
+ _ -> return status
-- | Try to set the history file.
setHistoryFile :: Settings REPL -> IO (Settings REPL)
@@ -201,7 +222,7 @@
cryptolCommand :: CompletionFunc REPL
cryptolCommand cursor@(l,r)
| ":" `isPrefixOf` l'
- , Just (cmd,rest) <- splitCommand l' = case nub (findCommand cmd) of
+ , Just (_,cmd,rest) <- splitCommand l' = case nub (findCommand cmd) of
[c] | null rest && not (any isSpace l') -> do
return (l, cmdComp cmd c)
diff --git a/cryptol/REPL/Logo.hs b/cryptol/REPL/Logo.hs
--- a/cryptol/REPL/Logo.hs
+++ b/cryptol/REPL/Logo.hs
@@ -14,6 +14,8 @@
import Cryptol.Version (commitShortHash,commitDirty)
import Data.Version (showVersion)
import System.Console.ANSI
+import Prelude ()
+import Prelude.Compat
type Version = String
diff --git a/lib/Cryptol.cry b/lib/Cryptol.cry
--- a/lib/Cryptol.cry
+++ b/lib/Cryptol.cry
@@ -168,6 +168,13 @@
primitive type Literal : # -> * -> Prop
/**
+ * 'LiteralLessThan n a' asserts that the type 'a' contains all the
+ * natural numbers strictly below 'n'. Note that we may have 'n = inf',
+ * in which case the type 'a' must be unbounded.
+ */
+primitive type LiteralLessThan : # -> * -> Prop
+
+/**
* The value corresponding to a numeric type.
*/
primitive number : {val, rep} Literal val rep => rep
@@ -195,6 +202,15 @@
[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.
+ */
+primitive fromToLessThan :
+ {first, bound, a} (fin first, bound >= first, LiteralLessThan bound a) => [bound - first]a
+
+
+/**
* A finite arithmetic sequence starting with 'first' and 'next',
* stopping when the values reach or would skip over 'last'.
*
@@ -879,8 +895,8 @@
* Declarations of the form 'x @ i = e' are syntactic sugar for
* 'x = generate (\i -> e)'.
*/
-generate : {n, a, ix} (fin n, n >= 1, Integral ix, Literal (n-1) ix) => (ix -> a) -> [n]a
-generate f = [ f i | i <- [0 .. n-1] ]
+generate : {n, a, ix} (Integral ix, LiteralLessThan n ix) => (ix -> a) -> [n]a
+generate f = [ f i | i <- [0 .. Float e p
+/** Negative infinity. */
fpNegInf : {e,p} ValidFloat e p => Float e p
fpNegInf = - fpPosInf
@@ -133,13 +134,33 @@
infix 20 =.=
+/** Test if this value is not-a-number (NaN). */
+primitive fpIsNaN : {e,p} ValidFloat e p => Float e p -> Bool
-/* Returns true for numbers that are not an infinity or NaN. */
-primitive
- fpIsFinite : {e,p} ValidFloat e p => Float e p -> Bool
+/** Test if this value is positive or negative infinity. */
+primitive fpIsInf : {e,p} ValidFloat e p => Float e p -> Bool
+/** Test if this value is positive or negative zero. */
+primitive fpIsZero : {e,p} ValidFloat e p => Float e p -> Bool
+/** Test if this value is negative. */
+primitive fpIsNeg : {e,p} ValidFloat e p => Float e p -> Bool
+/** Test if this value is normal (not NaN, not infinite, not zero, and not subnormal). */
+primitive fpIsNormal : {e,p} ValidFloat e p => Float e p -> Bool
+
+/**
+ * Test if this value is subnormal. Subnormal values are nonzero
+ * values with magnitudes smaller than can be represented with the
+ * normal implicit leading bit convention.
+ */
+primitive fpIsSubnormal : {e,p} ValidFloat e p => Float e p -> Bool
+
+/* Returns true for numbers that are not an infinity or NaN. */
+fpIsFinite : {e,p} ValidFloat e p => Float e p -> Bool
+fpIsFinite f = ~ (fpIsNaN f \/ fpIsInf f )
+
+
/* ----------------------------------------------------------------------
* Arithmetic
* ---------------------------------------------------------------------- */
@@ -165,7 +186,31 @@
fpDiv : {e,p} ValidFloat e p =>
RoundingMode -> Float e p -> Float e p -> Float e p
+/**
+ * Fused-multiply-add. 'fpFMA r x y z' computes the value '(x*y)+z',
+ * rounding the result according to mode 'r' only after performing both
+ * operations.
+ */
+primitive
+ fpFMA : {e,p} ValidFloat e p =>
+ RoundingMode -> Float e p -> Float e p -> Float e p -> Float e p
+/**
+ * Absolute value of a floating-point value.
+ */
+primitive
+ fpAbs : {e,p} ValidFloat e p =>
+ Float e p -> Float e p
+
+/**
+ * Square root of a floating-point value. The square root of
+ * a negative value yiels NaN, except that the sqaure root of
+ * '-0.0' is '-0.0'.
+ */
+primitive
+ fpSqrt : {e,p} ValidFloat e p =>
+ RoundingMode -> Float e p -> Float e p
+
/* ------------------------------------------------------------ *
* Rationals *
* ------------------------------------------------------------ */
@@ -181,4 +226,3 @@
primitive
fpFromRational : {e,p} ValidFloat e p =>
RoundingMode -> Rational -> Float e p
-
diff --git a/src/Cryptol/Backend.hs b/src/Cryptol/Backend.hs
--- a/src/Cryptol/Backend.hs
+++ b/src/Cryptol/Backend.hs
@@ -27,39 +27,32 @@
, rationalLessThan
, rationalGreaterThan
, iteRational
- , ppRational
) where
import Control.Monad.IO.Class
import Data.Kind (Type)
-import Data.Ratio ( (%), numerator, denominator )
import Cryptol.Backend.FloatHelpers (BF)
-import Cryptol.Backend.Monad ( PPOpts(..), EvalError(..) )
-import Cryptol.TypeCheck.AST(Name)
-import Cryptol.Utils.PP
-
+import Cryptol.Backend.Monad
+ ( EvalError(..), CallStack, pushCallFrame )
+import Cryptol.ModuleSystem.Name(Name)
+import Cryptol.Parser.Position
invalidIndex :: Backend sym => sym -> Integer -> SEval sym a
-invalidIndex sym = raiseError sym . InvalidIndex . Just
+invalidIndex sym i = raiseError sym (InvalidIndex (Just i))
cryUserError :: Backend sym => sym -> String -> SEval sym a
-cryUserError sym = raiseError sym . UserError
+cryUserError sym msg = raiseError sym (UserError msg)
cryNoPrimError :: Backend sym => sym -> Name -> SEval sym a
-cryNoPrimError sym = raiseError sym . NoPrim
-
+cryNoPrimError sym nm = raiseError sym (NoPrim nm)
{-# INLINE sDelay #-}
-- | Delay the given evaluation computation, returning a thunk
-- which will run the computation when forced. Raise a loop
-- error if the resulting thunk is forced during its own evaluation.
-sDelay :: Backend sym => sym -> Maybe String -> SEval sym a -> SEval sym (SEval sym a)
-sDelay sym msg m =
- let msg' = maybe "" ("while evaluating "++) msg
- retry = raiseError sym (LoopError msg')
- in sDelayFill sym m retry
-
+sDelay :: Backend sym => sym -> SEval sym a -> SEval sym (SEval sym a)
+sDelay sym m = sDelayFill sym m Nothing ""
-- | Representation of rational numbers.
-- Invariant: denominator is not 0
@@ -198,16 +191,6 @@
iteRational sym p (SRational a b) (SRational c d) =
SRational <$> iteInteger sym p a c <*> iteInteger sym p b d
-ppRational :: Backend sym => sym -> PPOpts -> SRational sym -> Doc
-ppRational sym opts (SRational n d)
- | Just ni <- integerAsLit sym n
- , Just di <- integerAsLit sym d
- = let q = ni % di in
- text "(ratio" <+> integer (numerator q) <+> (integer (denominator q) <> text ")")
-
- | otherwise
- = text "(ratio" <+> ppInteger sym opts n <+> (ppInteger sym opts d <> text ")")
-
-- | 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.
@@ -234,13 +217,27 @@
-- which will run the computation when forced. Run the 'retry'
-- computation instead if the resulting thunk is forced during
-- its own evaluation.
- sDelayFill :: sym -> SEval sym a -> SEval sym a -> SEval sym (SEval sym a)
+ sDelayFill :: sym -> SEval sym a -> Maybe (SEval sym a) -> String -> SEval sym (SEval sym a)
-- | Begin evaluating the given computation eagerly in a separate thread
-- and return a thunk which will await the completion of the given computation
-- when forced.
sSpark :: sym -> SEval sym a -> SEval sym (SEval sym a)
+ -- | Push a call frame on to the current call stack while evaluating the given action
+ sPushFrame :: sym -> Name -> Range -> SEval sym a -> SEval sym a
+ sPushFrame sym nm rng m = sModifyCallStack sym (pushCallFrame nm rng) m
+
+ -- | Use the given call stack while evaluating the given action
+ sWithCallStack :: sym -> CallStack -> SEval sym a -> SEval sym a
+ sWithCallStack sym stk m = sModifyCallStack sym (\_ -> stk) m
+
+ -- | Apply the given function to the current call stack while evaluating the given action
+ sModifyCallStack :: sym -> (CallStack -> CallStack) -> SEval sym a -> SEval sym a
+
+ -- | Retrieve the current evaluation call stack
+ sGetCallStack :: sym -> SEval sym CallStack
+
-- | Merge the two given computations according to the predicate.
mergeEval ::
sym ->
@@ -257,21 +254,6 @@
-- | Indiciate that an error condition exists
raiseError :: sym -> EvalError -> SEval sym a
-
- -- ==== Pretty printing ====
- -- | Pretty-print an individual bit
- ppBit :: sym -> SBit sym -> Doc
-
- -- | Pretty-print a word value
- ppWord :: sym -> PPOpts -> SWord sym -> Doc
-
- -- | Pretty-print an integer value
- ppInteger :: sym -> PPOpts -> SInteger sym -> Doc
-
- -- | Pretty-print a floating-point value
- ppFloat :: sym -> PPOpts -> SFloat sym -> Doc
-
-
-- ==== Identifying literal values ====
-- | Determine if this symbolic bit is a boolean literal
@@ -291,6 +273,9 @@
-- | Determine if this symbolic integer is a literal
integerAsLit :: sym -> SInteger sym -> Maybe Integer
+ -- | Determine if this symbolic floating-point value is a literal
+ fpAsLit :: sym -> SFloat sym -> Maybe BF
+
-- ==== Creating literal values ====
-- | Construct a literal bit value from a boolean.
@@ -325,6 +310,7 @@
iteBit :: sym -> SBit sym -> SBit sym -> SBit sym -> SEval sym (SBit sym)
iteWord :: sym -> SBit sym -> SWord sym -> SWord sym -> SEval sym (SWord sym)
iteInteger :: sym -> SBit sym -> SInteger sym -> SInteger sym -> SEval sym (SInteger sym)
+ iteFloat :: sym -> SBit sym -> SFloat sym -> SFloat sym -> SEval sym (SFloat sym)
-- ==== Bit operations ====
bitEq :: sym -> SBit sym -> SBit sym -> SEval sym (SBit sym)
@@ -333,7 +319,6 @@
bitXor :: sym -> SBit sym -> SBit sym -> SEval sym (SBit sym)
bitComplement :: sym -> SBit sym -> SEval sym (SBit sym)
-
-- ==== Word operations ====
-- | Extract the numbered bit from the word.
@@ -674,7 +659,7 @@
SInteger sym ->
SEval sym (SBit sym)
- -- | Multiplicitive inverse in (Z n).
+ -- | Multiplicative inverse in (Z n).
-- PRECONDITION: the modulus is a prime
znRecip ::
sym ->
@@ -689,21 +674,51 @@
fpLogicalEq :: sym -> SFloat sym -> SFloat sym -> SEval sym (SBit sym)
+ fpNaN :: sym -> Integer {- ^ exponent bits -} -> Integer {- ^ precision bits -} -> SEval sym (SFloat sym)
+ fpPosInf :: sym -> Integer {- ^ exponent bits -} -> Integer {- ^ precision bits -} -> SEval sym (SFloat sym)
+
fpPlus, fpMinus, fpMult, fpDiv :: FPArith2 sym
- fpNeg :: sym -> SFloat sym -> SEval sym (SFloat sym)
+ fpNeg, fpAbs :: sym -> SFloat sym -> SEval sym (SFloat sym)
+ fpSqrt :: sym -> SWord sym -> SFloat sym -> SEval sym (SFloat sym)
+ fpFMA :: sym -> SWord sym -> SFloat sym -> SFloat sym -> SFloat sym -> SEval sym (SFloat sym)
+
+ fpIsZero, fpIsNeg, fpIsNaN, fpIsInf, fpIsNorm, fpIsSubnorm :: sym -> SFloat sym -> SEval sym (SBit sym)
+
+ fpToBits :: sym -> SFloat sym -> SEval sym (SWord sym)
+ fpFromBits ::
+ sym ->
+ Integer {- ^ exponent bits -} ->
+ Integer {- ^ precision bits -} ->
+ SWord sym ->
+ SEval sym (SFloat sym)
+
fpToInteger ::
sym ->
String {- ^ Name of the function for error reporting -} ->
- SWord sym {-^ Rounding mode -} ->
- SFloat sym -> SEval sym (SInteger sym)
+ SWord sym {- ^ Rounding mode -} ->
+ SFloat sym ->
+ SEval sym (SInteger sym)
fpFromInteger ::
sym ->
- Integer {- exp width -} ->
- Integer {- prec width -} ->
+ Integer {- ^ exp width -} ->
+ Integer {- ^ prec width -} ->
SWord sym {- ^ rounding mode -} ->
- SInteger sym {- ^ the integeer to use -} ->
+ SInteger sym {- ^ the integer to use -} ->
+ SEval sym (SFloat sym)
+
+ fpToRational ::
+ sym ->
+ SFloat sym ->
+ SEval sym (SRational sym)
+
+ fpFromRational ::
+ sym ->
+ Integer {- ^ exp width -} ->
+ Integer {- ^ prec width -} ->
+ SWord sym {- ^ rounding mode -} ->
+ SRational sym ->
SEval sym (SFloat sym)
type FPArith2 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
@@ -37,6 +37,7 @@
import qualified Control.Exception as X
import Data.Bits
+import Data.Ratio
import Numeric (showIntAtBase)
import qualified LibBF as FP
import qualified GHC.Integer.GMP.Internals as Integer
@@ -136,10 +137,12 @@
type SFloat Concrete = FP.BF
type SEval Concrete = Eval
- raiseError _ err = io (X.throwIO err)
+ raiseError _ err =
+ do stk <- getCallStack
+ io (X.throwIO (EvalErrorEx stk err))
assertSideCondition _ True _ = return ()
- assertSideCondition _ False err = io (X.throwIO err)
+ assertSideCondition sym False err = raiseError sym err
wordLen _ (BV w _) = w
wordAsChar _ (BV _ x) = Just $! integerToChar x
@@ -160,15 +163,8 @@
sDeclareHole _ = blackhole
sDelayFill _ = delayFill
sSpark _ = evalSpark
-
- ppBit _ b | b = text "True"
- | otherwise = text "False"
-
- ppWord _ = ppBV
-
- ppInteger _ _opts i = integer i
-
- ppFloat _ = FP.fpPP
+ sModifyCallStack _ f m = modifyCallStack f m
+ sGetCallStack _ = getCallStack
bitLit _ b = b
bitAsLit _ b = Just b
@@ -182,6 +178,7 @@
iteBit _ b x y = pure $! if b then x else y
iteWord _ b x y = pure $! if b then x else y
iteInteger _ b x y = pure $! if b then x else y
+ iteFloat _ b x y = pure $! if b then x else y
wordLit _ w i = pure $! mkBv w i
wordAsLit _ (BV w i) = Just (w,i)
@@ -331,6 +328,11 @@
------------------------------------------------------------------------
-- Floating Point
fpLit _sym e p rat = pure (FP.fpLit e p rat)
+
+ fpNaN _sym e p = pure (FP.BF e p FP.bfNaN)
+ fpPosInf _sym e p = pure (FP.BF e p FP.bfPosInf)
+
+ fpAsLit _ f = Just f
fpExactLit _sym bf = pure bf
fpEq _sym x y = pure (FP.bfValue x == FP.bfValue y)
fpLogicalEq _sym x y = pure (FP.bfCompare (FP.bfValue x) (FP.bfValue y) == EQ)
@@ -340,17 +342,51 @@
fpMinus = fpBinArith FP.bfSub
fpMult = fpBinArith FP.bfMul
fpDiv = fpBinArith FP.bfDiv
- fpNeg _ x = pure x { FP.bfValue = FP.bfNeg (FP.bfValue x) }
+ fpNeg _ x = pure $! x { FP.bfValue = FP.bfNeg (FP.bfValue x) }
+
+ fpAbs _ x = pure $! x { FP.bfValue = FP.bfAbs (FP.bfValue x) }
+ fpSqrt sym r x =
+ do r' <- fpRoundMode sym r
+ let opts = FP.fpOpts (FP.bfExpWidth x) (FP.bfPrecWidth x) r'
+ pure $! x{ FP.bfValue = FP.fpCheckStatus (FP.bfSqrt opts (FP.bfValue x)) }
+
+ fpFMA sym r x y z =
+ do r' <- fpRoundMode sym r
+ let opts = FP.fpOpts (FP.bfExpWidth x) (FP.bfPrecWidth x) r'
+ pure $! x { FP.bfValue = FP.fpCheckStatus (FP.bfFMA opts (FP.bfValue x) (FP.bfValue y) (FP.bfValue z)) }
+
+ fpIsZero _ x = pure (FP.bfIsZero (FP.bfValue x))
+ fpIsNeg _ x = pure (FP.bfIsNeg (FP.bfValue x))
+ fpIsNaN _ x = pure (FP.bfIsNaN (FP.bfValue x))
+ fpIsInf _ x = pure (FP.bfIsInf (FP.bfValue x))
+ fpIsNorm _ x =
+ let opts = FP.fpOpts (FP.bfExpWidth x) (FP.bfPrecWidth x) FP.NearEven
+ in pure (FP.bfIsNormal opts (FP.bfValue x))
+ fpIsSubnorm _ x =
+ let opts = FP.fpOpts (FP.bfExpWidth x) (FP.bfPrecWidth x) FP.NearEven
+ in pure (FP.bfIsSubnormal opts (FP.bfValue x))
+
+ fpFromBits _sym e p bv = pure (FP.floatFromBits e p (bvVal bv))
+ fpToBits _sym (FP.BF e p v) = pure (mkBv (e+p) (FP.floatToBits e p v))
+
fpFromInteger sym e p r x =
- do opts <- FP.fpOpts e p <$> fpRoundMode sym r
+ do r' <- fpRoundMode sym r
pure FP.BF { FP.bfExpWidth = e
, FP.bfPrecWidth = p
, FP.bfValue = FP.fpCheckStatus $
- FP.bfRoundInt opts (FP.bfFromInteger x)
+ FP.bfRoundInt r' (FP.bfFromInteger x)
}
fpToInteger = fpCvtToInteger
+ fpFromRational sym e p r x =
+ do mode <- fpRoundMode sym r
+ pure (FP.floatFromRational e p mode (sNum x % sDenom x))
+ fpToRational sym fp =
+ case FP.floatToRational "fpToRational" fp of
+ Left err -> raiseError sym err
+ Right r -> pure $ SRational { sNum = numerator r, sDenom = denominator r }
+
{-# INLINE liftBinIntMod #-}
liftBinIntMod :: Monad m =>
(Integer -> Integer -> Integer) -> Integer -> Integer -> Integer -> m Integer
@@ -371,7 +407,7 @@
fpBinArith fun = \sym r x y ->
do opts <- FP.fpOpts (FP.bfExpWidth x) (FP.bfPrecWidth x)
<$> fpRoundMode sym r
- pure x { FP.bfValue = FP.fpCheckStatus
+ pure $! x { FP.bfValue = FP.fpCheckStatus
(fun opts (FP.bfValue x) (FP.bfValue y)) }
fpCvtToInteger ::
@@ -391,8 +427,3 @@
case FP.fpRound (bvVal w) of
Left err -> raiseError sym err
Right a -> pure a
-
-
-
-
-
diff --git a/src/Cryptol/Backend/FloatHelpers.hs b/src/Cryptol/Backend/FloatHelpers.hs
--- a/src/Cryptol/Backend/FloatHelpers.hs
+++ b/src/Cryptol/Backend/FloatHelpers.hs
@@ -2,22 +2,19 @@
{-# Language BangPatterns #-}
module Cryptol.Backend.FloatHelpers where
+import Data.Char (isDigit)
import Data.Ratio(numerator,denominator)
-import Data.Int(Int64)
-import Data.Bits(testBit,setBit,shiftL,shiftR,(.&.),(.|.))
import LibBF
import Cryptol.Utils.PP
import Cryptol.Utils.Panic(panic)
-import Cryptol.Backend.Monad( EvalError(..)
- , PPOpts(..), PPFloatFormat(..), PPFloatExp(..)
- )
+import Cryptol.Backend.Monad( EvalError(..) )
data BF = BF
- { bfExpWidth :: Integer
- , bfPrecWidth :: Integer
- , bfValue :: BigFloat
+ { bfExpWidth :: !Integer
+ , bfPrecWidth :: !Integer
+ , bfValue :: !BigFloat
}
@@ -86,19 +83,32 @@
str = bfToString base fmt num
fmt = addPrefix <> showRnd NearEven <>
case useFPFormat opts of
- FloatFree e -> withExp e $ showFreeMin
+ FloatFree e -> withExp e $ showFree
$ Just $ fromInteger precW
FloatFixed n e -> withExp e $ showFixed $ fromIntegral n
FloatFrac n -> showFrac $ fromIntegral n
-- non-base 10 literals are not overloaded so we add an explicit
- -- .0 if one is not present.
+ -- .0 if one is not present. Moreover, we trim any extra zeros
+ -- that appear in a decimal representation.
hacStr
- | base == 10 || elem '.' str = str
+ | base == 10 = trimZeros
+ | elem '.' str = str
| otherwise = case break (== 'p') str of
(xs,ys) -> xs ++ ".0" ++ ys
+ trimZeros =
+ case break (== '.') str of
+ (xs,'.':ys) ->
+ case break (not . isDigit) ys of
+ (frac, suffix) -> xs ++ '.' : processFraction frac ++ suffix
+ _ -> str
+ processFraction frac =
+ case dropWhile (== '0') (reverse frac) of
+ [] -> "0"
+ zs -> reverse zs
+
-- | Make a literal
fpLit ::
Integer {- ^ Exponent width -} ->
@@ -152,97 +162,17 @@
["Unexpected rounding mode", show r]
-
-
floatFromBits ::
Integer {- ^ Exponent width -} ->
Integer {- ^ Precision widht -} ->
Integer {- ^ Raw bits -} ->
BF
-floatFromBits e p bv = BF { bfValue = floatFromBits' e p bv
+floatFromBits e p bv = BF { bfValue = bfFromBits (fpOpts e p NearEven) bv
, bfExpWidth = e, bfPrecWidth = p }
-
--- | Make a float using "raw" bits.
-floatFromBits' ::
- Integer {- ^ Exponent width -} ->
- Integer {- ^ Precision widht -} ->
- Integer {- ^ Raw bits -} ->
- BigFloat
-
-floatFromBits' e p bits
- | expoBiased == 0 && mant == 0 = -- zero
- if isNeg then bfNegZero else bfPosZero
-
- | expoBiased == eMask && mant == 0 = -- infinity
- if isNeg then bfNegInf else bfPosInf
-
- | expoBiased == eMask = bfNaN -- NaN
-
- | expoBiased == 0 = -- Subnormal
- case bfMul2Exp opts (bfFromInteger mant) (expoVal + 1) of
- (num,Ok) -> if isNeg then bfNeg num else num
- (_,s) -> panic "floatFromBits" [ "Unexpected status: " ++ show s ]
-
- | otherwise = -- Normal
- case bfMul2Exp opts (bfFromInteger mantVal) expoVal of
- (num,Ok) -> if isNeg then bfNeg num else num
- (_,s) -> panic "floatFromBits" [ "Unexpected status: " ++ show s ]
-
- where
- opts = expBits e' <> precBits (p' + 1) <> allowSubnormal
-
- e' = fromInteger e :: Int
- p' = fromInteger p - 1 :: Int
- eMask = (1 `shiftL` e') - 1 :: Int64
- pMask = (1 `shiftL` p') - 1 :: Integer
-
- isNeg = testBit bits (e' + p')
-
- mant = pMask .&. bits :: Integer
- mantVal = mant `setBit` p' :: Integer
- -- accounts for the implicit 1 bit
-
- expoBiased = eMask .&. fromInteger (bits `shiftR` p') :: Int64
- bias = eMask `shiftR` 1 :: Int64
- expoVal = expoBiased - bias - fromIntegral p' :: Int64
-
-
-- | Turn a float into raw bits.
-- @NaN@ is represented as a positive "quiet" @NaN@
-- (most significant bit in the significand is set, the rest of it is 0)
floatToBits :: Integer -> Integer -> BigFloat -> Integer
-floatToBits e p bf = (isNeg `shiftL` (e' + p'))
- .|. (expBiased `shiftL` p')
- .|. (mant `shiftL` 0)
- where
- e' = fromInteger e :: Int
- p' = fromInteger p - 1 :: Int
-
- eMask = (1 `shiftL` e') - 1 :: Integer
- pMask = (1 `shiftL` p') - 1 :: Integer
-
- (isNeg, expBiased, mant) =
- case bfToRep bf of
- BFNaN -> (0, eMask, 1 `shiftL` (p' - 1))
- BFRep s num -> (sign, be, ma)
- where
- sign = case s of
- Neg -> 1
- Pos -> 0
-
- (be,ma) =
- case num of
- Zero -> (0,0)
- Num i ev
- | ex == 0 -> (0, i `shiftL` (p' - m -1))
- | otherwise -> (ex, (i `shiftL` (p' - m)) .&. pMask)
- where
- m = msb 0 i - 1
- bias = eMask `shiftR` 1
- ex = toInteger ev + bias + toInteger m
-
- Inf -> (eMask,0)
-
- msb !n j = if j == 0 then n else msb (n+1) (j `shiftR` 1)
+floatToBits e p bf = bfToBits (fpOpts e p NearEven) bf
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
@@ -1,6 +1,6 @@
-- |
--- Module : Cryptol.Eval.Monad
--- Copyright : (c) 2013-2016 Galois, Inc.
+-- Module : Cryptol.Backend.Monad
+-- Copyright : (c) 2013-2020 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
@@ -16,80 +16,97 @@
( -- * Evaluation monad
Eval(..)
, runEval
-, EvalOpts(..)
-, PPOpts(..)
-, asciiMode
-, PPFloatFormat(..)
-, PPFloatExp(..)
-, defaultPPOpts
, io
, delayFill
, ready
, blackhole
, evalSpark
, maybeReady
+ -- * Call stacks
+, CallStack
+, getCallStack
+, withCallStack
+, modifyCallStack
+, combineCallStacks
+, pushCallFrame
+, displayCallStack
-- * Error reporting
, Unsupported(..)
, EvalError(..)
+, EvalErrorEx(..)
, evalPanic
, wordTooWide
-, typeCannotBeDemoted
+, WordTooWide(..)
) where
import Control.Concurrent
import Control.Concurrent.STM
import Control.Monad
-import qualified Control.Monad.Fail as Fail
-import Control.Monad.Fix
import Control.Monad.IO.Class
+import Data.Foldable (toList)
+import Data.Sequence (Seq)
+import qualified Data.Sequence as Seq
import Data.Typeable (Typeable)
import qualified Control.Exception as X
+import Cryptol.Parser.Position
import Cryptol.Utils.Panic
import Cryptol.Utils.PP
-import Cryptol.Utils.Logger(Logger)
-import Cryptol.TypeCheck.AST(Type,Name)
+import Cryptol.TypeCheck.AST(Name)
-- | A computation that returns an already-evaluated value.
ready :: a -> Eval a
ready a = Ready a
--- | How to pretty print things when evaluating
-data PPOpts = PPOpts
- { useAscii :: Bool
- , useBase :: Int
- , useInfLength :: Int
- , useFPBase :: Int
- , useFPFormat :: PPFloatFormat
- }
-asciiMode :: PPOpts -> Integer -> Bool
-asciiMode opts width = useAscii opts && (width == 7 || width == 8)
+-- | 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 PPFloatFormat =
- FloatFixed Int PPFloatExp -- ^ Use this many significant digis
- | FloatFrac Int -- ^ Show this many digits after floating point
- | FloatFree PPFloatExp -- ^ Use the correct number of digits
+-- | 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
+ where
+ f (nm,rng)
+ | rng == emptyRange = pp nm
+ | otherwise = pp nm <+> text "called at" <+> pp rng
-data PPFloatExp = ForceExponent -- ^ Always show an exponent
- | AutoExponent -- ^ Only show exponent when needed
+-- | Combine the call stack of a function value with the call
+-- stack of the current calling context. This algorithm is
+-- the same one GHC uses to compute profiling calling contexts.
+--
+-- The algorithm is as follows.
+--
+-- ccs ++> ccsfn = ccs ++ dropCommonPrefix ccs ccsfn
+--
+-- where
+--
+-- dropCommonPrefix A B
+-- -- returns the suffix of B after removing any prefix common
+-- -- to both A and B.
+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
+ dropCommonPrefix (a Seq.:<| as) xs@(f Seq.:<| fs)
+ | a == f = dropCommonPrefix as fs
+ | otherwise = xs
-defaultPPOpts :: PPOpts
-defaultPPOpts = PPOpts { useAscii = False, useBase = 10, useInfLength = 5
- , useFPBase = 16
- , useFPFormat = FloatFree AutoExponent
- }
+-- | Add a call frame to the top of a call stack
+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)
--- | Some options for evalutaion
-data EvalOpts = EvalOpts
- { evalLogger :: Logger -- ^ Where to print stuff (e.g., for @trace@)
- , evalPPOpts :: PPOpts -- ^ How to pretty print things.
- }
-
-- | The monad for Cryptol evaluation.
-- A computation is either "ready", which means it represents
-- only trivial computation, or is an "eval" action which must
@@ -97,7 +114,7 @@
-- represents a delayed, shared computation.
data Eval a
= Ready !a
- | Eval !(IO a)
+ | Eval !(CallStack -> IO a)
| Thunk !(TVar (ThunkState a))
-- | This datastructure tracks the lifecycle of a thunk.
@@ -107,7 +124,7 @@
-- cryptol expression that is bound to a name, and is not
-- already obviously a value (and in a few other places as
-- well) will get turned into a thunk in order to avoid
--- recomputations. These thunks will start in the `Unforced`
+-- recomputation. These thunks will start in the `Unforced`
-- state, and have a backup computation that just raises
-- the `LoopError` exception.
--
@@ -129,16 +146,20 @@
data ThunkState a
= Void !String
-- ^ This thunk has not yet been initialized
- | Unforced !(IO a) !(IO a)
+ | Unforced !(IO a) !(Maybe (IO a)) !String !CallStack
-- ^ This thunk has not yet been forced. We keep track of the "main"
- -- computation to run and a "backup" computation to run if we
+ -- computation to run and an optional "backup" computation to run if we
-- detect a tight loop when evaluating the first one.
- | UnderEvaluation !ThreadId !(IO a)
+ -- The final two arguments are used to throw a loop exception
+ -- if the backup computation also causes a tight loop.
+ | UnderEvaluation !ThreadId !(Maybe (IO a)) !String !CallStack
-- ^ This thunk is currently being evaluated by the thread with the given
- -- thread ID. We track the "backup" computation to run if we detect
+ -- thread ID. We track an optional "backup" computation to run if we detect
-- a tight loop evaluating this thunk. If the thunk is being evaluated
-- by some other thread, the current thread will await its completion.
- | ForcedErr !EvalError
+ -- The final two arguments are used to throw a loop exception
+ -- if the backup computation also causes a tight loop.
+ | ForcedErr !EvalErrorEx
-- ^ This thunk has been forced, and its evaluation results in an exception
| Forced !a
-- ^ This thunk has been forced to the given value
@@ -148,7 +169,7 @@
-- it requires no computation to return.
maybeReady :: Eval a -> Eval (Maybe a)
maybeReady (Ready a) = pure (Just a)
-maybeReady (Thunk tv) = Eval $
+maybeReady (Thunk tv) = Eval $ \_ ->
readTVarIO tv >>= \case
Forced a -> pure (Just a)
_ -> pure Nothing
@@ -163,11 +184,13 @@
-- its own evaluation.
delayFill ::
Eval a {- ^ Computation to delay -} ->
- Eval a {- ^ Backup computation to run if a tight loop is detected -} ->
+ Maybe (Eval a) {- ^ Optional backup computation to run if a tight loop is detected -} ->
+ String {- ^ message for the <> exception if a tight loop is detected -} ->
Eval (Eval a)
-delayFill e@(Ready _) _ = return e
-delayFill e@(Thunk _) _ = return e
-delayFill (Eval x) backup = Eval (Thunk <$> newTVarIO (Unforced x (runEval backup)))
+delayFill e@(Ready _) _ _ = return e
+delayFill e@(Thunk _) _ _ = return e
+delayFill (Eval x) backup msg =
+ Eval (\stk -> Thunk <$> newTVarIO (Unforced (x stk) (runEval stk <$> backup) msg stk))
-- | Begin executing the given operation in a separate thread,
-- returning a thunk which will await the completion of
@@ -183,24 +206,24 @@
-- been forced. If so, return the result. Otherwise,
-- fork a thread to force this computation and return
-- the thunk.
-evalSpark (Thunk tv) = Eval $
+evalSpark (Thunk tv) = Eval $ \_stk ->
readTVarIO tv >>= \case
Forced x -> return (Ready x)
- ForcedErr ex -> return (Eval (X.throwIO ex))
+ ForcedErr ex -> return (Eval $ \_ -> (X.throwIO ex))
_ ->
do _ <- forkIO (sparkThunk tv)
return (Thunk tv)
-- If the computation is nontrivial but not already a thunk,
-- create a thunk and fork a thread to force it.
-evalSpark (Eval x) = Eval $
- do tv <- newTVarIO (Unforced x (X.throwIO (LoopError "")))
+evalSpark (Eval x) = Eval $ \stk ->
+ do tv <- newTVarIO (Unforced (x stk) Nothing "" stk)
_ <- forkIO (sparkThunk tv)
return (Thunk tv)
-- | To the work of forcing a thunk. This is the worker computation
--- that is foked off via @evalSpark@.
+-- that is forked off via @evalSpark@.
sparkThunk :: TVar (ThunkState a) -> IO ()
sparkThunk tv =
do tid <- myThreadId
@@ -212,13 +235,13 @@
do st <- readTVar tv
case st of
Void _ -> retry
- Unforced _ backup -> writeTVar tv (UnderEvaluation tid backup)
+ Unforced _ backup msg stk -> writeTVar tv (UnderEvaluation tid backup msg stk)
_ -> return ()
return st
-- If we successfully claimed the thunk to work on, run the computation and
-- update the thunk state with the result.
case st of
- Unforced work _ ->
+ Unforced work _ _ _ ->
X.try work >>= \case
Left err -> atomically (writeTVar tv (ForcedErr err))
Right a -> atomically (writeTVar tv (Forced a))
@@ -232,10 +255,10 @@
blackhole ::
String {- ^ A name to associate with this thunk. -} ->
Eval (Eval a, Eval a -> Eval ())
-blackhole msg = Eval $
+blackhole msg = Eval $ \stk ->
do tv <- newTVarIO (Void msg)
let set (Ready x) = io $ atomically (writeTVar tv (Forced x))
- set m = io $ atomically (writeTVar tv (Unforced (runEval m) (X.throwIO (LoopError msg))))
+ set m = io $ atomically (writeTVar tv (Unforced (runEval stk m) Nothing msg stk))
return (Thunk tv, set)
-- | Force a thunk to get the result.
@@ -254,16 +277,19 @@
case res of
-- In this case, we claim the thunk. Update the state to indicate
-- that we are working on it.
- Unforced _ backup -> writeTVar tv (UnderEvaluation tid backup)
+ Unforced _ backup msg stk -> writeTVar tv (UnderEvaluation tid backup msg stk)
-- In this case, the thunk is already being evaluated. If it is
-- under evaluation by this thread, we have to run the backup computation,
-- and "consume" it by updating the backup computation to one that throws
-- a loop error. If some other thread is evaluating, reset the
-- transaction to await completion of the thunk.
- UnderEvaluation t _
- | tid == t -> writeTVar tv (UnderEvaluation tid (X.throwIO (LoopError "")))
- | otherwise -> retry -- wait, if some other thread is evaualting
+ UnderEvaluation t backup msg stk
+ | tid == t ->
+ case backup of
+ Just _ -> writeTVar tv (UnderEvaluation tid Nothing msg stk)
+ Nothing -> writeTVar tv (ForcedErr (EvalErrorEx stk (LoopError msg)))
+ | otherwise -> retry -- wait, if some other thread is evaluating
_ -> return ()
-- Return the original thunk state so we can decide what work to do
@@ -283,25 +309,43 @@
Void msg -> evalPanic "unDelay" ["Thunk forced before it was initialized", msg]
Forced x -> pure x
ForcedErr e -> X.throwIO e
- UnderEvaluation _ backup -> doWork backup -- this thread was already evaluating this thunk
- Unforced work _ -> doWork work
+ -- this thread was already evaluating this thunk
+ UnderEvaluation _ (Just backup) _ _ -> doWork backup
+ UnderEvaluation _ Nothing msg stk -> X.throwIO (EvalErrorEx stk (LoopError msg))
+ Unforced work _ _ _ -> doWork work
+-- | Get the current call stack
+getCallStack :: Eval CallStack
+getCallStack = Eval (\stk -> pure stk)
+
+-- | Execute the action with the given call stack
+withCallStack :: CallStack -> Eval a -> Eval a
+withCallStack stk m = Eval (\_ -> runEval stk m)
+
+-- | Run the given action with a modify call stack
+modifyCallStack :: (CallStack -> CallStack) -> Eval a -> Eval a
+modifyCallStack f m =
+ Eval $ \stk ->
+ do let stk' = f stk
+ -- putStrLn $ unwords ["Pushing call stack", show (displayCallStack stk')]
+ runEval stk' m
+
-- | Execute the given evaluation action.
-runEval :: Eval a -> IO a
-runEval (Ready a) = return a
-runEval (Eval x) = x
-runEval (Thunk tv) = unDelay tv
+runEval :: CallStack -> Eval a -> IO a
+runEval _ (Ready a) = return a
+runEval stk (Eval x) = x stk
+runEval _ (Thunk tv) = unDelay tv
{-# INLINE evalBind #-}
evalBind :: Eval a -> (a -> Eval b) -> Eval b
evalBind (Ready a) f = f a
-evalBind (Eval x) f = Eval (x >>= runEval . f)
-evalBind (Thunk x) f = Eval (unDelay x >>= runEval . f)
+evalBind (Eval x) f = Eval (\stk -> x stk >>= runEval stk . f)
+evalBind (Thunk x) f = Eval (\stk -> unDelay x >>= runEval stk . f)
instance Functor Eval where
fmap f (Ready x) = Ready (f x)
- fmap f (Eval m) = Eval (f <$> m)
- fmap f (Thunk tv) = Eval (f <$> unDelay tv)
+ fmap f (Eval m) = Eval (\stk -> f <$> m stk)
+ fmap f (Thunk tv) = Eval (\_ -> f <$> unDelay tv)
{-# INLINE fmap #-}
instance Applicative Eval where
@@ -316,18 +360,12 @@
{-# INLINE return #-}
{-# INLINE (>>=) #-}
-instance Fail.MonadFail Eval where
- fail x = Eval (fail x)
-
instance MonadIO Eval where
liftIO = io
-instance MonadFix Eval where
- mfix f = Eval $ mfix (\x -> runEval (f x))
-
-- | Lift an 'IO' computation into the 'Eval' monad.
io :: IO a -> Eval a
-io m = Eval m
+io m = Eval (\_stk -> m)
{-# INLINE io #-}
@@ -341,37 +379,53 @@
-- | Data type describing errors that can occur during evaluation.
data EvalError
= InvalidIndex (Maybe Integer) -- ^ Out-of-bounds index
- | TypeCannotBeDemoted Type -- ^ Non-numeric type passed to @number@ function
| DivideByZero -- ^ Division or modulus by 0
| NegativeExponent -- ^ Exponentiation by negative integer
| LogNegative -- ^ Logarithm of a negative integer
- | WordTooWide Integer -- ^ Bitvector too large
| UserError String -- ^ Call to the Cryptol @error@ primitive
| LoopError String -- ^ Detectable nontermination
| NoPrim Name -- ^ Primitive with no implementation
| BadRoundingMode Integer -- ^ Invalid rounding mode
| BadValue String -- ^ Value outside the domain of a partial function.
- deriving (Typeable,Show)
+ deriving Typeable
instance PP EvalError where
ppPrec _ e = case e of
InvalidIndex (Just i) -> text "invalid sequence index:" <+> integer i
InvalidIndex Nothing -> text "invalid sequence index"
- TypeCannotBeDemoted t -> text "type cannot be demoted:" <+> pp t
DivideByZero -> text "division by 0"
NegativeExponent -> text "negative exponent"
LogNegative -> text "logarithm of negative"
- WordTooWide w ->
- text "word too wide for memory:" <+> integer w <+> text "bits"
UserError x -> text "Run-time error:" <+> text x
- LoopError x -> text "<>" <+> text x
+ LoopError x -> vcat [ text "<>" <+> text x
+ , text "This usually occurs due to an improper recursive definition,"
+ , text "but may also result from retrying a previously interrupted"
+ , text "computation (e.g., after CTRL^C). In that case, you may need to"
+ , text "`:reload` the current module to reset to a good state."
+ ]
BadRoundingMode r -> "invalid rounding mode" <+> integer r
BadValue x -> "invalid input for" <+> backticks (text x)
NoPrim x -> text "unimplemented primitive:" <+> pp x
-instance X.Exception EvalError
+instance Show EvalError where
+ show = show . pp
+data EvalErrorEx =
+ EvalErrorEx CallStack EvalError
+ deriving Typeable
+instance PP EvalErrorEx where
+ ppPrec _ (EvalErrorEx stk ex) = vcat ([ pp ex ] ++ callStk)
+
+ where
+ callStk | Seq.null stk = []
+ | otherwise = [ text "-- Backtrace --", displayCallStack stk ]
+
+instance Show EvalErrorEx where
+ show = show . pp
+
+instance X.Exception EvalErrorEx
+
data Unsupported
= UnsupportedSymbolicOp String -- ^ Operation cannot be supported in the symbolic simulator
deriving (Typeable,Show)
@@ -382,13 +436,20 @@
instance X.Exception Unsupported
-
--- | For things like @`(inf)@ or @`(0-1)@.
-typeCannotBeDemoted :: Type -> a
-typeCannotBeDemoted t = X.throw (TypeCannotBeDemoted t)
-
-- | For when we know that a word is too wide and will exceed gmp's
-- limits (though words approaching this size will probably cause the
-- system to crash anyway due to lack of memory).
wordTooWide :: Integer -> a
wordTooWide w = X.throw (WordTooWide w)
+
+data WordTooWide = WordTooWide Integer -- ^ Bitvector too large
+ deriving Typeable
+
+instance PP WordTooWide where
+ ppPrec _ (WordTooWide w) =
+ text "word too wide for memory:" <+> integer w <+> text "bits"
+
+instance Show WordTooWide where
+ show = show . pp
+
+instance X.Exception WordTooWide
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
@@ -6,6 +6,7 @@
-- Stability : provisional
-- Portability : portable
+{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
@@ -43,14 +44,14 @@
import qualified Data.SBV.Internals as SBV
import Cryptol.Backend
-import Cryptol.Backend.Concrete ( integerToChar, ppBV, BV(..) )
+import Cryptol.Backend.Concrete ( integerToChar )
import Cryptol.Backend.Monad
( Eval(..), blackhole, delayFill, evalSpark
- , EvalError(..), Unsupported(..)
+ , EvalError(..), EvalErrorEx(..), Unsupported(..)
+ , modifyCallStack, getCallStack
)
import Cryptol.Utils.Panic (panic)
-import Cryptol.Utils.PP
data SBV =
SBV
@@ -73,23 +74,30 @@
literalSWord :: Int -> Integer -> SWord SBV
literalSWord w i = svInteger (KBounded False w) i
+svMkSymVar_ :: Maybe Quantifier -> Kind -> Maybe String -> SBV.State -> IO SVal
+#if MIN_VERSION_sbv(8,8,0)
+svMkSymVar_ = svMkSymVar . SBV.NonQueryVar
+#else
+svMkSymVar_ = svMkSymVar
+#endif
+
freshBV_ :: SBV -> Int -> IO (SWord SBV)
freshBV_ (SBV stateVar _) w =
- withMVar stateVar (svMkSymVar Nothing (KBounded False w) Nothing)
+ withMVar stateVar (svMkSymVar_ Nothing (KBounded False w) Nothing)
freshSBool_ :: SBV -> IO (SBit SBV)
freshSBool_ (SBV stateVar _) =
- withMVar stateVar (svMkSymVar Nothing KBool Nothing)
+ withMVar stateVar (svMkSymVar_ Nothing KBool Nothing)
freshSInteger_ :: SBV -> IO (SInteger SBV)
freshSInteger_ (SBV stateVar _) =
- withMVar stateVar (svMkSymVar Nothing KUnbounded Nothing)
+ withMVar stateVar (svMkSymVar_ Nothing KUnbounded Nothing)
-- SBV Evaluation monad -------------------------------------------------------
data SBVResult a
- = SBVError !EvalError
+ = SBVError !EvalErrorEx
| SBVResult !SVal !a -- safety predicate and result
instance Functor SBVResult where
@@ -146,17 +154,19 @@
type SFloat SBV = () -- XXX: not implemented
type SEval SBV = SBVEval
- raiseError _ err = SBVEval (pure (SBVError err))
+ raiseError _ err = SBVEval $
+ do stk <- getCallStack
+ pure (SBVError (EvalErrorEx stk err))
- assertSideCondition _ cond err
- | Just False <- svAsBool cond = SBVEval (pure (SBVError err))
+ assertSideCondition sym cond err
+ | Just False <- svAsBool cond = raiseError sym err
| otherwise = SBVEval (pure (SBVResult cond ()))
isReady _ (SBVEval (Ready _)) = True
isReady _ _ = False
- sDelayFill _ m retry = SBVEval $
- do m' <- delayFill (sbvEval m) (sbvEval retry)
+ sDelayFill _ m retry msg = SBVEval $
+ do m' <- delayFill (sbvEval m) (sbvEval <$> retry) msg
pure (pure (SBVEval m'))
sSpark _ m = SBVEval $
@@ -167,6 +177,11 @@
do (hole, fill) <- blackhole msg
pure (pure (SBVEval hole, \m -> SBVEval (fmap pure $ fill (sbvEval m))))
+ sModifyCallStack _ f (SBVEval m) = SBVEval $
+ modifyCallStack f m
+
+ sGetCallStack _ = SBVEval (pure <$> getCallStack)
+
mergeEval _sym f c mx my = SBVEval $
do rx <- sbvEval mx
ry <- sbvEval my
@@ -187,16 +202,6 @@
wordLen _ v = toInteger (intSizeOf v)
wordAsChar _ v = integerToChar <$> svAsInteger v
- ppBit _ v
- | Just b <- svAsBool v = text $! if b then "True" else "False"
- | otherwise = text "?"
- ppWord sym opts v
- | Just x <- svAsInteger v = ppBV opts (BV (wordLen sym v) x)
- | otherwise = text "[?]"
- ppInteger _ _opts v
- | Just x <- svAsInteger v = integer x
- | otherwise = text "[?]"
-
iteBit _ b x y = pure $! svSymbolicMerge KBool True b x y
iteWord _ b x y = pure $! svSymbolicMerge (kindOf x) True b x y
iteInteger _ b x y = pure $! svSymbolicMerge KUnbounded True b x y
@@ -319,20 +324,37 @@
znNegate sym m a = sModNegate sym m a
znRecip = sModRecip
- ppFloat _ _ _ = text "[?]"
- fpExactLit _ _ = unsupported "fpExactLit"
- fpLit _ _ _ _ = unsupported "fpLit"
- fpLogicalEq _ _ _ = unsupported "fpLogicalEq"
- fpEq _ _ _ = unsupported "fpEq"
- fpLessThan _ _ _ = unsupported "fpLessThan"
- fpGreaterThan _ _ _ = unsupported "fpGreaterThan"
- fpPlus _ _ _ _ = unsupported "fpPlus"
- fpMinus _ _ _ _ = unsupported "fpMinus"
- fpMult _ _ _ _ = unsupported "fpMult"
- fpDiv _ _ _ _ = unsupported "fpDiv"
- fpNeg _ _ = unsupported "fpNeg"
- fpFromInteger _ _ _ _ _ = unsupported "fpFromInteger"
- fpToInteger _ _ _ _ = unsupported "fpToInteger"
+ fpAsLit _ _ = Nothing
+ iteFloat _ _ _ _ = unsupported "iteFloat"
+ fpNaN _ _ _ = unsupported "fpNaN"
+ fpPosInf _ _ _ = unsupported "fpPosInf"
+ fpExactLit _ _ = unsupported "fpExactLit"
+ fpLit _ _ _ _ = unsupported "fpLit"
+ fpLogicalEq _ _ _ = unsupported "fpLogicalEq"
+ fpEq _ _ _ = unsupported "fpEq"
+ fpLessThan _ _ _ = unsupported "fpLessThan"
+ fpGreaterThan _ _ _ = unsupported "fpGreaterThan"
+ fpPlus _ _ _ _ = unsupported "fpPlus"
+ fpMinus _ _ _ _ = unsupported "fpMinus"
+ fpMult _ _ _ _ = unsupported "fpMult"
+ fpDiv _ _ _ _ = unsupported "fpDiv"
+ fpAbs _ _ = unsupported "fpAbs"
+ fpSqrt _ _ _ = unsupported "fpSqrt"
+ fpFMA _ _ _ _ _ = unsupported "fpFMA"
+ fpNeg _ _ = unsupported "fpNeg"
+ fpFromInteger _ _ _ _ _ = unsupported "fpFromInteger"
+ fpToInteger _ _ _ _ = unsupported "fpToInteger"
+ fpIsZero _ _ = unsupported "fpIsZero"
+ fpIsInf _ _ = unsupported "fpIsInf"
+ fpIsNeg _ _ = unsupported "fpIsNeg"
+ fpIsNaN _ _ = unsupported "fpIsNaN"
+ fpIsNorm _ _ = unsupported "fpIsNorm"
+ fpIsSubnorm _ _ = unsupported "fpIsSubnorm"
+ fpToBits _ _ = unsupported "fpToBits"
+ fpFromBits _ _ _ _ = unsupported "fpFromBits"
+ fpToRational _ _ = unsupported "fpToRational"
+ fpFromRational _ _ _ _ _ = unsupported "fpFromRational"
+
unsupported :: String -> SEval SBV a
unsupported x = liftIO (X.throw (UnsupportedSymbolicOp x))
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
@@ -32,18 +32,16 @@
import qualified What4.Interface as W4
import qualified What4.SWord as SW
-
-import qualified Cryptol.Backend.What4.SFloat as FP
+import qualified What4.SFloat as FP
import Cryptol.Backend
-import Cryptol.Backend.Concrete( BV(..), ppBV )
import Cryptol.Backend.FloatHelpers
import Cryptol.Backend.Monad
- ( Eval(..), EvalError(..), Unsupported(..)
- , delayFill, blackhole, evalSpark
+ ( Eval(..), EvalError(..), EvalErrorEx(..)
+ , Unsupported(..), delayFill, blackhole, evalSpark
+ , modifyCallStack, getCallStack
)
import Cryptol.Utils.Panic
-import Cryptol.Utils.PP
data What4 sym =
@@ -72,7 +70,7 @@
-- | The symbolic value we computed.
data W4Result sym a
- = W4Error !EvalError
+ = W4Error !EvalErrorEx
-- ^ A malformed value
| W4Result !(W4.Pred sym) !a
@@ -186,7 +184,9 @@
-- | A fully undefined symbolic value
evalError :: W4.IsSymExprBuilder sym => EvalError -> W4Eval sym a
-evalError err = W4Eval (pure (W4Error err))
+evalError err = W4Eval $ W4Conn $ \_sym ->
+ do stk <- getCallStack
+ pure (W4Error (EvalErrorEx stk err))
--------------------------------------------------------------------------------
@@ -220,17 +220,21 @@
Ready _ -> True
_ -> False
- sDelayFill _ m retry =
+ sDelayFill _ m retry msg =
total
do sym <- getSym
- doEval (w4Thunk <$> delayFill (w4Eval m sym) (w4Eval retry sym))
+ doEval (w4Thunk <$> delayFill (w4Eval m sym) (w4Eval <$> retry <*> pure sym) msg)
sSpark _ m =
total
do sym <- getSym
doEval (w4Thunk <$> evalSpark (w4Eval m sym))
+ sModifyCallStack _ f (W4Eval (W4Conn m)) =
+ W4Eval (W4Conn \sym -> modifyCallStack f (m sym))
+ sGetCallStack _ = total (doEval getCallStack)
+
sDeclareHole _ msg =
total
do (hole, fill) <- doEval (blackhole msg)
@@ -288,25 +292,10 @@
integerAsLit _ v = W4.asInteger v
- ppBit _ v
- | Just b <- W4.asConstantPred v = text $! if b then "True" else "False"
- | otherwise = text "?"
-
- ppWord _ opts v
- | Just x <- SW.bvAsUnsignedInteger v
- = ppBV opts (BV (SW.bvWidth v) x)
-
- | otherwise = text "[?]"
-
- ppInteger _ _opts v
- | Just x <- W4.asInteger v = integer x
- | otherwise = text "[?]"
-
- ppFloat _ _opts _ = text "[?]"
-
iteBit sym c x y = liftIO (W4.itePred (w4 sym) c x y)
iteWord sym c x y = liftIO (SW.bvIte (w4 sym) c x y)
iteInteger sym c x y = liftIO (W4.intIte (w4 sym) c x y)
+ iteFloat sym p x y = liftIO (FP.fpIte (w4 sym) p x y)
bitEq sym x y = liftIO (W4.eqPred (w4 sym) x y)
bitAnd sym x y = liftIO (W4.andPred (w4 sym) x y)
@@ -443,10 +432,18 @@
--------------------------------------------------------------
fpLit sym e p r = liftIO $ FP.fpFromRationalLit (w4 sym) e p r
+ fpAsLit _ f = BF e p <$> FP.fpAsLit f
+ where (e,p) = FP.fpSize f
fpExactLit sym BF{ bfExpWidth = e, bfPrecWidth = p, bfValue = bf } =
liftIO (FP.fpFromBinary (w4 sym) e p =<< SW.bvLit (w4 sym) (e+p) (floatToBits e p bf))
+ fpNaN sym e p = liftIO (FP.fpNaN (w4 sym) e p)
+ fpPosInf sym e p = liftIO (FP.fpPosInf (w4 sym) e p)
+
+ fpToBits sym f = liftIO (FP.fpToBinary (w4 sym) f)
+ fpFromBits sym e p w = liftIO (FP.fpFromBinary (w4 sym) e p w)
+
fpEq sym x y = liftIO $ FP.fpEqIEEE (w4 sym) x y
fpLessThan sym x y = liftIO $ FP.fpLtIEEE (w4 sym) x y
fpGreaterThan sym x y = liftIO $ FP.fpGtIEEE (w4 sym) x y
@@ -458,12 +455,30 @@
fpDiv = fpBinArith FP.fpDiv
fpNeg sym x = liftIO $ FP.fpNeg (w4 sym) x
+ fpAbs sym x = liftIO $ FP.fpAbs (w4 sym) x
+ fpSqrt sym r x =
+ do rm <- fpRoundingMode sym r
+ liftIO $ FP.fpSqrt (w4 sym) rm x
+ fpFMA sym r x y z =
+ do rm <- fpRoundingMode sym r
+ liftIO $ FP.fpFMA (w4 sym) rm x y z
+
+ fpIsZero sym x = liftIO $ FP.fpIsZero (w4 sym) x
+ fpIsNeg sym x = liftIO $ FP.fpIsNeg (w4 sym) x
+ fpIsNaN sym x = liftIO $ FP.fpIsNaN (w4 sym) x
+ fpIsInf sym x = liftIO $ FP.fpIsInf (w4 sym) x
+ fpIsNorm sym x = liftIO $ FP.fpIsNorm (w4 sym) x
+ fpIsSubnorm sym x = liftIO $ FP.fpIsSubnorm (w4 sym) x
+
fpFromInteger sym e p r x =
do rm <- fpRoundingMode sym r
liftIO $ FP.fpFromInteger (w4 sym) e p rm x
fpToInteger = fpCvtToInteger
+
+ fpFromRational = fpCvtFromRational
+ fpToRational = fpCvtToRational
sModAdd :: W4.IsSymExprBuilder sym =>
sym -> Integer -> W4.SymInteger sym -> W4.SymInteger sym -> IO (W4.SymInteger sym)
diff --git a/src/Cryptol/Backend/What4/SFloat.hs b/src/Cryptol/Backend/What4/SFloat.hs
deleted file mode 100644
--- a/src/Cryptol/Backend/What4/SFloat.hs
+++ /dev/null
@@ -1,362 +0,0 @@
-{-# Language DataKinds #-}
-{-# Language FlexibleContexts #-}
-{-# Language GADTs #-}
-{-# Language RankNTypes #-}
-{-# Language TypeApplications #-}
-{-# Language TypeOperators #-}
--- | Working with floats of dynamic sizes.
--- This should probably be moved to What4 one day.
-module Cryptol.Backend.What4.SFloat
- ( -- * Interface
- SFloat(..)
- , fpReprOf
- , fpSize
- , fpRepr
-
- -- * Constants
- , fpFresh
- , fpNaN
- , fpPosInf
- , fpFromRationalLit
-
- -- * Interchange formats
- , fpFromBinary
- , fpToBinary
-
- -- * Relations
- , SFloatRel
- , fpEq
- , fpEqIEEE
- , fpLtIEEE
- , fpGtIEEE
-
- -- * Arithmetic
- , SFloatBinArith
- , fpNeg
- , fpAdd
- , fpSub
- , fpMul
- , fpDiv
-
- -- * Conversions
- , fpRound
- , fpToReal
- , fpFromReal
- , fpFromRational
- , fpToRational
- , fpFromInteger
-
- -- * Queries
- , fpIsInf, fpIsNaN
-
- -- * Exceptions
- , UnsupportedFloat(..)
- , FPTypeError(..)
- ) where
-
-import Control.Exception
-
-import Data.Parameterized.Some
-import Data.Parameterized.NatRepr
-
-import What4.BaseTypes
-import What4.Panic(panic)
-import What4.SWord
-import What4.Interface
-
--- | Symbolic floating point numbers.
-data SFloat sym where
- SFloat :: IsExpr (SymExpr sym) => SymFloat sym fpp -> SFloat sym
-
-
-
---------------------------------------------------------------------------------
-
--- | This exception is thrown if the operations try to create a
--- floating point value we do not support
-data UnsupportedFloat =
- UnsupportedFloat { fpWho :: String, exponentBits, precisionBits :: Integer }
- deriving Show
-
-
--- | Throw 'UnsupportedFloat' exception
-unsupported ::
- String {- ^ Label -} ->
- Integer {- ^ Exponent width -} ->
- Integer {- ^ Precision width -} ->
- IO a
-unsupported l e p =
- throwIO UnsupportedFloat { fpWho = l
- , exponentBits = e
- , precisionBits = p }
-
-instance Exception UnsupportedFloat
-
--- | This exceptoin is throws if the types don't match.
-data FPTypeError =
- FPTypeError { fpExpected :: Some BaseTypeRepr
- , fpActual :: Some BaseTypeRepr
- }
- deriving Show
-
-instance Exception FPTypeError
-
-fpTypeMismatch :: BaseTypeRepr t1 -> BaseTypeRepr t2 -> IO a
-fpTypeMismatch expect actual =
- throwIO FPTypeError { fpExpected = Some expect
- , fpActual = Some actual
- }
-fpTypeError :: FloatPrecisionRepr t1 -> FloatPrecisionRepr t2 -> IO a
-fpTypeError t1 t2 =
- fpTypeMismatch (BaseFloatRepr t1) (BaseFloatRepr t2)
-
-
---------------------------------------------------------------------------------
--- | Construct the 'FloatPrecisionRepr' with the given parameters.
-fpRepr ::
- Integer {- ^ Exponent width -} ->
- Integer {- ^ Precision width -} ->
- Maybe (Some FloatPrecisionRepr)
-fpRepr iE iP =
- do Some e <- someNat iE
- LeqProof <- testLeq (knownNat @2) e
- Some p <- someNat iP
- LeqProof <- testLeq (knownNat @2) p
- pure (Some (FloatingPointPrecisionRepr e p))
-
-fpReprOf ::
- IsExpr (SymExpr sym) => sym -> SymFloat sym fpp -> FloatPrecisionRepr fpp
-fpReprOf _ e =
- case exprType e of
- BaseFloatRepr r -> r
-
-fpSize :: SFloat sym -> (Integer,Integer)
-fpSize (SFloat f) =
- case exprType f of
- BaseFloatRepr (FloatingPointPrecisionRepr e p) -> (intValue e, intValue p)
-
-
---------------------------------------------------------------------------------
--- Constants
-
--- | A fresh variable of the given type.
-fpFresh ::
- IsSymExprBuilder sym =>
- sym ->
- Integer ->
- Integer ->
- IO (SFloat sym)
-fpFresh sym e p
- | Just (Some fpp) <- fpRepr e p =
- SFloat <$> freshConstant sym emptySymbol (BaseFloatRepr fpp)
- | otherwise = unsupported "fpFresh" e p
-
--- | Not a number
-fpNaN ::
- IsExprBuilder sym =>
- sym ->
- Integer {- ^ Exponent width -} ->
- Integer {- ^ Precision width -} ->
- IO (SFloat sym)
-fpNaN sym e p
- | Just (Some fpp) <- fpRepr e p = SFloat <$> floatNaN sym fpp
- | otherwise = unsupported "fpNaN" e p
-
-
--- | Positive infinity
-fpPosInf ::
- IsExprBuilder sym =>
- sym ->
- Integer {- ^ Exponent width -} ->
- Integer {- ^ Precision width -} ->
- IO (SFloat sym)
-fpPosInf sym e p
- | Just (Some fpp) <- fpRepr e p = SFloat <$> floatPInf sym fpp
- | otherwise = unsupported "fpPosInf" e p
-
--- | A floating point number corresponding to the given rations.
-fpFromRationalLit ::
- IsExprBuilder sym =>
- sym ->
- Integer {- ^ Exponent width -} ->
- Integer {- ^ Precision width -} ->
- Rational ->
- IO (SFloat sym)
-fpFromRationalLit sym e p r
- | Just (Some fpp) <- fpRepr e p = SFloat <$> floatLit sym fpp r
- | otherwise = unsupported "fpFromRational" e p
-
-
--- | Make a floating point number with the given bit representation.
-fpFromBinary ::
- IsExprBuilder sym =>
- sym ->
- Integer {- ^ Exponent width -} ->
- Integer {- ^ Precision width -} ->
- SWord sym ->
- IO (SFloat sym)
-fpFromBinary sym e p swe
- | DBV sw <- swe
- , Just (Some fpp) <- fpRepr e p
- , FloatingPointPrecisionRepr ew pw <- fpp
- , let expectW = addNat ew pw
- , actual@(BaseBVRepr actualW) <- exprType sw =
- case testEquality expectW actualW of
- Just Refl -> SFloat <$> floatFromBinary sym fpp sw
- Nothing -- we want to report type correct type errors! :-)
- | Just LeqProof <- testLeq (knownNat @1) expectW ->
- fpTypeMismatch (BaseBVRepr expectW) actual
- | otherwise -> panic "fpFromBits" [ "1 >= 2" ]
- | otherwise = unsupported "fpFromBits" e p
-
-fpToBinary :: IsExprBuilder sym => sym -> SFloat sym -> IO (SWord sym)
-fpToBinary sym (SFloat f)
- | FloatingPointPrecisionRepr e p <- fpReprOf sym f
- , Just LeqProof <- testLeq (knownNat @1) (addNat e p)
- = DBV <$> floatToBinary sym f
- | otherwise = panic "fpToBinary" [ "we messed up the types" ]
-
-
---------------------------------------------------------------------------------
--- Arithmetic
-
-fpNeg :: IsExprBuilder sym => sym -> SFloat sym -> IO (SFloat sym)
-fpNeg sym (SFloat fl) = SFloat <$> floatNeg sym fl
-
-fpBinArith ::
- IsExprBuilder sym =>
- (forall t.
- sym ->
- RoundingMode ->
- SymFloat sym t ->
- SymFloat sym t ->
- IO (SymFloat sym t)
- ) ->
- sym -> RoundingMode -> SFloat sym -> SFloat sym -> IO (SFloat sym)
-fpBinArith fun sym r (SFloat x) (SFloat y) =
- let t1 = sym `fpReprOf` x
- t2 = sym `fpReprOf` y
- in
- case testEquality t1 t2 of
- Just Refl -> SFloat <$> fun sym r x y
- _ -> fpTypeError t1 t2
-
-type SFloatBinArith sym =
- sym -> RoundingMode -> SFloat sym -> SFloat sym -> IO (SFloat sym)
-
-fpAdd :: IsExprBuilder sym => SFloatBinArith sym
-fpAdd = fpBinArith floatAdd
-
-fpSub :: IsExprBuilder sym => SFloatBinArith sym
-fpSub = fpBinArith floatSub
-
-fpMul :: IsExprBuilder sym => SFloatBinArith sym
-fpMul = fpBinArith floatMul
-
-fpDiv :: IsExprBuilder sym => SFloatBinArith sym
-fpDiv = fpBinArith floatDiv
-
-
-
-
---------------------------------------------------------------------------------
-
-fpRel ::
- IsExprBuilder sym =>
- (forall t.
- sym ->
- SymFloat sym t ->
- SymFloat sym t ->
- IO (Pred sym)
- ) ->
- sym -> SFloat sym -> SFloat sym -> IO (Pred sym)
-fpRel fun sym (SFloat x) (SFloat y) =
- let t1 = sym `fpReprOf` x
- t2 = sym `fpReprOf` y
- in
- case testEquality t1 t2 of
- Just Refl -> fun sym x y
- _ -> fpTypeError t1 t2
-
-
-
-
-type SFloatRel sym =
- sym -> SFloat sym -> SFloat sym -> IO (Pred sym)
-
-fpEq :: IsExprBuilder sym => SFloatRel sym
-fpEq = fpRel floatEq
-
-fpEqIEEE :: IsExprBuilder sym => SFloatRel sym
-fpEqIEEE = fpRel floatFpEq
-
-fpLtIEEE :: IsExprBuilder sym => SFloatRel sym
-fpLtIEEE = fpRel floatLt
-
-fpGtIEEE :: IsExprBuilder sym => SFloatRel sym
-fpGtIEEE = fpRel floatGt
-
-
---------------------------------------------------------------------------------
-fpRound ::
- IsExprBuilder sym => sym -> RoundingMode -> SFloat sym -> IO (SFloat sym)
-fpRound sym r (SFloat x) = SFloat <$> floatRound sym r x
-
--- | This is undefined on "special" values (NaN,infinity)
-fpToReal :: IsExprBuilder sym => sym -> SFloat sym -> IO (SymReal sym)
-fpToReal sym (SFloat x) = floatToReal sym x
-
-fpFromReal ::
- IsExprBuilder sym =>
- sym -> Integer -> Integer -> RoundingMode -> SymReal sym -> IO (SFloat sym)
-fpFromReal sym e p r x
- | Just (Some repr) <- fpRepr e p = SFloat <$> realToFloat sym repr r x
- | otherwise = unsupported "fpFromReal" e p
-
-
-fpFromInteger ::
- IsExprBuilder sym =>
- sym -> Integer -> Integer -> RoundingMode -> SymInteger sym -> IO (SFloat sym)
-fpFromInteger sym e p r x = fpFromReal sym e p r =<< integerToReal sym x
-
-
-fpFromRational ::
- IsExprBuilder sym =>
- sym -> Integer -> Integer -> RoundingMode ->
- SymInteger sym -> SymInteger sym -> IO (SFloat sym)
-fpFromRational sym e p r x y =
- do num <- integerToReal sym x
- den <- integerToReal sym y
- res <- realDiv sym num den
- fpFromReal sym e p r res
-
-{- | Returns a predicate and two integers, @x@ and @y@.
-If the the predicate holds, then @x / y@ is a rational representing
-the floating point number. Assumes the FP number is not one of the
-special ones that has no real representation. -}
-fpToRational ::
- IsSymExprBuilder sym =>
- sym ->
- SFloat sym ->
- IO (Pred sym, SymInteger sym, SymInteger sym)
-fpToRational sym fp =
- do r <- fpToReal sym fp
- x <- freshConstant sym emptySymbol BaseIntegerRepr
- y <- freshConstant sym emptySymbol BaseIntegerRepr
- num <- integerToReal sym x
- den <- integerToReal sym y
- res <- realDiv sym num den
- same <- realEq sym r res
- pure (same, x, y)
-
-
-
---------------------------------------------------------------------------------
-fpIsInf :: IsExprBuilder sym => sym -> SFloat sym -> IO (Pred sym)
-fpIsInf sym (SFloat x) = floatIsInf sym x
-
-fpIsNaN :: IsExprBuilder sym => sym -> SFloat sym -> IO (Pred sym)
-fpIsNaN sym (SFloat x) = floatIsNaN sym x
-
-
-
diff --git a/src/Cryptol/Eval.hs b/src/Cryptol/Eval.hs
--- a/src/Cryptol/Eval.hs
+++ b/src/Cryptol/Eval.hs
@@ -27,10 +27,13 @@
, emptyEnv
, evalExpr
, evalDecls
+ , evalNewtypeDecls
, evalSel
, evalSetSel
, EvalError(..)
+ , EvalErrorEx(..)
, Unsupported(..)
+ , WordTooWide(..)
, forceValue
) where
@@ -39,9 +42,11 @@
import Cryptol.Backend.Monad
import Cryptol.Eval.Generic ( iteValue )
import Cryptol.Eval.Env
+import Cryptol.Eval.Prims
import Cryptol.Eval.Type
import Cryptol.Eval.Value
import Cryptol.ModuleSystem.Name
+import Cryptol.Parser.Position
import Cryptol.Parser.Selector(ppSelector)
import Cryptol.TypeCheck.AST
import Cryptol.TypeCheck.Solver.InfNat(Nat'(..))
@@ -63,9 +68,10 @@
type EvalEnv = GenEvalEnv Concrete
type EvalPrims sym =
- ( Backend sym, ?evalPrim :: PrimIdent -> Maybe (Either Expr (GenValue sym)) )
+ ( Backend sym, ?callStacks :: Bool, ?evalPrim :: PrimIdent -> Maybe (Either Expr (Prim sym)) )
-type ConcPrims = ?evalPrim :: PrimIdent -> Maybe (Either Expr (GenValue Concrete))
+type ConcPrims =
+ (?callStacks :: Bool, ?evalPrim :: PrimIdent -> Maybe (Either Expr (Prim Concrete)))
-- Expression Evaluation -------------------------------------------------------
@@ -85,10 +91,10 @@
Module {- ^ Module containing declarations to evaluate -} ->
GenEvalEnv sym {- ^ Environment to extend -} ->
SEval sym (GenEvalEnv sym)
-moduleEnv sym m env = evalDecls sym (mDecls m) =<< evalNewtypes sym (mNewtypes m) env
+moduleEnv sym m env = evalDecls sym (mDecls m) =<< evalNewtypeDecls sym (mNewtypes m) env
{-# SPECIALIZE evalExpr ::
- ConcPrims =>
+ (?range :: Range, ConcPrims) =>
Concrete ->
GenEvalEnv Concrete ->
Expr ->
@@ -99,13 +105,17 @@
-- by the `EvalPrims` class, which defines the behavior of bits and words, in
-- addition to providing implementations for all the primitives.
evalExpr ::
- EvalPrims sym =>
+ (?range :: Range, EvalPrims sym) =>
sym ->
GenEvalEnv sym {- ^ Evaluation environment -} ->
Expr {- ^ Expression to evaluate -} ->
SEval sym (GenValue sym)
evalExpr sym env expr = case expr of
+ ELocated r e ->
+ let ?range = r in
+ evalExpr sym env e
+
-- Try to detect when the user has directly written a finite sequence of
-- literal bit values and pack these into a word.
EList es ty
@@ -115,22 +125,22 @@
return $ VWord len $
case tryFromBits sym vs of
Just w -> WordVal <$> w
- Nothing -> do xs <- mapM (sDelay sym Nothing) vs
- return $ LargeBitsVal len $ finiteSeqMap sym xs
+ Nothing -> do xs <- mapM (sDelay sym) vs
+ return $ LargeBitsVal len $ finiteSeqMap xs
| otherwise -> {-# SCC "evalExpr->EList" #-} do
- xs <- mapM (sDelay sym Nothing) vs
- return $ VSeq len $ finiteSeqMap sym xs
+ xs <- mapM (sDelay sym) vs
+ return $ VSeq len $ finiteSeqMap xs
where
tyv = evalValType (envTypes env) ty
vs = map eval es
len = genericLength es
ETuple es -> {-# SCC "evalExpr->ETuple" #-} do
- xs <- mapM (sDelay sym Nothing . eval) es
+ xs <- mapM (sDelay sym . eval) es
return $ VTuple xs
ERec fields -> {-# SCC "evalExpr->ERec" #-} do
- xs <- traverse (sDelay sym Nothing . eval) fields
+ xs <- traverse (sDelay sym . eval) fields
return $ VRecord xs
ESel e sel -> {-# SCC "evalExpr->ESel" #-} do
@@ -153,7 +163,15 @@
EVar n -> {-# SCC "evalExpr->EVar" #-} do
case lookupVar n env of
- Just val -> val
+ Just (Left p)
+ | ?callStacks -> sPushFrame sym n ?range (cacheCallStack sym =<< evalPrim sym n p)
+ | otherwise -> evalPrim sym n p
+ Just (Right val)
+ | ?callStacks ->
+ case nameInfo n of
+ Declared{} -> sPushFrame sym n ?range (cacheCallStack sym =<< val)
+ Parameter -> cacheCallStack sym =<< val
+ | otherwise -> val
Nothing -> do
envdoc <- ppEnv sym defaultPPOpts env
panic "[Eval] evalExpr"
@@ -163,14 +181,14 @@
ETAbs tv b -> {-# SCC "evalExpr->ETAbs" #-}
case tpKind tv of
- KType -> return $ VPoly $ \ty -> evalExpr sym (bindType (tpVar tv) (Right ty) env) b
- KNum -> return $ VNumPoly $ \n -> evalExpr sym (bindType (tpVar tv) (Left n) env) b
+ KType -> tlam sym $ \ty -> evalExpr sym (bindType (tpVar tv) (Right ty) env) b
+ KNum -> nlam sym $ \n -> evalExpr sym (bindType (tpVar tv) (Left n) env) b
k -> panic "[Eval] evalExpr" ["invalid kind on type abstraction", show k]
ETApp e ty -> {-# SCC "evalExpr->ETApp" #-} do
eval e >>= \case
- VPoly f -> f $! (evalValType (envTypes env) ty)
- VNumPoly f -> f $! (evalNumType (envTypes env) ty)
+ f@VPoly{} -> fromVPoly sym f $! (evalValType (envTypes env) ty)
+ f@VNumPoly{} -> fromVNumPoly sym f $! (evalNumType (envTypes env) ty)
val -> do vdoc <- ppV val
panic "[Eval] evalExpr"
["expected a polymorphic value"
@@ -179,13 +197,13 @@
EApp f v -> {-# SCC "evalExpr->EApp" #-} do
eval f >>= \case
- VFun f' -> f' (eval v)
- it -> do itdoc <- ppV it
- panic "[Eval] evalExpr" ["not a function", show itdoc ]
+ f'@VFun {} -> fromVFun sym f' (eval v)
+ it -> do itdoc <- ppV it
+ panic "[Eval] evalExpr" ["not a function", show itdoc ]
EAbs n _ty b -> {-# SCC "evalExpr->EAbs" #-}
- return $ VFun (\v -> do env' <- bindVar sym n v env
- evalExpr sym env' b)
+ lam sym (\v -> do env' <- bindVar sym n v env
+ evalExpr sym env' b)
-- XXX these will likely change once there is an evidence value
EProofAbs _ e -> eval e
@@ -202,9 +220,31 @@
ppV = ppValue sym defaultPPOpts
+-- | Capure the current call stack from the evaluation monad and
+-- annotate function values. When arguments are later applied
+-- to the function, the call stacks will be combined together.
+cacheCallStack ::
+ Backend sym =>
+ sym ->
+ GenValue sym ->
+ SEval sym (GenValue sym)
+cacheCallStack sym v = case v of
+ VFun fnstk f ->
+ do stk <- sGetCallStack sym
+ pure (VFun (combineCallStacks stk fnstk) f)
+ VPoly fnstk f ->
+ do stk <- sGetCallStack sym
+ pure (VPoly (combineCallStacks stk fnstk) f)
+ VNumPoly fnstk f ->
+ do stk <- sGetCallStack sym
+ pure (VNumPoly (combineCallStacks stk fnstk) f)
+
+ -- non-function types don't get annotated
+ _ -> pure v
+
-- Newtypes --------------------------------------------------------------------
-{-# SPECIALIZE evalNewtypes ::
+{-# SPECIALIZE evalNewtypeDecls ::
ConcPrims =>
Concrete ->
Map.Map Name Newtype ->
@@ -212,28 +252,34 @@
SEval Concrete (GenEvalEnv Concrete)
#-}
-evalNewtypes ::
+evalNewtypeDecls ::
EvalPrims sym =>
sym ->
Map.Map Name Newtype ->
GenEvalEnv sym ->
SEval sym (GenEvalEnv sym)
-evalNewtypes sym nts env = foldM (flip (evalNewtype sym)) env $ Map.elems nts
+evalNewtypeDecls sym nts env = foldM (flip (evalNewtypeDecl sym)) env $ Map.elems nts
-- | Introduce the constructor function for a newtype.
-evalNewtype ::
+evalNewtypeDecl ::
EvalPrims sym =>
sym ->
Newtype ->
GenEvalEnv sym ->
SEval sym (GenEvalEnv sym)
-evalNewtype sym nt = bindVar sym (ntName nt) (return (foldr tabs con (ntParams nt)))
+evalNewtypeDecl _sym nt = pure . bindVarDirect (ntName nt) (foldr tabs con (ntParams nt))
where
- tabs _tp body = tlam (\ _ -> body)
- con = VFun id
-{-# INLINE evalNewtype #-}
+ con = PFun PPrim
+ tabs tp body =
+ case tpKind tp of
+ KType -> PTyPoly (\ _ -> body)
+ KNum -> PNumPoly (\ _ -> body)
+ k -> evalPanic "evalNewtypeDecl" ["illegal newtype parameter kind", show (pp k)]
+{-# INLINE evalNewtypeDecl #-}
+
+
-- Declarations ----------------------------------------------------------------
{-# SPECIALIZE evalDecls ::
@@ -274,7 +320,7 @@
-- declare a "hole" for each declaration
-- and extend the evaluation environment
holes <- mapM (declHole sym) ds
- let holeEnv = IntMap.fromList $ [ (nameUnique nm, h) | (nm,_,h,_) <- holes ]
+ let holeEnv = IntMap.fromList $ [ (nameUnique nm, Right h) | (nm,_,h,_) <- holes ]
let env' = env `mappend` emptyEnv{ envVars = holeEnv }
-- evaluate the declaration bodies, building a new evaluation environment
@@ -318,12 +364,16 @@
SEval sym ()
fillHole sym env (nm, sch, _, fill) = do
case lookupVar nm env of
- Nothing -> evalPanic "fillHole" ["Recursive definition not completed", show (ppLocName nm)]
- Just v
- | isValueType env sch -> fill =<< sDelayFill sym v (etaDelay sym (show (ppLocName nm)) env sch v)
- | otherwise -> fill (etaDelay sym (show (ppLocName nm)) env sch v)
+ 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)
+ _ -> 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
@@ -337,6 +387,7 @@
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
@@ -357,14 +408,13 @@
SEval sym (GenValue sym) ->
SEval sym (WordValue sym)
etaWord sym n val = do
- w <- sDelay sym Nothing (fromWordVal "during eta-expansion" =<< val)
- xs <- memoMap $ IndexSeqMap $ \i ->
+ 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 ->
- String ->
GenEvalEnv Concrete ->
Schema ->
SEval Concrete (GenValue Concrete) ->
@@ -380,23 +430,24 @@
etaDelay ::
Backend sym =>
sym ->
- String ->
GenEvalEnv sym ->
Schema ->
SEval sym (GenValue sym) ->
SEval sym (GenValue sym)
-etaDelay sym msg env0 Forall{ sVars = vs0, sType = tp0 } = goTpVars env0 vs0
+etaDelay sym env0 Forall{ sVars = vs0, sType = tp0 } = goTpVars env0 vs0
where
- goTpVars env [] val = go (evalValType (envTypes env) tp0) val
+ goTpVars env [] val =
+ do stk <- sGetCallStack sym
+ go stk (evalValType (envTypes env) tp0) val
goTpVars env (v:vs) val =
case tpKind v of
- KType -> return $ VPoly $ \t ->
- goTpVars (bindType (tpVar v) (Right t) env) vs ( ($t) . fromVPoly =<< val )
- KNum -> return $ VNumPoly $ \n ->
- goTpVars (bindType (tpVar v) (Left n) env) vs ( ($n) . fromVNumPoly =<< val )
+ 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 tp x | isReady sym x = x >>= \case
+ go stk tp x | isReady sym x = x >>= \case
VBit{} -> x
VInteger{} -> x
VWord{} -> x
@@ -404,33 +455,39 @@
VFloat{} -> x
VSeq n xs ->
case tp of
- TVSeq _nt el -> return $ VSeq n $ IndexSeqMap $ \i -> go el (lookupSeqMap xs i)
+ 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 el (lookupSeqMap xs i)
+ 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 ts xs)
+ 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 t v) fs 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]
- VFun f ->
+ f@VFun{} ->
case tp of
- TVFun _t1 t2 -> return $ VFun $ \a -> go t2 (f a)
+ 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{} ->
@@ -439,7 +496,7 @@
VNumPoly{} ->
evalPanic "type mismatch during eta-expansion" ["Encountered numeric polymorphic value"]
- go tp v =
+ go stk tp v = sWithCallStack sym stk $
case tp of
TVBit -> v
TVInteger -> v
@@ -449,40 +506,41 @@
TVArray{} -> v
TVSeq n TVBit ->
- do w <- sDelayFill sym (fromWordVal "during eta-expansion" =<< v) (etaWord sym n v)
+ 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 (Just msg) (fromSeq "during eta-expansion" =<< v)
+ do x' <- sDelay sym (fromSeq "during eta-expansion" =<< v)
return $ VSeq n $ IndexSeqMap $ \i -> do
- go el (flip lookupSeqMap i =<< x')
+ go stk el (flip lookupSeqMap i =<< x')
TVStream el ->
- do x' <- sDelay sym (Just msg) (fromSeq "during eta-expansion" =<< v)
+ do x' <- sDelay sym (fromSeq "during eta-expansion" =<< v)
return $ VStream $ IndexSeqMap $ \i ->
- go el (flip lookupSeqMap i =<< x')
+ go stk el (flip lookupSeqMap i =<< x')
TVFun _t1 t2 ->
- do v' <- sDelay sym (Just msg) (fromVFun <$> v)
- return $ VFun $ \a -> go t2 ( ($a) =<< v' )
+ 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 (Just msg) (fromVTuple <$> v)
+ v' <- sDelay sym (fromVTuple <$> v)
return $ VTuple $
- [ go t =<< (flip genericIndex i <$> v')
+ [ go stk t =<< (flip genericIndex i <$> v')
| i <- [0..(n-1)]
| t <- ts
]
TVRec fs ->
- do v' <- sDelay sym (Just msg) (fromVRecord <$> v)
+ do v' <- sDelay sym (fromVRecord <$> v)
let err f = evalPanic "expected record value with field" [show f]
- let eta f t = go t =<< (fromMaybe (err f) . lookupField f <$> v')
+ 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 ->
@@ -504,7 +562,7 @@
where
nm = dName d
sch = dSignature d
- msg = unwords ["<> while evaluating", show (pp nm)]
+ msg = unwords ["while evaluating", show (pp nm)]
-- | Evaluate a declaration, extending the evaluation environment.
@@ -522,10 +580,11 @@
Decl {- ^ The declaration to evaluate -} ->
SEval sym (GenEvalEnv sym)
evalDecl sym renv env d =
+ let ?range = nameLoc (dName d) in
case dDefinition d of
DPrim ->
case ?evalPrim =<< asPrim (dName d) of
- Just (Right v) -> pure (bindVarDirect (dName d) v env)
+ Just (Right p) -> pure $ bindVarDirect (dName d) p env
Just (Left ex) -> bindVar sym (dName d) (evalExpr sym renv ex) env
Nothing -> bindVar sym (dName d) (cryNoPrimError sym (dName d)) env
@@ -535,7 +594,6 @@
-- Selectors -------------------------------------------------------------------
{-# SPECIALIZE evalSel ::
- ConcPrims =>
Concrete ->
GenValue Concrete ->
Selector ->
@@ -546,7 +604,7 @@
-- tuple and record selections pointwise down into other value constructs
-- (e.g., streams and functions).
evalSel ::
- EvalPrims sym =>
+ Backend sym =>
sym ->
GenValue sym ->
Selector ->
@@ -584,12 +642,11 @@
[ "Unexpected value in list selection"
, show vdoc ]
{-# SPECIALIZE evalSetSel ::
- ConcPrims =>
Concrete -> TValue ->
GenValue Concrete -> Selector -> SEval Concrete (GenValue Concrete) -> SEval Concrete (GenValue Concrete)
#-}
evalSetSel :: forall sym.
- EvalPrims sym =>
+ Backend sym =>
sym ->
TValue ->
GenValue sym -> Selector -> SEval sym (GenValue sym) -> SEval sym (GenValue sym)
@@ -645,7 +702,7 @@
data ListEnv sym = ListEnv
{ leVars :: !(IntMap.IntMap (Integer -> SEval sym (GenValue sym)))
-- ^ Bindings whose values vary by position
- , leStatic :: !(IntMap.IntMap (SEval sym (GenValue sym)))
+ , leStatic :: !(IntMap.IntMap (Either (Prim sym) (SEval sym (GenValue sym))))
-- ^ Bindings whose values are constant
, leTypes :: !TypeEnv
}
@@ -654,14 +711,14 @@
l <> r = ListEnv
{ leVars = IntMap.union (leVars l) (leVars r)
, leStatic = IntMap.union (leStatic l) (leStatic r)
- , leTypes = IntMap.union (leTypes l) (leTypes r)
+ , leTypes = leTypes l <> leTypes r
}
instance Monoid (ListEnv sym) where
mempty = ListEnv
{ leVars = IntMap.empty
, leStatic = IntMap.empty
- , leTypes = IntMap.empty
+ , leTypes = mempty
}
mappend l r = l <> r
@@ -680,7 +737,7 @@
-- locations.
evalListEnv :: ListEnv sym -> Integer -> GenEvalEnv sym
evalListEnv (ListEnv vm st tm) i =
- let v = fmap ($i) vm
+ let v = fmap (Right . ($i)) vm
in EvalEnv{ envVars = IntMap.union v st
, envTypes = tm
}
@@ -698,7 +755,7 @@
-- List Comprehensions ---------------------------------------------------------
{-# SPECIALIZE evalComp ::
- ConcPrims =>
+ (?range :: Range, ConcPrims) =>
Concrete ->
GenEvalEnv Concrete ->
Nat' ->
@@ -709,7 +766,7 @@
#-}
-- | Evaluate a comprehension.
evalComp ::
- EvalPrims sym =>
+ (?range :: Range, EvalPrims sym) =>
sym ->
GenEvalEnv sym {- ^ Starting evaluation environment -} ->
Nat' {- ^ Length of the comprehension -} ->
@@ -719,11 +776,11 @@
SEval sym (GenValue sym)
evalComp sym env len elty body ms =
do lenv <- mconcat <$> mapM (branchEnvs sym (toListEnv env)) ms
- mkSeq len elty <$> memoMap (IndexSeqMap $ \i -> do
+ mkSeq len elty <$> memoMap sym (IndexSeqMap $ \i -> do
evalExpr sym (evalListEnv lenv i) body)
{-# SPECIALIZE branchEnvs ::
- ConcPrims =>
+ (?range :: Range, ConcPrims) =>
Concrete ->
ListEnv Concrete ->
[Match] ->
@@ -732,7 +789,7 @@
-- | Turn a list of matches into the final environments for each iteration of
-- the branch.
branchEnvs ::
- EvalPrims sym =>
+ (?range :: Range, EvalPrims sym) =>
sym ->
ListEnv sym ->
[Match] ->
@@ -740,7 +797,7 @@
branchEnvs sym env matches = foldM (evalMatch sym) env matches
{-# SPECIALIZE evalMatch ::
- ConcPrims =>
+ (?range :: Range, ConcPrims) =>
Concrete ->
ListEnv Concrete ->
Match ->
@@ -749,7 +806,7 @@
-- | Turn a match into the list of environments it represents.
evalMatch ::
- EvalPrims sym =>
+ (?range :: Range, EvalPrims sym) =>
sym ->
ListEnv sym ->
Match ->
@@ -762,7 +819,7 @@
-- Select from a sequence of finite length. This causes us to 'stutter'
-- through our previous choices `nLen` times.
Nat nLen -> do
- vss <- memoMap $ IndexSeqMap $ \i -> evalExpr sym (evalListEnv lenv i) expr
+ vss <- memoMap sym $ 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
@@ -778,7 +835,7 @@
-- `leVars` elements of the comprehension environment into `leStatic` elements
-- by selecting out the 0th element.
Inf -> do
- let allvars = IntMap.union (fmap ($0) (leVars lenv)) (leStatic lenv)
+ let allvars = IntMap.union (fmap (Right . ($0)) (leVars lenv)) (leStatic lenv)
let lenv' = lenv { leVars = IntMap.empty
, leStatic = allvars
}
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
@@ -25,9 +25,9 @@
, toExpr
) where
-import Control.Monad (join, guard, zipWithM, foldM)
+import Control.Monad (guard, zipWithM, foldM, mzero)
import Data.Bits (Bits(..))
-import Data.Ratio((%),numerator,denominator)
+import Data.Ratio(numerator,denominator)
import Data.Word(Word32, Word64)
import MonadLib( ChoiceT, findOne, lift )
import qualified LibBF as FP
@@ -44,6 +44,7 @@
import Cryptol.Backend.Monad
import Cryptol.Eval.Generic hiding (logicShift)
+import Cryptol.Eval.Prims
import Cryptol.Eval.Type
import Cryptol.Eval.Value
import qualified Cryptol.SHA as SHA
@@ -54,7 +55,6 @@
import Cryptol.Utils.Panic (panic)
import Cryptol.Utils.Ident (PrimIdent,prelPrim,floatPrim,suiteBPrim,primeECPrim)
import Cryptol.Utils.PP
-import Cryptol.Utils.Logger(logPrint)
import Cryptol.Utils.RecordMap
type Value = GenValue Concrete
@@ -63,57 +63,68 @@
-- | Given an expected type, returns an expression that evaluates to
-- this value, if we can determine it.
-toExpr :: PrimMap -> AST.Type -> Value -> Eval (Maybe AST.Expr)
+toExpr :: PrimMap -> TValue -> Value -> Eval (Maybe AST.Expr)
toExpr prims t0 v0 = findOne (go t0 v0)
where
prim n = ePrim prims (prelPrim n)
- go :: AST.Type -> Value -> ChoiceT Eval Expr
+ go :: TValue -> Value -> ChoiceT Eval Expr
go ty val =
- case val of
- VRecord vfs ->
- do tfs <- maybe mismatch pure (tIsRec ty)
- -- NB, vfs first argument to keep their display order
+ case (ty,val) of
+ (TVRec tfs, VRecord vfs) ->
+ do -- NB, vfs first argument to keep their display order
res <- zipRecordsM (\_lbl v t -> go t =<< lift v) vfs tfs
case res of
Left _ -> mismatch -- different fields
Right efs -> pure (ERec efs)
- VTuple tvs ->
- do ts <- maybe mismatch pure (tIsTuple ty)
- guard (length ts == length tvs)
+
+ (TVNewtype nt ts tfs, VRecord vfs) ->
+ do -- NB, vfs first argument to keep their display order
+ res <- zipRecordsM (\_lbl v t -> go t =<< lift v) vfs tfs
+ case res of
+ Left _ -> mismatch -- different fields
+ Right efs ->
+ let f = foldl (\x t -> ETApp x (tNumValTy t)) (EVar (ntName nt)) ts
+ in pure (EApp f (ERec efs))
+
+ (TVTuple ts, VTuple tvs) ->
+ do guard (length ts == length tvs)
ETuple <$> (zipWithM go ts =<< lift (sequence tvs))
- VBit b ->
+ (TVBit, VBit b) ->
pure (prim (if b then "True" else "False"))
- VInteger i ->
- -- This works uniformly for values of type Integer or Z n
- pure $ ETApp (ETApp (prim "number") (tNum i)) ty
- VRational (SRational n d) ->
+ (TVInteger, VInteger i) ->
+ pure $ ETApp (ETApp (prim "number") (tNum i)) tInteger
+ (TVIntMod n, VInteger i) ->
+ pure $ ETApp (ETApp (prim "number") (tNum i)) (tIntMod (tNum n))
+
+ (TVRational, VRational (SRational n d)) ->
do let n' = ETApp (ETApp (prim "number") (tNum n)) tInteger
let d' = ETApp (ETApp (prim "number") (tNum d)) tInteger
pure $ EApp (EApp (prim "ratio") n') d'
- VFloat i ->
- do (eT, pT) <- maybe mismatch pure (tIsFloat ty)
- pure (floatToExpr prims eT pT (bfValue i))
- VSeq n svs ->
- do (_a, b) <- maybe mismatch pure (tIsSeq ty)
- ses <- traverse (go b) =<< lift (sequence (enumerateSeqMap n svs))
- pure $ EList ses b
- VWord _ wval ->
+
+ (TVFloat e p, VFloat i) ->
+ pure (floatToExpr prims (tNum e) (tNum p) (bfValue i))
+ (TVSeq _ b, VSeq n svs) ->
+ 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)
- pure $ ETApp (ETApp (prim "number") (tNum v)) ty
- VStream _ -> fail "cannot construct infinite expressions"
- VFun _ -> fail "cannot convert function values to expressions"
- VPoly _ -> fail "cannot convert polymorphic values to expressions"
- VNumPoly _ -> fail "cannot convert polymorphic values to expressions"
+ pure $ ETApp (ETApp (prim "number") (tNum v)) (tWord (tNum n))
+
+ (_,VStream{}) -> mzero
+ (_,VFun{}) -> mzero
+ (_,VPoly{}) -> mzero
+ (_,VNumPoly{}) -> mzero
+ _ -> mismatch
where
mismatch :: forall a. ChoiceT Eval a
mismatch =
do doc <- lift (ppValue Concrete defaultPPOpts val)
panic "Cryptol.Eval.Concrete.toExpr"
["type mismatch:"
- , pretty ty
+ , pretty (tValTy ty)
, render doc
]
@@ -139,153 +150,18 @@
-- Primitives ------------------------------------------------------------------
-primTable :: EvalOpts -> Map PrimIdent Value
-primTable eOpts = let sym = Concrete in
- Map.union (floatPrims sym) $
+primTable :: IO EvalOpts -> Map PrimIdent (Prim Concrete)
+primTable getEOpts = let sym = Concrete in
+ Map.union (genericPrimTable sym getEOpts) $
+ Map.union (genericFloatTable sym) $
Map.union suiteBPrims $
Map.union primeECPrims $
Map.fromList $ map (\(n, v) -> (prelPrim n, v))
- [ -- Literals
- ("True" , VBit (bitLit sym True))
- , ("False" , VBit (bitLit sym False))
- , ("number" , {-# SCC "Prelude::number" #-}
- ecNumberV sym)
- , ("ratio" , {-# SCC "Prelude::ratio" #-}
- ratioV sym)
- , ("fraction" , ecFractionV sym)
-
-
- -- Zero
- , ("zero" , {-# SCC "Prelude::zero" #-}
- VPoly (zeroV sym))
-
- -- Logic
- , ("&&" , {-# SCC "Prelude::(&&)" #-}
- binary (andV sym))
- , ("||" , {-# SCC "Prelude::(||)" #-}
- binary (orV sym))
- , ("^" , {-# SCC "Prelude::(^)" #-}
- binary (xorV sym))
- , ("complement" , {-# SCC "Prelude::complement" #-}
- unary (complementV sym))
-
- -- Ring
- , ("fromInteger", {-# SCC "Prelude::fromInteger" #-}
- fromIntegerV sym)
- , ("+" , {-# SCC "Prelude::(+)" #-}
- binary (addV sym))
- , ("-" , {-# SCC "Prelude::(-)" #-}
- binary (subV sym))
- , ("*" , {-# SCC "Prelude::(*)" #-}
- binary (mulV sym))
- , ("negate" , {-# SCC "Prelude::negate" #-}
- unary (negateV sym))
-
- -- Integral
- , ("toInteger" , {-# SCC "Prelude::toInteger" #-}
- toIntegerV sym)
- , ("/" , {-# SCC "Prelude::(/)" #-}
- binary (divV sym))
- , ("%" , {-# SCC "Prelude::(%)" #-}
- binary (modV sym))
- , ("^^" , {-# SCC "Prelude::(^^)" #-}
- expV sym)
- , ("infFrom" , {-# SCC "Prelude::infFrom" #-}
- infFromV sym)
- , ("infFromThen", {-# SCC "Prelude::infFromThen" #-}
- infFromThenV sym)
-
- -- Field
- , ("recip" , {-# SCC "Prelude::recip" #-}
- recipV sym)
- , ("/." , {-# SCC "Prelude::(/.)" #-}
- fieldDivideV sym)
-
- -- Round
- , ("floor" , {-# SCC "Prelude::floor" #-}
- unary (floorV sym))
- , ("ceiling" , {-# SCC "Prelude::ceiling" #-}
- unary (ceilingV sym))
- , ("trunc" , {-# SCC "Prelude::trunc" #-}
- unary (truncV sym))
- , ("roundAway" , {-# SCC "Prelude::roundAway" #-}
- unary (roundAwayV sym))
- , ("roundToEven", {-# SCC "Prelude::roundToEven" #-}
- unary (roundToEvenV sym))
-
- -- Bitvector specific operations
- , ("/$" , {-# SCC "Prelude::(/$)" #-}
- sdivV sym)
- , ("%$" , {-# SCC "Prelude::(%$)" #-}
- smodV sym)
- , ("lg2" , {-# SCC "Prelude::lg2" #-}
- lg2V sym)
- , (">>$" , {-# SCC "Prelude::(>>$)" #-}
+ [ (">>$" , {-# SCC "Prelude::(>>$)" #-}
sshrV)
- -- Cmp
- , ("<" , {-# SCC "Prelude::(<)" #-}
- binary (lessThanV sym))
- , (">" , {-# SCC "Prelude::(>)" #-}
- binary (greaterThanV sym))
- , ("<=" , {-# SCC "Prelude::(<=)" #-}
- binary (lessThanEqV sym))
- , (">=" , {-# SCC "Prelude::(>=)" #-}
- binary (greaterThanEqV sym))
- , ("==" , {-# SCC "Prelude::(==)" #-}
- binary (eqV sym))
- , ("!=" , {-# SCC "Prelude::(!=)" #-}
- binary (distinctV sym))
-
- -- SignedCmp
- , ("<$" , {-# SCC "Prelude::(<$)" #-}
- binary (signedLessThanV sym))
-
- -- Finite enumerations
- , ("fromTo" , {-# SCC "Prelude::fromTo" #-}
- fromToV sym)
- , ("fromThenTo" , {-# SCC "Prelude::fromThenTo" #-}
- fromThenToV sym)
-
- -- Sequence manipulations
- , ("#" , {-# SCC "Prelude::(#)" #-}
- nlam $ \ front ->
- nlam $ \ back ->
- tlam $ \ elty ->
- lam $ \ l -> return $
- lam $ \ r -> join (ccatV sym front back elty <$> l <*> r))
-
-
- , ("join" , {-# SCC "Prelude::join" #-}
- nlam $ \ parts ->
- nlam $ \ (finNat' -> each) ->
- tlam $ \ a ->
- lam $ \ x ->
- joinV sym parts each a =<< x)
-
- , ("split" , {-# SCC "Prelude::split" #-}
- ecSplitV sym)
-
- , ("splitAt" , {-# SCC "Prelude::splitAt" #-}
- nlam $ \ front ->
- nlam $ \ back ->
- tlam $ \ a ->
- lam $ \ x ->
- splitAtV sym front back a =<< x)
-
- , ("reverse" , {-# SCC "Prelude::reverse" #-}
- nlam $ \_a ->
- tlam $ \_b ->
- lam $ \xs -> reverseV sym =<< xs)
-
- , ("transpose" , {-# SCC "Prelude::transpose" #-}
- nlam $ \a ->
- nlam $ \b ->
- tlam $ \c ->
- lam $ \xs -> transposeV sym a b c =<< xs)
-
-- Shifts and rotates
, ("<<" , {-# SCC "Prelude::(<<)" #-}
logicShift shiftLW shiftLS)
@@ -308,56 +184,12 @@
, ("updateEnd" , {-# SCC "Prelude::updateEnd" #-}
updatePrim sym updateBack_word updateBack)
- -- Misc
- , ("foldl" , {-# SCC "Prelude::foldl" #-}
- foldlV sym)
-
- , ("foldl'" , {-# SCC "Prelude::foldl'" #-}
- foldl'V sym)
-
- , ("deepseq" , {-# SCC "Prelude::deepseq" #-}
- tlam $ \_a ->
- tlam $ \_b ->
- lam $ \x -> pure $
- lam $ \y ->
- do _ <- forceValue =<< x
- y)
-
- , ("parmap" , {-# SCC "Prelude::parmap" #-}
- parmapV sym)
-
- , ("fromZ" , {-# SCC "Prelude::fromZ" #-}
- fromZV sym)
-
- , ("error" , {-# SCC "Prelude::error" #-}
- tlam $ \a ->
- nlam $ \_ ->
- lam $ \s -> errorV sym a =<< (valueToString sym =<< s))
-
- , ("random" , {-# SCC "Prelude::random" #-}
- tlam $ \a ->
- wlam sym $ \(bvVal -> x) -> randomV sym a x)
-
- , ("trace" , {-# SCC "Prelude::trace" #-}
- nlam $ \_n ->
- tlam $ \_a ->
- tlam $ \_b ->
- lam $ \s -> return $
- lam $ \x -> return $
- lam $ \y -> do
- msg <- valueToString sym =<< s
- let EvalOpts { evalPPOpts, evalLogger } = eOpts
- doc <- ppValue sym evalPPOpts =<< x
- yv <- y
- io $ logPrint evalLogger
- $ if null msg then doc else text msg <+> doc
- return yv)
-
, ("pmult",
- ilam $ \u ->
- ilam $ \v ->
- wlam Concrete $ \(BV _ x) -> return $
- wlam Concrete $ \(BV _ y) ->
+ PFinPoly \u ->
+ PFinPoly \v ->
+ PWordFun \(BV _ x) ->
+ PWordFun \(BV _ y) ->
+ PPrim
let z = if u <= v then
F2.pmult (fromInteger (u+1)) x y
else
@@ -365,56 +197,62 @@
in return . VWord (1+u+v) . pure . WordVal . mkBv (1+u+v) $! z)
, ("pmod",
- ilam $ \_u ->
- ilam $ \v ->
- wlam Concrete $ \(BV w x) -> return $
- wlam Concrete $ \(BV _ m) ->
+ PFinPoly \_u ->
+ PFinPoly \v ->
+ PWordFun \(BV w x) ->
+ PWordFun \(BV _ m) ->
+ PPrim
do assertSideCondition sym (m /= 0) DivideByZero
return . VWord v . pure . WordVal . mkBv v $! F2.pmod (fromInteger w) x m)
, ("pdiv",
- ilam $ \_u ->
- ilam $ \_v ->
- wlam Concrete $ \(BV w x) -> return $
- wlam Concrete $ \(BV _ m) ->
+ PFinPoly \_u ->
+ PFinPoly \_v ->
+ PWordFun \(BV w x) ->
+ PWordFun \(BV _ m) ->
+ PPrim
do assertSideCondition sym (m /= 0) DivideByZero
return . VWord w . pure . WordVal . mkBv w $! F2.pdiv (fromInteger w) x m)
]
-primeECPrims :: Map.Map PrimIdent Value
+primeECPrims :: Map.Map PrimIdent (Prim Concrete)
primeECPrims = Map.fromList $ map (\(n,v) -> (primeECPrim n, v))
[ ("ec_double", {-# SCC "PrimeEC::ec_double" #-}
- ilam $ \p ->
- lam $ \s ->
+ PFinPoly \p ->
+ PFun \s ->
+ PPrim
do s' <- toProjectivePoint =<< s
let r = PrimeEC.ec_double (PrimeEC.primeModulus p) s'
fromProjectivePoint $! r)
, ("ec_add_nonzero", {-# SCC "PrimeEC::ec_add_nonzero" #-}
- ilam $ \p ->
- lam $ \s -> pure $
- lam $ \t ->
+ PFinPoly \p ->
+ PFun \s ->
+ PFun \t ->
+ PPrim
do s' <- toProjectivePoint =<< s
t' <- toProjectivePoint =<< t
let r = PrimeEC.ec_add_nonzero (PrimeEC.primeModulus p) s' t'
fromProjectivePoint $! r)
, ("ec_mult", {-# SCC "PrimeEC::ec_mult" #-}
- ilam $ \p ->
- lam $ \d -> pure $
- lam $ \s ->
+ PFinPoly \p ->
+ PFun \d ->
+ PFun \s ->
+ PPrim
do d' <- fromVInteger <$> d
s' <- toProjectivePoint =<< s
let r = PrimeEC.ec_mult (PrimeEC.primeModulus p) d' s'
fromProjectivePoint $! r)
, ("ec_twin_mult", {-# SCC "PrimeEC::ec_twin_mult" #-}
- ilam $ \p ->
- lam $ \d0 -> pure $
- lam $ \s -> pure $
- lam $ \d1 -> pure $
- lam $ \t ->
+ PFinPoly \p ->
+ PFun \d0 ->
+ PFun \s ->
+ PFun \d1 ->
+ PFun \t ->
+ PPrim
do d0' <- fromVInteger <$> d0
s' <- toProjectivePoint =<< s
d1' <- fromVInteger <$> d1
@@ -436,59 +274,64 @@
-suiteBPrims :: Map.Map PrimIdent Value
+suiteBPrims :: Map.Map PrimIdent (Prim Concrete)
suiteBPrims = Map.fromList $ map (\(n, v) -> (suiteBPrim n, v))
[ ("processSHA2_224", {-# SCC "SuiteB::processSHA2_224" #-}
- ilam $ \n ->
- lam $ \xs ->
- do blks <- enumerateSeqMap n . fromVSeq <$> xs
- (SHA.SHA256S w0 w1 w2 w3 w4 w5 w6 _) <-
- 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 Concrete (map f [w0,w1,w2,w3,w4,w5,w6])
- seq zs (pure (VSeq 7 zs)))
+ PFinPoly \n ->
+ PFun \xs ->
+ PPrim
+ do blks <- enumerateSeqMap n . fromVSeq <$> xs
+ (SHA.SHA256S w0 w1 w2 w3 w4 w5 w6 _) <-
+ 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])
+ seq zs (pure (VSeq 7 zs)))
, ("processSHA2_256", {-# SCC "SuiteB::processSHA2_256" #-}
- ilam $ \n ->
- lam $ \xs ->
- do blks <- enumerateSeqMap n . fromVSeq <$> xs
- (SHA.SHA256S w0 w1 w2 w3 w4 w5 w6 w7) <-
- 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 Concrete (map f [w0,w1,w2,w3,w4,w5,w6,w7])
- seq zs (pure (VSeq 8 zs)))
+ PFinPoly \n ->
+ PFun \xs ->
+ PPrim
+ do blks <- enumerateSeqMap n . fromVSeq <$> xs
+ (SHA.SHA256S w0 w1 w2 w3 w4 w5 w6 w7) <-
+ 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])
+ seq zs (pure (VSeq 8 zs)))
, ("processSHA2_384", {-# SCC "SuiteB::processSHA2_384" #-}
- ilam $ \n ->
- lam $ \xs ->
- do blks <- enumerateSeqMap n . fromVSeq <$> xs
- (SHA.SHA512S w0 w1 w2 w3 w4 w5 _ _) <-
- 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 Concrete (map f [w0,w1,w2,w3,w4,w5])
- seq zs (pure (VSeq 6 zs)))
+ PFinPoly \n ->
+ PFun \xs ->
+ PPrim
+ do blks <- enumerateSeqMap n . fromVSeq <$> xs
+ (SHA.SHA512S w0 w1 w2 w3 w4 w5 _ _) <-
+ 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])
+ seq zs (pure (VSeq 6 zs)))
, ("processSHA2_512", {-# SCC "SuiteB::processSHA2_512" #-}
- ilam $ \n ->
- lam $ \xs ->
- do blks <- enumerateSeqMap n . fromVSeq <$> xs
- (SHA.SHA512S w0 w1 w2 w3 w4 w5 w6 w7) <-
- 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 Concrete (map f [w0,w1,w2,w3,w4,w5,w6,w7])
- seq zs (pure (VSeq 8 zs)))
+ PFinPoly \n ->
+ PFun \xs ->
+ PPrim
+ do blks <- enumerateSeqMap n . fromVSeq <$> xs
+ (SHA.SHA512S w0 w1 w2 w3 w4 w5 w6 w7) <-
+ 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])
+ seq zs (pure (VSeq 8 zs)))
, ("AESKeyExpand", {-# SCC "SuiteB::AESKeyExpand" #-}
- ilam $ \k ->
- lam $ \seed ->
+ PFinPoly \k ->
+ PFun \seed ->
+ PPrim
do ss <- fromVSeq <$> seed
let toWord :: Integer -> Eval Word32
toWord i = fromInteger. bvVal <$> (fromVWord Concrete "AESInfKeyExpand" =<< lookupSeqMap ss i)
@@ -497,10 +340,11 @@
kws <- mapM toWord [0 .. k-1]
let ws = AES.keyExpansionWords k kws
let len = 4*(k+7)
- pure (VSeq len (finiteSeqMap Concrete (map fromWord ws))))
+ pure (VSeq len (finiteSeqMap (map fromWord ws))))
, ("AESInvMixColumns", {-# SCC "SuiteB::AESInvMixColumns" #-}
- lam $ \st ->
+ PFun \st ->
+ PPrim
do ss <- fromVSeq <$> st
let toWord :: Integer -> Eval Word32
toWord i = fromInteger. bvVal <$> (fromVWord Concrete "AESInvMixColumns" =<< lookupSeqMap ss i)
@@ -508,10 +352,11 @@
fromWord = pure . VWord 32 . pure . WordVal . BV 32 . toInteger
ws <- mapM toWord [0,1,2,3]
let ws' = AES.invMixColumns ws
- pure . VSeq 4 . finiteSeqMap Concrete . map fromWord $ ws')
+ pure . VSeq 4 . finiteSeqMap . map fromWord $ ws')
, ("AESEncRound", {-# SCC "SuiteB::AESEncRound" #-}
- lam $ \st ->
+ PFun \st ->
+ PPrim
do ss <- fromVSeq <$> st
let toWord :: Integer -> Eval Word32
toWord i = fromInteger. bvVal <$> (fromVWord Concrete "AESEncRound" =<< lookupSeqMap ss i)
@@ -519,10 +364,11 @@
fromWord = pure . VWord 32 . pure . WordVal . BV 32 . toInteger
ws <- mapM toWord [0,1,2,3]
let ws' = AES.aesRound ws
- pure . VSeq 4 . finiteSeqMap Concrete . map fromWord $ ws')
+ pure . VSeq 4 . finiteSeqMap . map fromWord $ ws')
, ("AESEncFinalRound", {-# SCC "SuiteB::AESEncFinalRound" #-}
- lam $ \st ->
+ PFun \st ->
+ PPrim
do ss <- fromVSeq <$> st
let toWord :: Integer -> Eval Word32
toWord i = fromInteger. bvVal <$> (fromVWord Concrete "AESEncFinalRound" =<< lookupSeqMap ss i)
@@ -530,10 +376,11 @@
fromWord = pure . VWord 32 . pure . WordVal . BV 32 . toInteger
ws <- mapM toWord [0,1,2,3]
let ws' = AES.aesFinalRound ws
- pure . VSeq 4 . finiteSeqMap Concrete . map fromWord $ ws')
+ pure . VSeq 4 . finiteSeqMap . map fromWord $ ws')
, ("AESDecRound", {-# SCC "SuiteB::AESDecRound" #-}
- lam $ \st ->
+ PFun \st ->
+ PPrim
do ss <- fromVSeq <$> st
let toWord :: Integer -> Eval Word32
toWord i = fromInteger. bvVal <$> (fromVWord Concrete "AESDecRound" =<< lookupSeqMap ss i)
@@ -541,10 +388,11 @@
fromWord = pure . VWord 32 . pure . WordVal . BV 32 . toInteger
ws <- mapM toWord [0,1,2,3]
let ws' = AES.aesInvRound ws
- pure . VSeq 4 . finiteSeqMap Concrete . map fromWord $ ws')
+ pure . VSeq 4 . finiteSeqMap . map fromWord $ ws')
, ("AESDecFinalRound", {-# SCC "SuiteB::AESDecFinalRound" #-}
- lam $ \st ->
+ PFun \st ->
+ PPrim
do ss <- fromVSeq <$> st
let toWord :: Integer -> Eval Word32
toWord i = fromInteger. bvVal <$> (fromVWord Concrete "AESDecFinalRound" =<< lookupSeqMap ss i)
@@ -552,7 +400,7 @@
fromWord = pure . VWord 32 . pure . WordVal . BV 32 . toInteger
ws <- mapM toWord [0,1,2,3]
let ws' = AES.aesInvFinalRound ws
- pure . VSeq 4 . finiteSeqMap Concrete . map fromWord $ ws')
+ pure . VSeq 4 . finiteSeqMap . map fromWord $ ws')
]
@@ -603,12 +451,13 @@
--------------------------------------------------------------------------------
-sshrV :: Value
+sshrV :: Prim Concrete
sshrV =
- nlam $ \_n ->
- tlam $ \ix ->
- wlam Concrete $ \(BV w x) -> return $
- lam $ \y ->
+ 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
@@ -618,14 +467,15 @@
-- ^ The function may assume its arguments are masked.
-- It is responsible for masking its result if needed.
-> (Nat' -> TValue -> SeqMap Concrete -> Integer -> SeqMap Concrete)
- -> Value
-logicShift opW opS
- = nlam $ \ a ->
- tlam $ \ _ix ->
- tlam $ \ c ->
- lam $ \ l -> return $
- lam $ \ r -> do
- i <- r >>= \case
+ -> 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"]
@@ -795,55 +645,3 @@
updateBack_word (Nat n) _eltTy bs (Right w) val = do
idx <- bvVal <$> asWordVal Concrete w
updateWordValue Concrete bs (n - idx - 1) (fromVBit <$> val)
-
-
-floatPrims :: Concrete -> Map PrimIdent Value
-floatPrims sym = Map.fromList [ (floatPrim i,v) | (i,v) <- nonInfixTable ]
- where
- (~>) = (,)
- nonInfixTable =
- [ "fpNaN" ~> ilam \e -> ilam \p ->
- VFloat BF { bfValue = FP.bfNaN
- , bfExpWidth = e, bfPrecWidth = p }
-
- , "fpPosInf" ~> ilam \e -> ilam \p ->
- VFloat BF { bfValue = FP.bfPosInf
- , bfExpWidth = e, bfPrecWidth = p }
-
- , "fpFromBits" ~> ilam \e -> ilam \p -> wlam sym \bv ->
- pure $ VFloat $ floatFromBits e p $ bvVal bv
-
- , "fpToBits" ~> ilam \e -> ilam \p -> flam \x ->
- pure $ word sym (e + p)
- $ floatToBits e p
- $ bfValue x
- , "=.=" ~> ilam \_ -> ilam \_ -> flam \x -> pure $ flam \y ->
- pure $ VBit
- $ bitLit sym
- $ FP.bfCompare (bfValue x) (bfValue y) == EQ
-
- , "fpIsFinite" ~> ilam \_ -> ilam \_ -> flam \x ->
- pure $ VBit $ bitLit sym $ FP.bfIsFinite $ bfValue x
-
- -- From Backend class
- , "fpAdd" ~> fpBinArithV sym fpPlus
- , "fpSub" ~> fpBinArithV sym fpMinus
- , "fpMul" ~> fpBinArithV sym fpMult
- , "fpDiv" ~> fpBinArithV sym fpDiv
-
- , "fpFromRational" ~>
- ilam \e -> ilam \p -> wlam sym \r -> pure $ lam \x ->
- do rat <- fromVRational <$> x
- VFloat <$> do mode <- fpRoundMode sym r
- pure $ floatFromRational e p mode
- $ sNum rat % sDenom rat
- , "fpToRational" ~>
- ilam \_e -> ilam \_p -> flam \fp ->
- case floatToRational "fpToRational" fp of
- Left err -> raiseError sym err
- Right r -> pure $
- VRational
- SRational { sNum = numerator r, sDenom = denominator r }
- ]
-
-
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
@@ -16,8 +16,7 @@
import Cryptol.Backend
-import Cryptol.Backend.Monad( PPOpts )
-
+import Cryptol.Eval.Prims
import Cryptol.Eval.Type
import Cryptol.Eval.Value
import Cryptol.ModuleSystem.Name
@@ -25,7 +24,6 @@
import Cryptol.TypeCheck.Solver.InfNat
import Cryptol.Utils.PP
-
import qualified Data.IntMap.Strict as IntMap
import Data.Semigroup
@@ -37,29 +35,31 @@
-- Evaluation Environment ------------------------------------------------------
data GenEvalEnv sym = EvalEnv
- { envVars :: !(IntMap.IntMap (SEval sym (GenValue sym)))
+ { envVars :: !(IntMap.IntMap (Either (Prim sym) (SEval sym (GenValue sym))))
, envTypes :: !TypeEnv
} deriving Generic
instance Semigroup (GenEvalEnv sym) where
l <> r = EvalEnv
{ envVars = IntMap.union (envVars l) (envVars r)
- , envTypes = IntMap.union (envTypes l) (envTypes r)
+ , envTypes = envTypes l <> envTypes r
}
instance Monoid (GenEvalEnv sym) where
mempty = EvalEnv
{ envVars = IntMap.empty
- , envTypes = IntMap.empty
+ , envTypes = mempty
}
-
mappend l r = l <> r
ppEnv :: Backend sym => sym -> PPOpts -> GenEvalEnv sym -> SEval sym Doc
ppEnv sym opts env = brackets . fsep <$> mapM bind (IntMap.toList (envVars env))
where
- bind (k,v) = do vdoc <- ppValue sym opts =<< v
- return (int k <+> text "->" <+> vdoc)
+ bind (k,Left _) =
+ do return (int k <+> text "<>")
+ bind (k,Right v) =
+ do vdoc <- ppValue sym opts =<< v
+ return (int k <+> text "->" <+> vdoc)
-- | Evaluation environment with no bindings
emptyEnv :: GenEvalEnv sym
@@ -75,32 +75,32 @@
SEval sym (GenEvalEnv sym)
bindVar sym n val env = do
let nm = show $ ppLocName n
- val' <- sDelay sym (Just nm) val
- return $ env{ envVars = IntMap.insert (nameUnique n) val' (envVars env) }
+ val' <- sDelayFill sym val Nothing nm
+ return $ env{ envVars = IntMap.insert (nameUnique n) (Right val') (envVars env) }
-- | Bind a variable to a value in the evaluation environment, without
-- creating a thunk.
bindVarDirect ::
Backend sym =>
Name ->
- GenValue sym ->
+ Prim sym ->
GenEvalEnv sym ->
GenEvalEnv sym
bindVarDirect n val env = do
- env{ envVars = IntMap.insert (nameUnique n) (pure val) (envVars env) }
+ env{ envVars = IntMap.insert (nameUnique n) (Left val) (envVars env) }
-- | Lookup a variable in the environment.
{-# INLINE lookupVar #-}
-lookupVar :: Name -> GenEvalEnv sym -> Maybe (SEval sym (GenValue sym))
+lookupVar :: Name -> GenEvalEnv sym -> Maybe (Either (Prim sym) (SEval sym (GenValue sym)))
lookupVar n env = IntMap.lookup (nameUnique n) (envVars env)
-- | Bind a type variable of kind *.
{-# INLINE bindType #-}
bindType :: TVar -> Either Nat' TValue -> GenEvalEnv sym -> GenEvalEnv sym
-bindType p ty env = env { envTypes = IntMap.insert (tvUnique p) ty (envTypes env) }
+bindType p ty env = env{ envTypes = bindTypeVar p ty (envTypes env) }
-- | Lookup a type variable.
{-# INLINE lookupType #-}
lookupType :: TVar -> GenEvalEnv sym -> Maybe (Either Nat' TValue)
-lookupType p env = IntMap.lookup (tvUnique p) (envTypes env)
+lookupType p env = lookupTypeVar p (envTypes env)
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
@@ -11,6 +11,7 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE Rank2Types #-}
@@ -27,24 +28,28 @@
import System.Random.TF.Gen (seedTFGen)
import Data.Bits (testBit, (.&.), 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.Backend
import Cryptol.Backend.Concrete (Concrete(..))
-import Cryptol.Backend.Monad ( Eval, evalPanic, EvalError(..), Unsupported(..) )
+import Cryptol.Backend.Monad( Eval, evalPanic, EvalError(..), Unsupported(..) )
import Cryptol.Testing.Random( randomValue )
+import Cryptol.Eval.Prims
import Cryptol.Eval.Type
import Cryptol.Eval.Value
+import Cryptol.Utils.Ident (PrimIdent, prelPrim, floatPrim)
+import Cryptol.Utils.Logger(logPrint)
import Cryptol.Utils.Panic (panic)
+import Cryptol.Utils.PP
import Cryptol.Utils.RecordMap
-
{-# SPECIALIZE mkLit :: Concrete -> TValue -> Integer -> Eval (GenValue Concrete)
#-}
@@ -63,14 +68,15 @@
_ -> evalPanic "Cryptol.Eval.Prim.evalConst"
[ "Invalid type for number" ]
-{-# SPECIALIZE ecNumberV :: Concrete -> GenValue Concrete
+{-# SPECIALIZE ecNumberV :: Concrete -> Prim Concrete
#-}
-- | Make a numeric constant.
-ecNumberV :: Backend sym => sym -> GenValue sym
+ecNumberV :: Backend sym => sym -> Prim sym
ecNumberV sym =
- nlam $ \valT ->
- VPoly $ \ty ->
+ PNumPoly \valT ->
+ PTyPoly \ty ->
+ PPrim
case valT of
Nat v -> mkLit sym ty v
_ -> evalPanic "Cryptol.Eval.Prim.evalConst"
@@ -80,32 +86,38 @@
]
-
{-# SPECIALIZE intV :: Concrete -> Integer -> TValue -> Eval (GenValue Concrete)
#-}
intV :: Backend sym => sym -> SInteger sym -> TValue -> SEval sym (GenValue sym)
-intV sym i = ringNullary sym (\w -> wordFromInt sym w i) (pure i) (\m -> intToZn sym m i) (intToRational sym i)
- (\e p -> fpRndMode sym >>= \r -> fpFromInteger sym e p r i)
+intV sym i =
+ ringNullary sym
+ (\w -> wordFromInt sym w i)
+ (pure i)
+ (\m -> intToZn sym m i)
+ (intToRational sym i)
+ (\e p -> fpRndMode sym >>= \r -> fpFromInteger sym e p r i)
-{-# SPECIALIZE ratioV :: Concrete -> GenValue Concrete #-}
-ratioV :: Backend sym => sym -> GenValue sym
+{-# SPECIALIZE ratioV :: Concrete -> Prim Concrete #-}
+ratioV :: Backend sym => sym -> Prim sym
ratioV sym =
- lam $ \x -> return $
- lam $ \y ->
+ PFun \x ->
+ PFun \y ->
+ PPrim
do x' <- fromVInteger <$> x
y' <- fromVInteger <$> y
VRational <$> ratio sym x' y'
-{-# SPECIALIZE ecFractionV :: Concrete -> GenValue Concrete
+{-# SPECIALIZE ecFractionV :: Concrete -> Prim Concrete
#-}
-ecFractionV :: Backend sym => sym -> GenValue sym
+ecFractionV :: Backend sym => sym -> Prim sym
ecFractionV sym =
- ilam \n ->
- ilam \d ->
- ilam \_r ->
- VPoly \ty ->
+ PFinPoly \n ->
+ PFinPoly \d ->
+ PFinPoly \_r ->
+ PTyPoly \ty ->
+ PPrim
case ty of
- TVFloat e p -> VFloat <$> fpLit sym e p (n % d)
+ TVFloat e p -> VFloat <$> fpLit sym e p (n % d)
TVRational ->
do x <- integerLit sym n
y <- integerLit sym d
@@ -116,34 +128,38 @@
-{-# SPECIALIZE fromZV :: Concrete -> GenValue Concrete #-}
-fromZV :: Backend sym => sym -> GenValue sym
+{-# SPECIALIZE fromZV :: Concrete -> Prim Concrete #-}
+fromZV :: Backend sym => sym -> Prim sym
fromZV sym =
- nlam $ \(finNat' -> n) ->
- lam $ \v -> VInteger <$> (znToInt sym n . fromVInteger =<< v)
+ PFinPoly \n ->
+ PFun \v ->
+ PPrim
+ (VInteger <$> (znToInt sym n . fromVInteger =<< v))
-- Operation Lifting -----------------------------------------------------------
type Binary sym = TValue -> GenValue sym -> GenValue sym -> SEval sym (GenValue sym)
-{-# SPECIALIZE binary :: Binary Concrete -> GenValue Concrete
+{-# SPECIALIZE binary :: Binary Concrete -> Prim Concrete
#-}
-binary :: Backend sym => Binary sym -> GenValue sym
-binary f = tlam $ \ ty ->
- lam $ \ a -> return $
- lam $ \ b -> do
- --io $ putStrLn "Entering a binary function"
- join (f ty <$> a <*> b)
+binary :: Backend sym => Binary sym -> Prim sym
+binary f = PTyPoly \ty ->
+ PFun \a ->
+ PFun \b ->
+ PPrim $
+ do x <- a
+ y <- b
+ f ty x y
type Unary sym = TValue -> GenValue sym -> SEval sym (GenValue sym)
-{-# SPECIALIZE unary :: Unary Concrete -> GenValue Concrete
+{-# SPECIALIZE unary :: Unary Concrete -> Prim Concrete
#-}
-unary :: Backend sym => Unary sym -> GenValue sym
-unary f = tlam $ \ ty ->
- lam $ \ a -> f ty =<< a
-
+unary :: Backend sym => Unary sym -> Prim sym
+unary f = PTyPoly \ty ->
+ PFun \a ->
+ PPrim (f ty =<< a)
type BinWord sym = Integer -> SWord sym -> SWord sym -> SEval sym (SWord sym)
@@ -200,37 +216,41 @@
| isTBit a -> do
lw <- fromVWord sym "ringLeft" l
rw <- fromVWord sym "ringRight" r
- return $ VWord w (WordVal <$> opw w lw rw)
- | otherwise -> VSeq w <$> (join (zipSeqMap (loop a) <$>
+ stk <- sGetCallStack sym
+ return $ VWord w (WordVal <$> (sWithCallStack sym stk (opw w lw rw)))
+ | otherwise -> VSeq w <$> (join (zipSeqMap sym (loop a) <$>
(fromSeq "ringBinary left" l) <*>
(fromSeq "ringBinary right" r)))
TVStream a ->
-- streams
- VStream <$> (join (zipSeqMap (loop a) <$>
+ VStream <$> (join (zipSeqMap sym (loop a) <$>
(fromSeq "ringBinary left" l) <*>
(fromSeq "ringBinary right" r)))
-- functions
TVFun _ ety ->
- return $ lam $ \ x -> loop' ety (fromVFun l x) (fromVFun r x)
+ lam sym $ \ x -> loop' ety (fromVFun sym l x) (fromVFun sym r x)
-- tuples
TVTuple tys ->
- do ls <- mapM (sDelay sym Nothing) (fromVTuple l)
- rs <- mapM (sDelay sym Nothing) (fromVTuple r)
+ do ls <- mapM (sDelay sym) (fromVTuple l)
+ rs <- mapM (sDelay sym) (fromVTuple r)
return $ VTuple (zipWith3 loop' tys ls rs)
-- records
TVRec fs ->
do VRecord <$>
traverseRecordMap
- (\f fty -> sDelay sym Nothing (loop' fty (lookupRecord f l) (lookupRecord f r)))
+ (\f fty -> sDelay sym (loop' fty (lookupRecord f l) (lookupRecord f r)))
fs
TVAbstract {} ->
evalPanic "ringBinary" ["Abstract type not in `Ring`"]
+ TVNewtype {} ->
+ evalPanic "ringBinary" ["Newtype not in `Ring`"]
+
type UnaryWord sym = Integer -> SWord sym -> SEval sym (SWord sym)
@@ -282,30 +302,34 @@
-- words and finite sequences
| isTBit a -> do
wx <- fromVWord sym "ringUnary" v
- return $ VWord w (WordVal <$> opw w wx)
- | otherwise -> VSeq w <$> (mapSeqMap (loop a) =<< fromSeq "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)
TVStream a ->
- VStream <$> (mapSeqMap (loop a) =<< fromSeq "ringUnary" v)
+ VStream <$> (mapSeqMap sym (loop a) =<< fromSeq "ringUnary" v)
-- functions
TVFun _ ety ->
- return $ lam $ \ y -> loop' ety (fromVFun v y)
+ lam sym $ \ y -> loop' ety (fromVFun sym v y)
-- tuples
TVTuple tys ->
- do as <- mapM (sDelay sym Nothing) (fromVTuple v)
+ do as <- mapM (sDelay sym) (fromVTuple v)
return $ VTuple (zipWith loop' tys as)
-- records
TVRec fs ->
VRecord <$>
traverseRecordMap
- (\f fty -> sDelay sym Nothing (loop' fty (lookupRecord f v)))
+ (\f fty -> sDelay sym (loop' fty (lookupRecord f v)))
fs
TVAbstract {} -> evalPanic "ringUnary" ["Abstract type not in `Ring`"]
+ TVNewtype {} -> evalPanic "ringUnary" ["Newtype not in `Ring`"]
+
+
{-# SPECIALIZE ringNullary ::
Concrete ->
(Integer -> SEval Concrete (SWord Concrete)) ->
@@ -346,30 +370,35 @@
TVSeq w a
-- words and finite sequences
- | isTBit a -> pure $ VWord w $ (WordVal <$> opw w)
+ | isTBit a ->
+ do stk <- sGetCallStack sym
+ pure $ VWord w $ (WordVal <$> sWithCallStack sym stk (opw w))
| otherwise ->
- do v <- sDelay sym Nothing (loop a)
- pure $ VSeq w $ IndexSeqMap $ const v
+ do v <- sDelay sym (loop a)
+ pure $ VSeq w $ IndexSeqMap \_i -> v
TVStream a ->
- do v <- sDelay sym Nothing (loop a)
- pure $ VStream $ IndexSeqMap $ const v
+ do v <- sDelay sym (loop a)
+ pure $ VStream $ IndexSeqMap \_i -> v
TVFun _ b ->
- do v <- sDelay sym Nothing (loop b)
- pure $ lam $ const $ v
+ do v <- sDelay sym (loop b)
+ lam sym (const v)
TVTuple tys ->
- do xs <- mapM (sDelay sym Nothing . loop) tys
+ do xs <- mapM (sDelay sym . loop) tys
pure $ VTuple xs
TVRec fs ->
- do xs <- traverse (sDelay sym Nothing . loop) fs
+ do xs <- traverse (sDelay sym . loop) fs
pure $ VRecord xs
TVAbstract {} ->
evalPanic "ringNullary" ["Abstract type not in `Ring`"]
+ TVNewtype {} ->
+ evalPanic "ringNullary" ["Newtype not in `Ring`"]
+
{-# SPECIALIZE integralBinary :: Concrete -> BinWord Concrete ->
(SInteger Concrete -> SInteger Concrete -> SEval Concrete (SInteger Concrete)) ->
Binary Concrete
@@ -390,7 +419,8 @@
| isTBit a ->
do wl <- fromVWord sym "integralBinary left" l
wr <- fromVWord sym "integralBinary right" r
- return $ VWord w (WordVal <$> opw w wl wr)
+ stk <- sGetCallStack sym
+ return $ VWord w (WordVal <$> sWithCallStack sym stk (opw w wl wr))
_ -> evalPanic "integralBinary" [show ty ++ " not int class `Integral`"]
@@ -398,15 +428,16 @@
---------------------------------------------------------------------------
-- Ring
-{-# SPECIALIZE fromIntegerV :: Concrete -> GenValue Concrete
+{-# SPECIALIZE fromIntegerV :: Concrete -> Prim Concrete
#-}
-- | Convert an unbounded integer to a value in Ring
-fromIntegerV :: Backend sym => sym -> GenValue sym
+fromIntegerV :: Backend sym => sym -> Prim sym
fromIntegerV sym =
- tlam $ \ a ->
- lam $ \ v ->
- do i <- fromVInteger <$> v
- intV sym i a
+ PTyPoly \a ->
+ PFun \v ->
+ PPrim
+ do i <- fromVInteger <$> v
+ intV sym i a
{-# INLINE addV #-}
addV :: Backend sym => sym -> Binary sym
@@ -458,13 +489,14 @@
opw _w x y = wordDiv sym x y
opi x y = intDiv sym x y
-{-# SPECIALIZE expV :: Concrete -> GenValue Concrete #-}
-expV :: Backend sym => sym -> GenValue sym
+{-# SPECIALIZE expV :: Concrete -> Prim Concrete #-}
+expV :: Backend sym => sym -> Prim sym
expV sym =
- tlam $ \aty ->
- tlam $ \ety ->
- lam $ \am -> return $
- lam $ \em ->
+ PTyPoly \aty ->
+ PTyPoly \ety ->
+ PFun \am ->
+ PFun \em ->
+ PPrim
do a <- am
e <- em
case ety of
@@ -522,12 +554,13 @@
opw _w x y = wordMod sym x y
opi x y = intMod sym x y
-{-# SPECIALIZE toIntegerV :: Concrete -> GenValue Concrete #-}
+{-# SPECIALIZE toIntegerV :: Concrete -> Prim Concrete #-}
-- | Convert a word to a non-negative integer.
-toIntegerV :: Backend sym => sym -> GenValue sym
+toIntegerV :: Backend sym => sym -> Prim sym
toIntegerV sym =
- tlam $ \a ->
- lam $ \v ->
+ PTyPoly \a ->
+ PFun \v ->
+ PPrim
case a of
TVSeq _w el | isTBit el ->
VInteger <$> (wordToInt sym =<< (fromVWord sym "toInteger" =<< v))
@@ -537,11 +570,12 @@
-----------------------------------------------------------------------------
-- Field
-{-# SPECIALIZE recipV :: Concrete -> GenValue Concrete #-}
-recipV :: Backend sym => sym -> GenValue sym
+{-# SPECIALIZE recipV :: Concrete -> Prim Concrete #-}
+recipV :: Backend sym => sym -> Prim sym
recipV sym =
- tlam $ \a ->
- lam $ \x ->
+ PTyPoly \a ->
+ PFun \x ->
+ PPrim
case a of
TVRational -> VRational <$> (rationalRecip sym . fromVRational =<< x)
TVFloat e p ->
@@ -552,12 +586,13 @@
TVIntMod m -> VInteger <$> (znRecip sym m . fromVInteger =<< x)
_ -> evalPanic "recip" [show a ++ "is not a Field"]
-{-# SPECIALIZE fieldDivideV :: Concrete -> GenValue Concrete #-}
-fieldDivideV :: Backend sym => sym -> GenValue sym
+{-# SPECIALIZE fieldDivideV :: Concrete -> Prim Concrete #-}
+fieldDivideV :: Backend sym => sym -> Prim sym
fieldDivideV sym =
- tlam $ \a ->
- lam $ \x -> return $
- lam $ \y ->
+ PTyPoly \a ->
+ PFun \x ->
+ PFun \y ->
+ PPrim
case a of
TVRational ->
do x' <- fromVRational <$> x
@@ -656,27 +691,27 @@
-- Bitvector signed div and modulus
{-# INLINE lg2V #-}
-lg2V :: Backend sym => sym -> GenValue sym
+lg2V :: Backend sym => sym -> Prim sym
lg2V sym =
- nlam $ \(finNat' -> w) ->
- wlam sym $ \x -> return $
- VWord w (WordVal <$> wordLg2 sym x)
+ PFinPoly \w ->
+ PWordFun \x ->
+ PVal (VWord w (WordVal <$> wordLg2 sym x))
-{-# SPECIALIZE sdivV :: Concrete -> GenValue Concrete #-}
-sdivV :: Backend sym => sym -> GenValue sym
+{-# SPECIALIZE sdivV :: Concrete -> Prim Concrete #-}
+sdivV :: Backend sym => sym -> Prim sym
sdivV sym =
- nlam $ \(finNat' -> w) ->
- wlam sym $ \x -> return $
- wlam sym $ \y -> return $
- VWord w (WordVal <$> wordSignedDiv sym x y)
+ PFinPoly \w ->
+ PWordFun \x ->
+ PWordFun \y ->
+ PVal (VWord w (WordVal <$> wordSignedDiv sym x y))
-{-# SPECIALIZE smodV :: Concrete -> GenValue Concrete #-}
-smodV :: Backend sym => sym -> GenValue sym
+{-# SPECIALIZE smodV :: Concrete -> Prim Concrete #-}
+smodV :: Backend sym => sym -> Prim sym
smodV sym =
- nlam $ \(finNat' -> w) ->
- wlam sym $ \x -> return $
- wlam sym $ \y -> return $
- VWord w (WordVal <$> wordSignedMod sym x y)
+ PFinPoly \w ->
+ PWordFun \x ->
+ PWordFun \y ->
+ PVal (VWord w (WordVal <$> wordSignedMod sym x y))
-- Cmp -------------------------------------------------------------------------
@@ -733,6 +768,9 @@
TVAbstract {} -> evalPanic "cmpValue"
[ "Abstract type not in `Cmp`" ]
+ TVNewtype {} -> evalPanic "cmpValue"
+ [ "Newtype not in `Cmp`" ]
+
cmpValues (t : ts) (x1 : xs1) (x2 : xs2) k =
do x1' <- x1
x2' <- x2
@@ -879,30 +917,32 @@
TVSeq w ety
| isTBit ety -> pure $ word sym w 0
| otherwise ->
- do z <- sDelay sym Nothing (zeroV sym ety)
- pure $ VSeq w (IndexSeqMap $ const z)
+ do z <- sDelay sym (zeroV sym ety)
+ pure $ VSeq w (IndexSeqMap \_i -> z)
TVStream ety ->
- do z <- sDelay sym Nothing (zeroV sym ety)
- pure $ VStream (IndexSeqMap $ const z)
+ do z <- sDelay sym (zeroV sym ety)
+ pure $ VStream (IndexSeqMap \_i -> z)
-- functions
TVFun _ bty ->
- do z <- sDelay sym Nothing (zeroV sym bty)
- pure $ lam (const z)
+ do z <- sDelay sym (zeroV sym bty)
+ lam sym (const z)
-- tuples
TVTuple tys ->
- do xs <- mapM (sDelay sym Nothing . zeroV sym) tys
+ do xs <- mapM (sDelay sym . zeroV sym) tys
pure $ VTuple xs
-- records
TVRec fields ->
- do xs <- traverse (sDelay sym Nothing . zeroV sym) fields
+ do xs <- traverse (sDelay sym . zeroV sym) fields
pure $ VRecord xs
TVAbstract {} -> evalPanic "zeroV" [ "Abstract type not in `Zero`" ]
+ TVNewtype {} -> evalPanic "zeroV" [ "Newtype not in `Zero`" ]
+
-- | otherwise = evalPanic "zeroV" ["invalid type for zero"]
{-# INLINE joinWordVal #-}
@@ -936,7 +976,7 @@
where
loop :: SEval sym (WordValue sym) -> [SEval sym (GenValue sym)] -> SEval sym (GenValue sym)
loop !wv [] =
- VWord (nParts * nEach) <$> sDelay sym Nothing wv
+ VWord (nParts * nEach) <$> sDelay sym wv
loop !wv (w : ws) =
w >>= \case
VWord _ w' ->
@@ -1038,24 +1078,24 @@
case back of
Nat rightWidth | aBit -> do
- ws <- sDelay sym Nothing (splitWordVal sym leftWidth rightWidth =<< fromWordVal "splitAtV" val)
+ 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 Nothing (fromSeq "splitAtV" val)
- ls <- sDelay sym Nothing (fst . splitSeqMap leftWidth <$> vs)
- rs <- sDelay sym Nothing (snd . splitSeqMap leftWidth <$> vs)
+ 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 Nothing (fromSeq "splitAtV" val)
- ls <- sDelay sym Nothing (fst . splitSeqMap leftWidth <$> vs)
- rs <- sDelay sym Nothing (snd . splitSeqMap leftWidth <$> vs)
+ 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
]
@@ -1093,19 +1133,20 @@
{-# INLINE ecSplitV #-}
-- | Split implementation.
-ecSplitV :: Backend sym => sym -> GenValue sym
+ecSplitV :: Backend sym => sym -> Prim sym
ecSplitV sym =
- nlam $ \ parts ->
- nlam $ \ each ->
- tlam $ \ a ->
- lam $ \ val ->
+ PNumPoly \parts ->
+ PNumPoly \each ->
+ PTyPoly \a ->
+ PFun \val ->
+ PPrim
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 Nothing (fromSeq "ecSplitV" =<< val)
+ val' <- sDelay sym (fromSeq "ecSplitV" =<< val)
return $ VStream $ IndexSeqMap $ \i ->
return $ VWord e $ return $ LargeBitsVal e $ IndexSeqMap $ \j ->
let idx = i*e + toInteger j
@@ -1113,13 +1154,13 @@
xs <- val'
lookupSeqMap xs idx
(Nat p, Nat e) -> do
- val' <- sDelay sym Nothing (fromSeq "ecSplitV" =<< val)
+ val' <- sDelay sym (fromSeq "ecSplitV" =<< 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 Nothing (fromSeq "ecSplitV" =<< val)
+ val' <- sDelay sym (fromSeq "ecSplitV" =<< val)
return $ VStream $ IndexSeqMap $ \i ->
return $ VSeq e $ IndexSeqMap $ \j -> do
xs <- val'
@@ -1157,7 +1198,8 @@
| 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 ->
- do ys <- flip lookupSeqMap (toInteger ai) =<< fromSeq "transposeV" xs
+ 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)
@@ -1166,7 +1208,8 @@
| isTBit c, Inf <- a = -- [inf][b]Bit -> [b][inf]Bit
return $ bseq $ IndexSeqMap $ \bi ->
return $ VStream $ IndexSeqMap $ \ai ->
- do ys <- flip lookupSeqMap ai =<< fromSeq "transposeV" xs
+ 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)
@@ -1175,8 +1218,9 @@
| otherwise = -- [a][b]c -> [b][a]c
return $ bseq $ IndexSeqMap $ \bi ->
return $ aseq $ IndexSeqMap $ \ai -> do
- ys <- flip lookupSeqMap ai =<< fromSeq "transposeV 1" xs
- z <- flip lookupSeqMap bi =<< fromSeq "transposeV 2" ys
+ xs' <- fromSeq "transposeV 1" xs
+ ys <- fromSeq "transposeV 2" =<< lookupSeqMap xs' ai
+ z <- lookupSeqMap ys bi
return z
where
@@ -1206,7 +1250,7 @@
return $ VWord (m+n) (join (joinWordVal sym <$> l <*> r))
ccatV sym _front _back _elty (VWord m l) (VStream r) = do
- l' <- sDelay sym Nothing l
+ l' <- sDelay sym l
return $ VStream $ IndexSeqMap $ \i ->
if i < m then
VBit <$> (flip (indexWordValue sym) i =<< l')
@@ -1214,8 +1258,8 @@
lookupSeqMap r (i-m)
ccatV sym front back elty l r = do
- l'' <- sDelay sym Nothing (fromSeq "ccatV left" l)
- r'' <- sDelay sym Nothing (fromSeq "ccatV right" r)
+ 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
@@ -1238,7 +1282,7 @@
wordValLogicOp _sym _ wop (WordVal w1) (WordVal w2) = WordVal <$> wop w1 w2
wordValLogicOp sym bop _ w1 w2 = LargeBitsVal (wordValueSize sym w1) <$> zs
- where zs = memoMap $ IndexSeqMap $ \i -> join (op <$> (lookupSeqMap xs i) <*> (lookupSeqMap ys i))
+ 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))
@@ -1281,7 +1325,7 @@
TVSeq w aty
-- words
| isTBit aty
- -> do v <- sDelay sym Nothing $ join
+ -> do v <- sDelay sym $ join
(wordValLogicOp sym opb opw <$>
fromWordVal "logicBinary l" l <*>
fromWordVal "logicBinary r" r)
@@ -1289,41 +1333,45 @@
-- finite sequences
| otherwise -> VSeq w <$>
- (join (zipSeqMap (loop aty) <$>
+ (join (zipSeqMap sym (loop aty) <$>
(fromSeq "logicBinary left" l)
<*> (fromSeq "logicBinary right" r)))
TVStream aty ->
- VStream <$> (join (zipSeqMap (loop aty) <$>
+ VStream <$> (join (zipSeqMap sym (loop aty) <$>
(fromSeq "logicBinary left" l) <*>
(fromSeq "logicBinary right" r)))
TVTuple etys -> do
- ls <- mapM (sDelay sym Nothing) (fromVTuple l)
- rs <- mapM (sDelay sym Nothing) (fromVTuple r)
+ ls <- mapM (sDelay sym) (fromVTuple l)
+ rs <- mapM (sDelay sym) (fromVTuple r)
return $ VTuple $ zipWith3 loop' etys ls rs
TVFun _ bty ->
- return $ lam $ \ a -> loop' bty (fromVFun l a) (fromVFun r a)
+ lam sym $ \ a -> loop' bty (fromVFun sym l a) (fromVFun sym r a)
TVRec fields ->
VRecord <$>
traverseRecordMap
- (\f fty -> sDelay sym Nothing (loop' fty (lookupRecord f l) (lookupRecord f r)))
+ (\f fty -> sDelay sym (loop' fty (lookupRecord f l) (lookupRecord f r)))
fields
TVAbstract {} -> evalPanic "logicBinary"
[ "Abstract type not in `Logic`" ]
+ 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 bop _ (LargeBitsVal n xs) = LargeBitsVal n <$> mapSeqMap f xs
+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 ::
@@ -1357,32 +1405,33 @@
TVSeq w ety
-- words
| isTBit ety
- -> do v <- sDelay sym Nothing (wordValUnaryOp opb opw =<< fromWordVal "logicUnary" val)
+ -> do v <- sDelay sym (wordValUnaryOp sym opb opw =<< fromWordVal "logicUnary" val)
return $ VWord w v
-- finite sequences
| otherwise
- -> VSeq w <$> (mapSeqMap (loop ety) =<< fromSeq "logicUnary" val)
+ -> VSeq w <$> (mapSeqMap sym (loop ety) =<< fromSeq "logicUnary" val)
-- streams
TVStream ety ->
- VStream <$> (mapSeqMap (loop ety) =<< fromSeq "logicUnary" val)
+ VStream <$> (mapSeqMap sym (loop ety) =<< fromSeq "logicUnary" val)
TVTuple etys ->
- do as <- mapM (sDelay sym Nothing) (fromVTuple val)
+ do as <- mapM (sDelay sym) (fromVTuple val)
return $ VTuple (zipWith loop' etys as)
TVFun _ bty ->
- return $ lam $ \ a -> loop' bty (fromVFun val a)
+ lam sym $ \ a -> loop' bty (fromVFun sym val a)
TVRec fields ->
VRecord <$>
traverseRecordMap
- (\f fty -> sDelay sym Nothing (loop' fty (lookupRecord f val)))
+ (\f fty -> sDelay sym (loop' fty (lookupRecord f val)))
fields
TVAbstract {} -> evalPanic "logicUnary" [ "Abstract type not in `Logic`" ]
+ TVNewtype {} -> evalPanic "logicUnary" [ "Newtype not in `Logic`" ]
{-# SPECIALIZE bitsValueLessThan ::
Concrete ->
@@ -1471,14 +1520,15 @@
(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)) ->
- GenValue sym
+ Prim sym
indexPrim sym int_op bits_op word_op =
- nlam $ \ len ->
- tlam $ \ eltTy ->
- tlam $ \ ix ->
- lam $ \ xs -> return $
- lam $ \ idx -> do
- vs <- xs >>= \case
+ PNumPoly \len ->
+ PTyPoly \eltTy ->
+ PTyPoly \ix ->
+ PFun \xs ->
+ PFun \idx ->
+ PPrim
+ do vs <- xs >>= \case
VWord _ w -> w >>= \w' -> return $ IndexSeqMap (\i -> VBit <$> indexWordValue sym w' i)
VSeq _ vs -> return vs
VStream vs -> return vs
@@ -1486,7 +1536,7 @@
idx' <- asIndex sym "index" ix =<< idx
assertIndexInBounds sym len idx'
case idx' of
- Left i -> int_op len eltTy vs ix i
+ 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)
@@ -1497,31 +1547,33 @@
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)) ->
- GenValue sym
+ Prim sym
updatePrim sym updateWord updateSeq =
- nlam $ \len ->
- tlam $ \eltTy ->
- tlam $ \ix ->
- lam $ \xs -> return $
- lam $ \idx -> return $
- lam $ \val -> do
- idx' <- asIndex sym "update" ix =<< idx
- assertIndexInBounds sym len idx'
- xs >>= \case
- VWord l w -> do w' <- sDelay sym Nothing 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"]
+ PNumPoly \len ->
+ PTyPoly \eltTy ->
+ PTyPoly \ix ->
+ PFun \xs ->
+ PFun \idx ->
+ PFun \val ->
+ PPrim
+ 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"]
{-# INLINE fromToV #-}
-- @[ 0 .. 10 ]@
-fromToV :: Backend sym => sym -> GenValue sym
+fromToV :: Backend sym => sym -> Prim sym
fromToV sym =
- nlam $ \ first ->
- nlam $ \ lst ->
- tlam $ \ ty ->
+ PNumPoly \first ->
+ PNumPoly \lst ->
+ PTyPoly \ty ->
+ PVal
let !f = mkLit sym ty in
case (first, lst) of
(Nat first', Nat lst') ->
@@ -1529,16 +1581,32 @@
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 -> GenValue sym
+fromThenToV :: Backend sym => sym -> Prim sym
fromThenToV sym =
- nlam $ \ first ->
- nlam $ \ next ->
- nlam $ \ lst ->
- tlam $ \ ty ->
- nlam $ \ len ->
+ PNumPoly \first ->
+ PNumPoly \next ->
+ PNumPoly \lst ->
+ PTyPoly \ty ->
+ PNumPoly \len ->
+ PVal
let !f = mkLit sym ty in
case (first, next, lst, len) of
(Nat first', Nat next', Nat _lst', Nat len') ->
@@ -1547,31 +1615,33 @@
_ -> evalPanic "fromThenToV" ["invalid arguments"]
{-# INLINE infFromV #-}
-infFromV :: Backend sym => sym -> GenValue sym
+infFromV :: Backend sym => sym -> Prim sym
infFromV sym =
- tlam $ \ ty ->
- lam $ \ x ->
- do mx <- sDelay sym Nothing x
- return $ VStream $ IndexSeqMap $ \i ->
- do x' <- mx
- i' <- integerLit sym i
- addV sym ty x' =<< intV sym i' ty
+ PTyPoly \ty ->
+ PFun \x ->
+ PPrim
+ do mx <- sDelay sym x
+ return $ VStream $ IndexSeqMap $ \i ->
+ do x' <- mx
+ i' <- integerLit sym i
+ addV sym ty x' =<< intV sym i' ty
{-# INLINE infFromThenV #-}
-infFromThenV :: Backend sym => sym -> GenValue sym
+infFromThenV :: Backend sym => sym -> Prim sym
infFromThenV sym =
- tlam $ \ ty ->
- lam $ \ first -> return $
- lam $ \ next ->
- do mxd <- sDelay sym Nothing
- (do x <- first
- y <- next
- d <- subV sym ty y x
- pure (x,d))
- return $ VStream $ IndexSeqMap $ \i -> do
- (x,d) <- mxd
- i' <- integerLit sym i
- addV sym ty x =<< mulV sym ty d =<< intV sym i' ty
+ PTyPoly \ty ->
+ PFun \first ->
+ PFun \next ->
+ PPrim
+ do mxd <- sDelay sym
+ (do x <- first
+ y <- next
+ d <- subV sym ty y x
+ pure (x,d))
+ 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 ---------------------------------------------------
@@ -1596,7 +1666,7 @@
| otherwise
= do x_shft <- shift_op x (2 ^ length bs)
- x' <- memoMap (mergeSeqMap sym b x_shft x)
+ x' <- memoMap sym (mergeSeqMap sym b x_shft x)
go x' bs
{-# INLINE shiftLeftReindex #-}
@@ -1670,13 +1740,14 @@
{- ^ reindexing operation for positive indices (sequence size, starting index, shift amount -} ->
(Nat' -> Integer -> Integer -> Maybe Integer)
{- ^ reindexing operation for negative indices (sequence size, starting index, shift amount -} ->
- GenValue sym
+ Prim sym
logicShift sym nm shrinkRange wopPos wopNeg reindexPos reindexNeg =
- nlam $ \m ->
- tlam $ \ix ->
- tlam $ \a ->
- VFun $ \xs -> return $
- VFun $ \y ->
+ PNumPoly \m ->
+ PTyPoly \ix ->
+ PTyPoly \a ->
+ PFun \xs ->
+ PFun \y ->
+ PPrim
do xs' <- xs
y' <- asIndex sym "shift" ix =<< y
case y' of
@@ -1701,7 +1772,7 @@
SEval sym (GenValue sym)
intShifter sym nm wop reindex m ix a xs idx =
do let shiftOp vs shft =
- memoMap $ IndexSeqMap $ \i ->
+ memoMap sym $ IndexSeqMap $ \i ->
case reindex m i shft of
Nothing -> zeroV sym a
Just i' -> lookupSeqMap vs i'
@@ -1737,7 +1808,7 @@
SEval sym (GenValue sym)
wordShifter sym nm wop reindex m a xs idx =
let shiftOp vs shft =
- memoMap $ IndexSeqMap $ \i ->
+ memoMap sym $ IndexSeqMap $ \i ->
case reindex m i shft of
Nothing -> zeroV sym a
Just i' -> lookupSeqMap vs i'
@@ -1789,37 +1860,38 @@
TValue ->
String ->
SEval sym (GenValue sym)
-errorV sym ty msg = case ty of
- -- bits
- TVBit -> cryUserError sym msg
- TVInteger -> cryUserError sym msg
- TVIntMod _ -> cryUserError sym msg
- TVRational -> cryUserError sym msg
- TVArray{} -> cryUserError sym msg
- TVFloat {} -> cryUserError sym msg
+errorV sym ty0 msg =
+ do stk <- sGetCallStack sym
+ loop stk ty0
+ where
+ err stk = sWithCallStack sym stk (cryUserError sym msg)
- -- sequences
- TVSeq w ety
- | isTBit ety -> return $ VWord w $ return $ LargeBitsVal w $ IndexSeqMap $ \_ -> cryUserError sym msg
- | otherwise -> return $ VSeq w (IndexSeqMap $ \_ -> errorV sym ety msg)
+ loop stk = \case
+ TVBit -> err stk
+ TVInteger -> err stk
+ TVIntMod _ -> err stk
+ TVRational -> err stk
+ TVArray{} -> err stk
+ TVFloat {} -> err stk
- TVStream ety ->
- return $ VStream (IndexSeqMap $ \_ -> errorV sym ety msg)
+ -- sequences
+ TVSeq w ety
+ | isTBit ety -> return $ VWord w $ return $ LargeBitsVal w $ IndexSeqMap $ \_ -> err stk
+ | otherwise -> return $ VSeq w $ IndexSeqMap $ \_ -> loop stk ety
- -- functions
- TVFun _ bty ->
- return $ lam (\ _ -> errorV sym bty msg)
+ TVStream ety -> return $ VStream $ IndexSeqMap $ \_ -> loop stk ety
- -- tuples
- TVTuple tys ->
- return $ VTuple (map (\t -> errorV sym t msg) tys)
+ -- functions
+ TVFun _ bty -> lam sym (\ _ -> loop stk bty)
- -- records
- TVRec fields ->
- return $ VRecord $ fmap (\t -> errorV sym t msg) $ fields
+ -- tuples
+ TVTuple tys -> return $ VTuple (map (\t -> loop stk t) tys)
- TVAbstract {} -> cryUserError sym msg
+ -- records
+ TVRec fields -> return $ VRecord $ fmap (\t -> loop stk t) $ fields
+ TVAbstract {} -> err stk
+ TVNewtype {} -> err stk
{-# INLINE valueToChar #-}
@@ -1862,7 +1934,7 @@
mergeWord sym c (WordVal w1) (WordVal w2) =
WordVal <$> iteWord sym c w1 w2
mergeWord sym c w1 w2 =
- LargeBitsVal (wordValueSize sym w1) <$> memoMap (mergeSeqMap sym c (asBitsMap sym w1) (asBitsMap sym w2))
+ LargeBitsVal (wordValueSize sym w1) <$> memoMap sym (mergeSeqMap sym c (asBitsMap sym w1) (asBitsMap sym w2))
{-# INLINE mergeWord' #-}
mergeWord' :: Backend sym =>
@@ -1900,11 +1972,12 @@
(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 (mergeSeqMap sym c vs1 vs2)
- (VStream vs1 , VStream vs2 ) -> VStream <$> memoMap (mergeSeqMap sym c vs1 vs2)
- (VFun f1 , VFun f2 ) -> pure $ VFun $ \x -> mergeValue' sym c (f1 x) (f2 x)
- (VPoly f1 , VPoly f2 ) -> pure $ VPoly $ \x -> mergeValue' sym c (f1 x) (f2 x)
+ (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" ]
@@ -1921,53 +1994,55 @@
-foldlV :: Backend sym => sym -> GenValue sym
+foldlV :: Backend sym => sym -> Prim sym
foldlV sym =
- ilam $ \_n ->
- tlam $ \_a ->
- tlam $ \_b ->
- lam $ \f -> pure $
- lam $ \z -> pure $
- lam $ \v ->
- v >>= \case
+ PNumPoly \_n ->
+ PTyPoly \_a ->
+ PTyPoly \_b ->
+ PFun \f ->
+ PFun \z ->
+ PStrict \v ->
+ 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)
_ -> panic "Cryptol.Eval.Generic.foldlV" ["Expected finite sequence"]
where
go0 _f a [] = a
go0 f a bs =
- do f' <- fromVFun <$> f
+ do f' <- fromVFun sym <$> f
go1 f' a bs
go1 _f a [] = a
go1 f a (b:bs) =
- do f' <- fromVFun <$> (f a)
+ do f' <- fromVFun sym <$> (f a)
go1 f (f' b) bs
-foldl'V :: Backend sym => sym -> GenValue sym
+foldl'V :: Backend sym => sym -> Prim sym
foldl'V sym =
- ilam $ \_n ->
- tlam $ \_a ->
- tlam $ \_b ->
- lam $ \f -> pure $
- lam $ \z -> pure $
- lam $ \v ->
- v >>= \case
+ PNumPoly \_n ->
+ PTyPoly \_a ->
+ PTyPoly \_b ->
+ PFun \f ->
+ PFun \z ->
+ PStrict \v ->
+ 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)
_ -> panic "Cryptol.Eval.Generic.foldlV" ["Expected finite sequence"]
where
go0 _f a [] = a
go0 f a bs =
- do f' <- fromVFun <$> f
- a' <- sDelay sym Nothing a
+ do f' <- fromVFun sym <$> f
+ a' <- sDelay sym a
forceValue =<< a'
go1 f' a' bs
go1 _f a [] = a
go1 f a (b:bs) =
- do f' <- fromVFun <$> (f a)
- a' <- sDelay sym Nothing (f' b)
+ do f' <- fromVFun sym <$> (f a)
+ a' <- sDelay sym (f' b)
forceValue =<< a'
go1 f a' bs
@@ -1994,14 +2069,15 @@
--------------------------------------------------------------------------------
-- Experimental parallel primitives
-parmapV :: Backend sym => sym -> GenValue sym
+parmapV :: Backend sym => sym -> Prim sym
parmapV sym =
- tlam $ \_a ->
- tlam $ \_b ->
- ilam $ \_n ->
- lam $ \f -> pure $
- lam $ \xs ->
- do f' <- fromVFun <$> f
+ PTyPoly \_a ->
+ PTyPoly \_b ->
+ PFinPoly \_n ->
+ PFun \f ->
+ PFun \xs ->
+ PPrim
+ do f' <- fromVFun sym <$> f
xs' <- xs
case xs' of
VWord n w ->
@@ -2022,25 +2098,35 @@
SeqMap sym ->
SEval sym (SeqMap sym)
sparkParMap sym f n m =
- finiteSeqMap sym <$> mapM (sSpark sym . g) (enumerateSeqMap n m)
+ finiteSeqMap <$> mapM (sSpark sym . g) (enumerateSeqMap n m)
where
g x =
- do z <- sDelay sym Nothing (f x)
+ do z <- sDelay sym (f x)
forceValue =<< z
z
--------------------------------------------------------------------------------
-- Floating Point Operations
+-- | A helper for definitng floating point constants.
+fpConst ::
+ Backend sym =>
+ (Integer -> Integer -> SEval sym (SFloat sym)) ->
+ Prim sym
+fpConst mk =
+ PFinPoly \e ->
+ PNumPoly \ ~(Nat p) ->
+ PPrim (VFloat <$> mk e p)
+
-- | Make a Cryptol value for a binary arithmetic function.
-fpBinArithV :: Backend sym => sym -> FPArith2 sym -> GenValue sym
+fpBinArithV :: Backend sym => sym -> FPArith2 sym -> Prim sym
fpBinArithV sym fun =
- ilam \_ ->
- ilam \_ ->
- wlam sym \r ->
- pure $ flam \x ->
- pure $ flam \y ->
- VFloat <$> fun sym r x y
+ PFinPoly \_e ->
+ PFinPoly \_p ->
+ PWordFun \r ->
+ PFloatFun \x ->
+ PFloatFun \y ->
+ PPrim (VFloat <$> fun sym r x y)
-- | Rounding mode used in FP operations that do not specify it explicitly.
fpRndMode, fpRndRNE, fpRndRNA, fpRndRTP, fpRndRTN, fpRndRTZ ::
@@ -2051,3 +2137,266 @@
fpRndRTP sym = wordLit sym 3 2 {- to +inf -}
fpRndRTN sym = wordLit sym 3 3 {- to -inf -}
fpRndRTZ sym = wordLit sym 3 4 {- to 0 -}
+
+
+{-# SPECIALIZE genericFloatTable :: Concrete -> Map PrimIdent (Prim Concrete) #-}
+
+genericFloatTable :: Backend sym => sym -> Map PrimIdent (Prim sym)
+genericFloatTable sym =
+ let (~>) = (,) in
+ Map.fromList $ map (\(n, v) -> (floatPrim n, v))
+ [ "fpNaN" ~> fpConst (fpNaN sym)
+ , "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
+ , "=.=" ~> PFinPoly \_ -> PFinPoly \_ -> PFloatFun \x -> PFloatFun \y ->
+ PPrim (VBit <$> fpLogicalEq sym x y)
+
+ , "fpIsNaN" ~> PFinPoly \_ -> PFinPoly \_ -> PFloatFun \x ->
+ PPrim (VBit <$> fpIsNaN sym x)
+ , "fpIsInf" ~> PFinPoly \_ -> PFinPoly \_ -> PFloatFun \x ->
+ PPrim (VBit <$> fpIsInf sym x)
+ , "fpIsZero" ~> PFinPoly \_ -> PFinPoly \_ -> PFloatFun \x ->
+ PPrim (VBit <$> fpIsZero sym x)
+ , "fpIsNeg" ~> PFinPoly \_ -> PFinPoly \_ -> PFloatFun \x ->
+ PPrim (VBit <$> fpIsNeg sym x)
+ , "fpIsNormal" ~> PFinPoly \_ -> PFinPoly \_ -> PFloatFun \x ->
+ PPrim (VBit <$> fpIsNorm sym x)
+ , "fpIsSubnormal" ~> PFinPoly \_ -> PFinPoly \_ -> PFloatFun \x ->
+ PPrim (VBit <$> fpIsSubnorm sym x)
+
+ , "fpAdd" ~> fpBinArithV sym fpPlus
+ , "fpSub" ~> fpBinArithV sym fpMinus
+ , "fpMul" ~> fpBinArithV sym fpMult
+ , "fpDiv" ~> fpBinArithV sym fpDiv
+ , "fpFMA" ~> PFinPoly \_ -> PFinPoly \_ -> PWordFun \r ->
+ PFloatFun \x -> PFloatFun \y -> PFloatFun \z ->
+ PPrim (VFloat <$> fpFMA sym r x y z)
+
+ , "fpAbs" ~> PFinPoly \_ -> PFinPoly \_ ->
+ PFloatFun \x ->
+ PPrim (VFloat <$> fpAbs sym x)
+
+ , "fpSqrt" ~> PFinPoly \_ -> PFinPoly \_ ->
+ PWordFun \r -> PFloatFun \x ->
+ PPrim (VFloat <$> fpSqrt sym r x)
+
+ , "fpToRational" ~>
+ PFinPoly \_e -> PFinPoly \_p -> PFloatFun \x ->
+ PPrim (VRational <$> fpToRational sym x)
+
+ , "fpFromRational" ~>
+ PFinPoly \e -> PFinPoly \p -> PWordFun \r -> PFun \x ->
+ PPrim
+ do rat <- fromVRational <$> x
+ VFloat <$> fpFromRational sym e p r rat
+
+ ]
+
+
+{-# SPECIALIZE genericPrimTable :: Concrete -> IO EvalOpts -> Map PrimIdent (Prim Concrete) #-}
+
+genericPrimTable :: Backend sym => sym -> IO EvalOpts -> Map PrimIdent (Prim sym)
+genericPrimTable sym getEOpts =
+ Map.fromList $ map (\(n, v) -> (prelPrim n, v))
+
+ [ -- Literals
+ ("True" , PVal $ VBit (bitLit sym True))
+ , ("False" , PVal $ VBit (bitLit sym False))
+ , ("number" , {-# SCC "Prelude::number" #-}
+ ecNumberV sym)
+ , ("ratio" , {-# SCC "Prelude::ratio" #-}
+ ratioV sym)
+ , ("fraction" , ecFractionV sym)
+
+ -- Zero
+ , ("zero" , {-# SCC "Prelude::zero" #-}
+ PTyPoly \ty ->
+ PPrim (zeroV sym ty))
+
+ -- Logic
+ , ("&&" , {-# SCC "Prelude::(&&)" #-}
+ binary (andV sym))
+ , ("||" , {-# SCC "Prelude::(||)" #-}
+ binary (orV sym))
+ , ("^" , {-# SCC "Prelude::(^)" #-}
+ binary (xorV sym))
+ , ("complement" , {-# SCC "Prelude::complement" #-}
+ unary (complementV sym))
+
+ -- Ring
+ , ("fromInteger", {-# SCC "Prelude::fromInteger" #-}
+ fromIntegerV sym)
+ , ("+" , {-# SCC "Prelude::(+)" #-}
+ binary (addV sym))
+ , ("-" , {-# SCC "Prelude::(-)" #-}
+ binary (subV sym))
+ , ("*" , {-# SCC "Prelude::(*)" #-}
+ binary (mulV sym))
+ , ("negate" , {-# SCC "Prelude::negate" #-}
+ unary (negateV sym))
+
+ -- Integral
+ , ("toInteger" , {-# SCC "Prelude::toInteger" #-}
+ toIntegerV sym)
+ , ("/" , {-# SCC "Prelude::(/)" #-}
+ binary (divV sym))
+ , ("%" , {-# SCC "Prelude::(%)" #-}
+ binary (modV sym))
+ , ("^^" , {-# SCC "Prelude::(^^)" #-}
+ expV sym)
+ , ("infFrom" , {-# SCC "Prelude::infFrom" #-}
+ infFromV sym)
+ , ("infFromThen", {-# SCC "Prelude::infFromThen" #-}
+ infFromThenV sym)
+
+ -- Field
+ , ("recip" , {-# SCC "Prelude::recip" #-}
+ recipV sym)
+ , ("/." , {-# SCC "Prelude::(/.)" #-}
+ fieldDivideV sym)
+
+ -- Round
+ , ("floor" , {-# SCC "Prelude::floor" #-}
+ unary (floorV sym))
+ , ("ceiling" , {-# SCC "Prelude::ceiling" #-}
+ unary (ceilingV sym))
+ , ("trunc" , {-# SCC "Prelude::trunc" #-}
+ unary (truncV sym))
+ , ("roundAway" , {-# SCC "Prelude::roundAway" #-}
+ unary (roundAwayV sym))
+ , ("roundToEven", {-# SCC "Prelude::roundToEven" #-}
+ unary (roundToEvenV sym))
+
+ -- Bitvector specific operations
+ , ("/$" , {-# SCC "Prelude::(/$)" #-}
+ sdivV sym)
+ , ("%$" , {-# SCC "Prelude::(%$)" #-}
+ smodV sym)
+ , ("lg2" , {-# SCC "Prelude::lg2" #-}
+ lg2V sym)
+
+ -- Cmp
+ , ("<" , {-# SCC "Prelude::(<)" #-}
+ binary (lessThanV sym))
+ , (">" , {-# SCC "Prelude::(>)" #-}
+ binary (greaterThanV sym))
+ , ("<=" , {-# SCC "Prelude::(<=)" #-}
+ binary (lessThanEqV sym))
+ , (">=" , {-# SCC "Prelude::(>=)" #-}
+ binary (greaterThanEqV sym))
+ , ("==" , {-# SCC "Prelude::(==)" #-}
+ binary (eqV sym))
+ , ("!=" , {-# SCC "Prelude::(!=)" #-}
+ binary (distinctV sym))
+
+ -- SignedCmp
+ , ("<$" , {-# SCC "Prelude::(<$)" #-}
+ binary (signedLessThanV sym))
+
+ -- Finite enumerations
+ , ("fromTo" , {-# SCC "Prelude::fromTo" #-}
+ fromToV sym)
+
+ , ("fromThenTo" , {-# SCC "Prelude::fromThenTo" #-}
+ fromThenToV sym)
+
+ , ("fromToLessThan"
+ , {-# SCC "Prelude::fromToLessThan" #-}
+ fromToLessThanV sym)
+
+ -- Sequence manipulations
+ , ("#" , {-# SCC "Prelude::(#)" #-}
+ PFinPoly \front ->
+ PNumPoly \back ->
+ PTyPoly \elty ->
+ PFun \l ->
+ PFun \r ->
+ PPrim (join (ccatV sym (Nat front) back elty <$> l <*> r)))
+
+ , ("join" , {-# SCC "Prelude::join" #-}
+ PNumPoly \parts ->
+ PFinPoly \each ->
+ PTyPoly \a ->
+ PStrict \x ->
+ PPrim $ joinV sym parts each a x)
+
+ , ("split" , {-# SCC "Prelude::split" #-}
+ ecSplitV sym)
+
+ , ("splitAt" , {-# SCC "Prelude::splitAt" #-}
+ PNumPoly \front ->
+ PNumPoly \back ->
+ PTyPoly \a ->
+ PStrict \x ->
+ PPrim $ splitAtV sym front back a x)
+
+ , ("reverse" , {-# SCC "Prelude::reverse" #-}
+ PFinPoly \_a ->
+ PTyPoly \_b ->
+ PStrict \xs ->
+ PPrim $ reverseV sym xs)
+
+ , ("transpose" , {-# SCC "Prelude::transpose" #-}
+ PNumPoly \a ->
+ PNumPoly \b ->
+ PTyPoly \c ->
+ PStrict \xs ->
+ PPrim $ transposeV sym a b c xs)
+
+ -- Misc
+
+ -- {at,len} (fin len) => [len][8] -> at
+ , ("error" , {-# SCC "Prelude::error" #-}
+ PTyPoly \a ->
+ PFinPoly \_ ->
+ PStrict \s ->
+ PPrim (errorV sym a =<< valueToString sym s))
+
+ , ("trace" , {-# SCC "Prelude::trace" #-}
+ PNumPoly \_n ->
+ PTyPoly \_a ->
+ PTyPoly \_b ->
+ PFun \s ->
+ PFun \x ->
+ PFun \y ->
+ PPrim
+ do msg <- valueToString sym =<< s
+ EvalOpts { evalPPOpts, evalLogger } <- liftIO getEOpts
+ doc <- ppValue sym evalPPOpts =<< x
+ liftIO $ logPrint evalLogger
+ $ if null msg then doc else text msg <+> doc
+ y)
+
+ , ("random" , {-# SCC "Prelude::random" #-}
+ PTyPoly \a ->
+ PWordFun \x ->
+ PPrim
+ case wordAsLit sym x of
+ Just (_,i) -> randomV sym a i
+ Nothing -> liftIO (X.throw (UnsupportedSymbolicOp "random")))
+
+ , ("foldl" , {-# SCC "Prelude::foldl" #-}
+ foldlV sym)
+
+ , ("foldl'" , {-# SCC "Prelude::foldl'" #-}
+ foldl'V sym)
+
+ , ("deepseq" , {-# SCC "Prelude::deepseq" #-}
+ PTyPoly \_a ->
+ PTyPoly \_b ->
+ PFun \x ->
+ PFun \y ->
+ PPrim do _ <- forceValue =<< x
+ y)
+
+ , ("parmap" , {-# SCC "Prelude::parmap" #-}
+ parmapV sym)
+
+ , ("fromZ" , {-# SCC "Prelude::fromZ" #-}
+ fromZV sym)
+
+ ]
diff --git a/src/Cryptol/Eval/Prims.hs b/src/Cryptol/Eval/Prims.hs
new file mode 100644
--- /dev/null
+++ b/src/Cryptol/Eval/Prims.hs
@@ -0,0 +1,39 @@
+{-# LANGUAGE ImplicitParams #-}
+{-# LANGUAGE LambdaCase #-}
+module Cryptol.Eval.Prims where
+
+import Cryptol.Backend
+import Cryptol.Eval.Type
+import Cryptol.Eval.Value
+import Cryptol.ModuleSystem.Name
+import Cryptol.TypeCheck.Solver.InfNat(Nat'(..))
+import Cryptol.Utils.Panic
+
+-- | This type provides a lightweight syntactic framework for defining
+-- Cryptol primitives. The main purpose of this type is to provide
+-- an abstraction barrier that insulates the definitions of primitives
+-- from possible changes in the representation of values.
+data Prim sym
+ = PFun (SEval sym (GenValue sym) -> Prim sym)
+ | PStrict (GenValue sym -> Prim sym)
+ | PWordFun (SWord sym -> Prim sym)
+ | PFloatFun (SFloat sym -> Prim sym)
+ | PTyPoly (TValue -> Prim sym)
+ | PNumPoly (Nat' -> Prim sym)
+ | PFinPoly (Integer -> Prim sym)
+ | PPrim (SEval sym (GenValue sym))
+ | PVal (GenValue sym)
+
+-- | Evaluate a primitive into a value computation
+evalPrim :: Backend sym => sym -> Name -> Prim sym -> SEval sym (GenValue sym)
+evalPrim sym nm p = case p of
+ PFun f -> lam sym (evalPrim sym nm . f)
+ PStrict f -> lam sym (\x -> evalPrim sym nm . f =<< x)
+ PWordFun f -> lam sym (\x -> evalPrim sym nm . f =<< (fromVWord sym (show nm) =<< x))
+ PFloatFun f -> flam sym (evalPrim sym nm . f)
+ PTyPoly f -> tlam sym (evalPrim sym nm . f)
+ PNumPoly f -> nlam sym (evalPrim sym nm . f)
+ PFinPoly f -> nlam sym (\case Inf -> panic "PFin" ["Unexpected `inf`", show nm];
+ Nat n -> evalPrim sym nm (f n))
+ PPrim m -> m
+ PVal v -> pure v
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
@@ -28,7 +28,6 @@
> import Data.Ord (comparing)
> import Data.Map (Map)
> import qualified Data.Map as Map
-> import qualified Data.IntMap as IntMap
> import qualified Data.Text as T (pack)
> import LibBF (BigFloat)
> import qualified LibBF as FP
@@ -39,8 +38,9 @@
> import Cryptol.TypeCheck.AST
> import Cryptol.Backend.FloatHelpers (BF(..))
> import qualified Cryptol.Backend.FloatHelpers as FP
-> import Cryptol.Backend.Monad (EvalError(..), PPOpts(..))
-> import Cryptol.Eval.Type (TValue(..), isTBit, evalValType, evalNumType, TypeEnv)
+> import Cryptol.Backend.Monad (EvalError(..))
+> import Cryptol.Eval.Type
+> (TValue(..), isTBit, evalValType, evalNumType, TypeEnv, bindTypeVar)
> import Cryptol.Eval.Concrete (mkBv, ppBV, lg2)
> import Cryptol.Utils.Ident (Ident,PrimIdent, prelPrim, floatPrim)
> import Cryptol.Utils.Panic (panic)
@@ -48,7 +48,7 @@
> import Cryptol.Utils.RecordMap
>
> import qualified Cryptol.ModuleSystem as M
-> import qualified Cryptol.ModuleSystem.Env as M (loadedModules)
+> import qualified Cryptol.ModuleSystem.Env as M (loadedModules,loadedNewtypes)
Overview
========
@@ -250,14 +250,14 @@
>
> instance Semigroup Env where
> l <> r = Env
-> { envVars = Map.union (envVars l) (envVars r)
-> , envTypes = IntMap.union (envTypes l) (envTypes r)
+> { envVars = envVars l <> envVars r
+> , envTypes = envTypes l <> envTypes r
> }
>
> instance Monoid Env where
> mempty = Env
-> { envVars = Map.empty
-> , envTypes = IntMap.empty
+> { envVars = mempty
+> , envTypes = mempty
> }
> mappend l r = l <> r
>
@@ -267,7 +267,7 @@
>
> -- | Bind a type variable of kind # or *.
> bindType :: TVar -> Either Nat' TValue -> Env -> Env
-> bindType p ty env = env { envTypes = IntMap.insert (tvUnique p) ty (envTypes env) }
+> bindType p ty env = env { envTypes = bindTypeVar p ty (envTypes env) }
Evaluation
@@ -284,6 +284,8 @@
> evalExpr env expr =
> case expr of
>
+> ELocated _ e -> evalExpr env e
+>
> EList es _ty ->
> pure $ VList (Nat (genericLength es)) [ evalExpr env e | e <- es ]
>
@@ -340,13 +342,15 @@
---------
Apply the the given selector form to the given value.
+Note that record selectors work uniformly on both record
+types and on newtypes.
> evalSel :: Selector -> Value -> E Value
> evalSel sel val =
> case sel of
> TupleSel n _ -> tupleSel n val
> RecordSel n _ -> recordSel n val
-> ListSel n _ -> listSel n val
+> ListSel n _ -> listSel n val
> where
> tupleSel n v =
> case v of
@@ -366,12 +370,15 @@
Update the given value using the given selector and new value.
+Note that record selectors work uniformly on both record
+types and on newtypes.
> evalSet :: TValue -> E Value -> Selector -> E Value -> E Value
> evalSet tyv val sel fval =
> case (tyv, sel) of
> (TVTuple ts, TupleSel n _) -> updTupleAt ts n
> (TVRec fs, RecordSel n _) -> updRecAt fs n
+> (TVNewtype _ _ fs, RecordSel n _) -> updRecAt fs n
> (TVSeq len _, ListSel n _) -> updSeqAt len n
> (_, _) -> evalPanic "evalSet" ["type/selector mismatch", show tyv, show sel]
> where
@@ -463,7 +470,8 @@
> -> Expr -- ^ Head expression of the comprehension
> -> [[Match]] -- ^ List of parallel comprehension branches
> -> E Value
-> evalComp env expr branches = pure $ VList len [ evalExpr e expr | e <- envs ]
+> evalComp env expr branches =
+> pure $ VList len [ evalExpr e expr | e <- envs ]
> where
> -- Generate a new environment for each iteration of each
> -- parallel branch.
@@ -504,8 +512,27 @@
> case dDefinition d of
> DPrim -> (dName d, pure (evalPrim (dName d)))
> DExpr e -> (dName d, evalExpr env e)
+>
+Newtypes
+--------
+At runtime, newtypes values are represented in exactly
+the same way as records. The constructor function for
+newtypes is thus basically just an identity function
+that consumes and ignores its type arguments.
+
+> evalNewtypeDecl :: Env -> Newtype -> Env
+> evalNewtypeDecl env nt = bindVar (ntName nt, pure val) env
+> where
+> val = foldr tabs con (ntParams nt)
+> con = VFun (\x -> x)
+> tabs tp body =
+> case tpKind tp of
+> KType -> VPoly (\_ -> pure body)
+> KNum -> VNumPoly (\_ -> pure body)
+> k -> evalPanic "evalNewtypeDecl" ["illegal newtype parameter kind", show k]
+
Primitives
==========
@@ -909,7 +936,7 @@
> | (f, fty) <- canonicalFields fields ]
> zero (TVFun _ bty) = VFun (\_ -> pure (zero bty))
> zero (TVAbstract{}) = evalPanic "zero" ["Abstract type not in `Zero`"]
-
+> zero (TVNewtype{}) = evalPanic "zero" ["Newtype not in `Zero`"]
Literals
--------
@@ -978,6 +1005,7 @@
> TVRational -> evalPanic "logicUnary" ["Rational not in class Logic"]
> TVFloat{} -> evalPanic "logicUnary" ["Float not in class Logic"]
> TVAbstract{} -> evalPanic "logicUnary" ["Abstract type not in `Logic`"]
+> TVNewtype{} -> evalPanic "logicUnary" ["Newtype not in `Logic`"]
> logicBinary :: (Bool -> Bool -> Bool) -> TValue -> E Value -> E Value -> E Value
> logicBinary op = go
@@ -1016,6 +1044,7 @@
> TVRational -> evalPanic "logicBinary" ["Rational not in class Logic"]
> TVFloat{} -> evalPanic "logicBinary" ["Float not in class Logic"]
> TVAbstract{} -> evalPanic "logicBinary" ["Abstract type not in `Logic`"]
+> TVNewtype{} -> evalPanic "logicBinary" ["Newtype not in `Logic`"]
Ring Arithmetic
@@ -1063,6 +1092,8 @@
> pure $ VRecord [ (f, go fty) | (f, fty) <- canonicalFields fs ]
> TVAbstract {} ->
> evalPanic "arithNullary" ["Abstract type not in `Ring`"]
+> TVNewtype {} ->
+> evalPanic "arithNullary" ["Newtype type not in `Ring`"]
> ringUnary ::
> (Integer -> E Integer) ->
@@ -1101,6 +1132,8 @@
> | (f, fty) <- canonicalFields fs ]
> TVAbstract {} ->
> evalPanic "arithUnary" ["Abstract type not in `Ring`"]
+> TVNewtype {} ->
+> evalPanic "arithUnary" ["Newtype not in `Ring`"]
> ringBinary ::
> (Integer -> Integer -> E Integer) ->
@@ -1149,6 +1182,8 @@
> | (f, fty) <- canonicalFields fs ]
> TVAbstract {} ->
> evalPanic "arithBinary" ["Abstract type not in class `Ring`"]
+> TVNewtype {} ->
+> evalPanic "arithBinary" ["Newtype not in class `Ring`"]
Integral
@@ -1325,6 +1360,8 @@
> lexList (zipWith3 lexCompare tys ls rs)
> TVAbstract {} ->
> evalPanic "lexCompare" ["Abstract type not in `Cmp`"]
+> TVNewtype {} ->
+> evalPanic "lexCompare" ["Newtype not in `Cmp`"]
>
> lexList :: [E Ordering] -> E Ordering
> lexList [] = pure EQ
@@ -1379,6 +1416,8 @@
> lexList (zipWith3 lexSignedCompare tys ls rs)
> TVAbstract {} ->
> evalPanic "lexSignedCompare" ["Abstract type not in `Cmp`"]
+> TVNewtype {} ->
+> evalPanic "lexSignedCompare" ["Newtype type not in `Cmp`"]
Sequences
@@ -1690,7 +1729,10 @@
running the reference evaluator on an expression.
> evaluate :: Expr -> M.ModuleCmd (E Value)
-> evaluate expr (_, _, modEnv) = return (Right (evalExpr env expr, modEnv), [])
+> evaluate expr minp = return (Right (val, modEnv), [])
> where
+> modEnv = M.minpModuleEnv minp
> extDgs = concatMap mDecls (M.loadedModules modEnv)
-> env = foldl evalDeclGroup mempty extDgs
+> 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
@@ -6,6 +6,7 @@
-- Stability : provisional
-- Portability : portable
+{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
@@ -21,7 +22,6 @@
) where
import qualified Control.Exception as X
-import Control.Monad (join)
import Control.Monad.IO.Class (MonadIO(..))
import Data.Bits (bit, shiftL)
import qualified Data.Map as Map
@@ -33,8 +33,9 @@
import Cryptol.Backend.Monad ( EvalError(..), Unsupported(..) )
import Cryptol.Backend.SBV
-import Cryptol.Eval.Type (TValue(..), finNat')
+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.Utils.Ident
@@ -46,106 +47,12 @@
-- Primitives ------------------------------------------------------------------
-- See also Cryptol.Eval.Concrete.primTable
-primTable :: SBV -> Map.Map PrimIdent Value
-primTable sym =
+primTable :: SBV -> IO EvalOpts -> Map.Map PrimIdent (Prim SBV)
+primTable sym getEOpts =
+ Map.union (genericPrimTable sym getEOpts) $
Map.fromList $ map (\(n, v) -> (prelPrim (T.pack n), v))
- [ -- Literals
- ("True" , VBit (bitLit sym True))
- , ("False" , VBit (bitLit sym False))
- , ("number" , ecNumberV sym) -- Converts a numeric type into its corresponding value.
- -- { val, rep } (Literal val rep) => rep
- , ("fraction" , ecFractionV sym)
- , ("ratio" , ratioV sym)
-
- -- Zero
- , ("zero" , VPoly (zeroV sym))
-
- -- Logic
- , ("&&" , binary (andV sym))
- , ("||" , binary (orV sym))
- , ("^" , binary (xorV sym))
- , ("complement" , unary (complementV sym))
-
- -- Ring
- , ("fromInteger" , fromIntegerV sym)
- , ("+" , binary (addV sym))
- , ("-" , binary (subV sym))
- , ("negate" , unary (negateV sym))
- , ("*" , binary (mulV sym))
-
- -- Integral
- , ("toInteger" , toIntegerV sym)
- , ("/" , binary (divV sym))
- , ("%" , binary (modV sym))
- , ("^^" , expV sym)
- , ("infFrom" , infFromV sym)
- , ("infFromThen" , infFromThenV sym)
-
- -- Field
- , ("recip" , recipV sym)
- , ("/." , fieldDivideV sym)
-
- -- Round
- , ("floor" , unary (floorV sym))
- , ("ceiling" , unary (ceilingV sym))
- , ("trunc" , unary (truncV sym))
- , ("roundAway" , unary (roundAwayV sym))
- , ("roundToEven" , unary (roundToEvenV sym))
-
- -- Word operations
- , ("/$" , sdivV sym)
- , ("%$" , smodV sym)
- , ("lg2" , lg2V sym)
- , (">>$" , sshrV sym)
-
- -- Cmp
- , ("<" , binary (lessThanV sym))
- , (">" , binary (greaterThanV sym))
- , ("<=" , binary (lessThanEqV sym))
- , (">=" , binary (greaterThanEqV sym))
- , ("==" , binary (eqV sym))
- , ("!=" , binary (distinctV sym))
-
- -- SignedCmp
- , ("<$" , binary (signedLessThanV sym))
-
- -- Finite enumerations
- , ("fromTo" , fromToV sym)
- , ("fromThenTo" , fromThenToV sym)
-
- -- Sequence manipulations
- , ("#" , -- {a,b,d} (fin a) => [a] d -> [b] d -> [a + b] d
- nlam $ \ front ->
- nlam $ \ back ->
- tlam $ \ elty ->
- lam $ \ l -> return $
- lam $ \ r -> join (ccatV sym front back elty <$> l <*> r))
-
- , ("join" ,
- nlam $ \ parts ->
- nlam $ \ (finNat' -> each) ->
- tlam $ \ a ->
- lam $ \ x ->
- joinV sym parts each a =<< x)
-
- , ("split" , ecSplitV sym)
-
- , ("splitAt" ,
- nlam $ \ front ->
- nlam $ \ back ->
- tlam $ \ a ->
- lam $ \ x ->
- splitAtV sym front back a =<< x)
-
- , ("reverse" , nlam $ \_a ->
- tlam $ \_b ->
- lam $ \xs -> reverseV sym =<< xs)
-
- , ("transpose" , nlam $ \a ->
- nlam $ \b ->
- tlam $ \c ->
- lam $ \xs -> transposeV sym a b c =<< xs)
+ [ (">>$" , sshrV sym)
-- Shifts and rotates
, ("<<" , logicShift sym "<<"
@@ -179,52 +86,8 @@
, ("update" , updatePrim sym (updateFrontSym_word sym) (updateFrontSym sym))
, ("updateEnd" , updatePrim sym (updateBackSym_word sym) (updateBackSym sym))
- -- Misc
-
- , ("fromZ" , fromZV sym)
-
- , ("foldl" , foldlV sym)
- , ("foldl'" , foldl'V sym)
-
- , ("deepseq" ,
- tlam $ \_a ->
- tlam $ \_b ->
- lam $ \x -> pure $
- lam $ \y ->
- do _ <- forceValue =<< x
- y)
-
- , ("parmap" , parmapV sym)
-
- -- {at,len} (fin len) => [len][8] -> at
- , ("error" ,
- tlam $ \a ->
- nlam $ \_ ->
- VFun $ \s -> errorV sym a =<< (valueToString sym =<< s))
-
- , ("random" ,
- tlam $ \a ->
- wlam sym $ \x ->
- case integerAsLit sym x of
- Just i -> randomV sym a i
- Nothing -> cryUserError sym "cannot evaluate 'random' with symbolic inputs")
-
- -- The trace function simply forces its first two
- -- values before returing the third in the symbolic
- -- evaluator.
- , ("trace",
- nlam $ \_n ->
- tlam $ \_a ->
- tlam $ \_b ->
- lam $ \s -> return $
- lam $ \x -> return $
- lam $ \y -> do
- _ <- s
- _ <- x
- y)
]
-
indexFront ::
SBV ->
Nat' ->
@@ -468,13 +331,14 @@
go f (WordVal x :vs) = go (f . (x:)) vs
go _f (LargeBitsVal _ _ : _) = Nothing
-sshrV :: SBV -> Value
+sshrV :: SBV -> Prim SBV
sshrV sym =
- nlam $ \n ->
- tlam $ \ix ->
- wlam sym $ \x -> return $
- lam $ \y ->
- y >>= asIndex sym ">>$" ix >>= \case
+ 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)
diff --git a/src/Cryptol/Eval/Type.hs b/src/Cryptol/Eval/Type.hs
--- a/src/Cryptol/Eval/Type.hs
+++ b/src/Cryptol/Eval/Type.hs
@@ -11,7 +11,7 @@
{-# LANGUAGE DeriveGeneric #-}
module Cryptol.Eval.Type where
-import Cryptol.Backend.Monad (evalPanic, typeCannotBeDemoted)
+import Cryptol.Backend.Monad (evalPanic)
import Cryptol.TypeCheck.AST
import Cryptol.TypeCheck.PP(pp)
import Cryptol.TypeCheck.Solver.InfNat
@@ -38,8 +38,11 @@
| TVTuple [TValue] -- ^ @ (a, b, c )@
| TVRec (RecordMap Ident TValue) -- ^ @ { x : a, y : b, z : c } @
| TVFun TValue TValue -- ^ @ a -> b @
+ | TVNewtype Newtype
+ [Either Nat' TValue]
+ (RecordMap Ident TValue) -- ^ a named newtype
| TVAbstract UserTC [Either Nat' TValue] -- ^ an abstract type
- deriving (Generic, NFData)
+ deriving (Generic, NFData, Eq)
-- | Convert a type value back into a regular type
tValTy :: TValue -> Type
@@ -56,13 +59,17 @@
TVTuple ts -> tTuple (map tValTy ts)
TVRec fs -> tRec (fmap tValTy fs)
TVFun t1 t2 -> tFun (tValTy t1) (tValTy t2)
- TVAbstract u vs -> tAbstract u (map arg vs)
- where arg x = case x of
- Left Inf -> tInf
- Left (Nat n) -> tNum n
- Right v -> tValTy v
+ TVNewtype nt vs _ -> tNewtype nt (map tNumValTy vs)
+ TVAbstract u vs -> tAbstract u (map tNumValTy vs)
+tNumTy :: Nat' -> Type
+tNumTy Inf = tInf
+tNumTy (Nat n) = tNum n
+tNumValTy :: Either Nat' TValue -> Type
+tNumValTy = either tNumTy tValTy
+
+
instance Show TValue where
showsPrec p v = showsPrec p (tValTy v)
@@ -90,20 +97,38 @@
-- Type Evaluation -------------------------------------------------------------
-type TypeEnv = IntMap.IntMap (Either Nat' TValue)
+newtype TypeEnv =
+ TypeEnv
+ { envTypeMap :: IntMap.IntMap (Either Nat' TValue) }
+instance Monoid TypeEnv where
+ mempty = TypeEnv mempty
+instance Semigroup TypeEnv where
+ l <> r = TypeEnv
+ { envTypeMap = IntMap.union (envTypeMap l) (envTypeMap r) }
+
+lookupTypeVar :: TVar -> TypeEnv -> Maybe (Either Nat' TValue)
+lookupTypeVar tv env = IntMap.lookup (tvUnique tv) (envTypeMap env)
+
+bindTypeVar :: TVar -> Either Nat' TValue -> TypeEnv -> TypeEnv
+bindTypeVar tv ty env = env{ envTypeMap = IntMap.insert (tvUnique tv) ty (envTypeMap env) }
+
-- | Evaluation for types (kind * or #).
evalType :: TypeEnv -> Type -> Either Nat' TValue
evalType env ty =
case ty of
TVar tv ->
- case IntMap.lookup (tvUnique tv) env of
+ case lookupTypeVar tv env of
Just v -> v
Nothing -> evalPanic "evalType" ["type variable not bound", show tv]
TUser _ _ ty' -> evalType env ty'
TRec fields -> Right $ TVRec (fmap val fields)
+
+ TNewtype nt ts -> Right $ TVNewtype nt tvs $ evalNewtypeBody env nt tvs
+ where tvs = map (evalType env) ts
+
TCon (TC c) ts ->
case (c, ts) of
(TCBit, []) -> Right $ TVBit
@@ -128,7 +153,6 @@
, "*** Name: " ++ show (pp u)
]
- -- FIXME: What about TCNewtype?
_ -> evalPanic "evalType" ["not a value type", show ty]
TCon (TF f) ts -> Left $ evalTF f (map num ts)
TCon (PC p) _ -> evalPanic "evalType" ["invalid predicate symbol", show p]
@@ -142,6 +166,16 @@
Inf -> evalPanic "evalType"
["Expecting a finite size, but got `inf`"]
+-- | Evaluate the body of a newtype, given evaluated arguments
+evalNewtypeBody :: TypeEnv -> Newtype -> [Either Nat' TValue] -> RecordMap Ident TValue
+evalNewtypeBody env0 nt args = fmap (evalValType env') (ntFields nt)
+ where
+ env' = loop env0 (ntParams nt) args
+
+ loop env [] [] = env
+ loop env (p:ps) (a:as) = loop (bindTypeVar (TVBound p) a env) ps as
+ loop _ _ _ = evalPanic "evalNewtype" ["type parameter/argument mismatch"]
+
-- | Evaluation for value types (kind *).
evalValType :: TypeEnv -> Type -> TValue
evalValType env ty =
@@ -175,5 +209,5 @@
| otherwise = evalPanic "evalTF"
["Unexpected type function:", show ty]
- where mb = fromMaybe (typeCannotBeDemoted ty)
+ where mb = fromMaybe (evalPanic "evalTF" ["type cannot be demoted", show (pp ty)])
ty = TCon (TF f) (map tNat' vs)
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
@@ -30,10 +30,11 @@
, forceValue
, Backend(..)
, asciiMode
+
+ , EvalOpts(..)
-- ** Value introduction operations
, word
, lam
- , wlam
, flam
, tlam
, nlam
@@ -95,16 +96,21 @@
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 qualified Cryptol.Backend.Arch as Arch
-import Cryptol.Backend.Monad ( PPOpts(..), evalPanic, wordTooWide, defaultPPOpts, asciiMode )
+import Cryptol.Backend.Monad
+ ( evalPanic, wordTooWide, CallStack, combineCallStacks )
+import Cryptol.Backend.FloatHelpers (fpPP)
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
@@ -113,6 +119,12 @@
import GHC.Generics (Generic)
+-- | Some options for evalutaion
+data EvalOpts = EvalOpts
+ { evalLogger :: Logger -- ^ Where to print stuff (e.g., for @trace@)
+ , evalPPOpts :: PPOpts -- ^ How to pretty print things.
+ }
+
-- Values ----------------------------------------------------------------------
-- | A sequence map represents a mapping from nonnegative integer indices
@@ -135,22 +147,22 @@
largeBitSize = 1 `shiftL` 48
-- | Generate a finite sequence map from a list of values
-finiteSeqMap :: Backend sym => sym -> [SEval sym (GenValue sym)] -> SeqMap sym
-finiteSeqMap sym xs =
+finiteSeqMap :: [SEval sym (GenValue sym)] -> SeqMap sym
+finiteSeqMap xs =
UpdateSeqMap
(Map.fromList (zip [0..] xs))
- (invalidIndex sym)
+ (\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 => [SEval sym (GenValue sym)] -> SEval sym (SeqMap sym)
-infiniteSeqMap xs =
+infiniteSeqMap :: Backend sym => sym -> [SEval sym (GenValue sym)] -> SEval sym (SeqMap sym)
+infiniteSeqMap sym xs =
-- TODO: use an int-trie?
- memoMap (IndexSeqMap $ \i -> genericIndex xs i)
+ 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] ]
+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)]
@@ -191,17 +203,18 @@
-- | Given a sequence map, return a new sequence map that is memoized using
-- a finite map memo table.
-memoMap :: (MonadIO m, Backend sym) => SeqMap sym -> m (SeqMap sym)
-memoMap x = do
+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)
+ return $ IndexSeqMap (memo cache stk)
where
- memo cache i = do
+ memo cache stk i = do
mz <- liftIO (Map.lookup i <$> readIORef cache)
case mz of
Just z -> return z
- Nothing -> doEval cache i
+ Nothing -> sWithCallStack sym stk (doEval cache i)
doEval cache i = do
v <- lookupSeqMap x i
@@ -212,20 +225,22 @@
-- sequence maps.
zipSeqMap ::
Backend sym =>
+ sym ->
(GenValue sym -> GenValue sym -> SEval sym (GenValue sym)) ->
SeqMap sym ->
SeqMap sym ->
SEval sym (SeqMap sym)
-zipSeqMap f x y =
- memoMap (IndexSeqMap $ \i -> join (f <$> lookupSeqMap x i <*> lookupSeqMap y i))
+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 f x =
- memoMap (IndexSeqMap $ \i -> f =<< lookupSeqMap x i)
+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
@@ -280,7 +295,8 @@
-- | 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 :: 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)
@@ -308,9 +324,9 @@
-- Invariant: VSeq is never a sequence of bits
| VWord !Integer !(SEval sym (WordValue sym)) -- ^ @ [n]Bit @
| VStream !(SeqMap sym) -- ^ @ [inf]a @
- | VFun (SEval sym (GenValue sym) -> SEval sym (GenValue sym)) -- ^ functions
- | VPoly (TValue -> SEval sym (GenValue sym)) -- ^ polymorphic values (kind *)
- | VNumPoly (Nat' -> SEval sym (GenValue sym)) -- ^ polymorphic values (kind #)
+ | 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
@@ -331,9 +347,9 @@
VFloat f -> seq f (return ())
VWord _ wv -> forceWordValue =<< wv
VStream _ -> return ()
- VFun _ -> return ()
- VPoly _ -> return ()
- VNumPoly _ -> return ()
+ VFun{} -> return ()
+ VPoly{} -> return ()
+ VNumPoly{} -> return ()
@@ -348,9 +364,9 @@
VSeq n _ -> "seq:" ++ show n
VWord n _ -> "word:" ++ show n
VStream _ -> "stream"
- VFun _ -> "fun"
- VPoly _ -> "poly"
- VNumPoly _ -> "numpoly"
+ VFun{} -> "fun"
+ VPoly{} -> "poly"
+ VNumPoly{} -> "numpoly"
-- Pretty Printing -------------------------------------------------------------
@@ -371,10 +387,10 @@
ppField (f,r) = pp f <+> char '=' <+> r
VTuple vals -> do vals' <- traverse (>>=loop) vals
return $ parens (sep (punctuate comma vals'))
- VBit b -> return $ ppBit x b
- VInteger i -> return $ ppInteger x opts i
- VRational q -> return $ ppRational x opts q
- VFloat i -> return $ ppFloat x opts i
+ 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
VStream vals -> do vals' <- traverse (>>=loop) $ enumerateSeqMap (useInfLength opts) vals
@@ -382,12 +398,12 @@
$ punctuate comma
( vals' ++ [text "..."]
)
- VFun _ -> return $ text ""
- VPoly _ -> return $ text ""
- VNumPoly _ -> return $ text ""
+ VFun{} -> return $ text ""
+ VPoly{} -> return $ text ""
+ VNumPoly{} -> return $ text ""
ppWordVal :: WordValue sym -> SEval sym Doc
- ppWordVal w = ppWord x opts <$> asWordVal x w
+ ppWordVal w = ppSWord x opts =<< asWordVal x w
ppWordSeq :: Integer -> SeqMap sym -> SEval sym Doc
ppWordSeq sz vals = do
@@ -399,11 +415,102 @@
-> do vs <- traverse (fromVWord x "ppWordSeq") ws
case traverse (wordAsChar x) vs of
Just str -> return $ text (show str)
- _ -> return $ brackets (fsep (punctuate comma $ map (ppWord x opts) vs))
+ _ -> do vs' <- mapM (ppSWord x opts) vs
+ return $ brackets (fsep (punctuate comma vs'))
_ -> do ws' <- traverse loop ws
return $ brackets (fsep (punctuate comma ws'))
+ppSBit :: Backend sym => sym -> SBit sym -> SEval sym Doc
+ppSBit sym b =
+ case bitAsLit sym b of
+ Just True -> pure (text "True")
+ Just False -> pure (text "False")
+ Nothing -> pure (text "?")
+ppSInteger :: Backend sym => sym -> SInteger sym -> SEval sym Doc
+ppSInteger sym x =
+ case integerAsLit sym x of
+ Just i -> pure (integer i)
+ Nothing -> pure (text "[?]")
+
+ppSFloat :: Backend sym => sym -> PPOpts -> SFloat sym -> SEval sym Doc
+ppSFloat sym opts x =
+ case fpAsLit sym x of
+ Just fp -> pure (fpPP opts fp)
+ Nothing -> pure (text "[?]")
+
+ppSRational :: Backend sym => sym -> SRational sym -> SEval sym Doc
+ppSRational sym (SRational n d)
+ | Just ni <- integerAsLit sym n
+ , Just di <- integerAsLit sym d
+ = let q = ni % di in
+ pure (text "(ratio" <+> integer (numerator q) <+> (integer (denominator q) <> text ")"))
+
+ | otherwise
+ = do n' <- ppSInteger sym n
+ d' <- ppSInteger sym d
+ pure (text "(ratio" <+> n' <+> (d' <> text ")"))
+
+ppSWord :: Backend sym => sym -> PPOpts -> SWord sym -> SEval sym Doc
+ppSWord sym opts bv
+ | asciiMode opts width =
+ case wordAsLit sym bv of
+ Just (_,i) -> pure (text (show (toEnum (fromInteger i) :: Char)))
+ Nothing -> pure (text "?")
+
+ | otherwise =
+ case wordAsLit sym bv of
+ Just (_,i) ->
+ let val = value i in
+ pure (prefix (length val) <.> text val)
+ Nothing
+ | base == 2 -> sliceDigits 1 "0b"
+ | base == 8 -> sliceDigits 3 "0o"
+ | base == 16 -> sliceDigits 4 "0x"
+ | otherwise -> pure (text "[?]")
+
+ where
+ width = wordLen sym bv
+
+ base = if useBase opts > 36 then 10 else useBase opts
+
+ padding bitsPerDigit len = text (replicate padLen '0')
+ where
+ padLen | m > 0 = d + 1
+ | otherwise = d
+
+ (d,m) = (fromInteger width - (len * bitsPerDigit))
+ `divMod` bitsPerDigit
+
+ prefix len = case base of
+ 2 -> text "0b" <.> padding 1 len
+ 8 -> text "0o" <.> padding 3 len
+ 10 -> empty
+ 16 -> text "0x" <.> padding 4 len
+ _ -> text "0" <.> char '<' <.> int base <.> char '>'
+
+ value i = showIntAtBase (toInteger base) (digits !!) i ""
+ digits = "0123456789abcdefghijklmnopqrstuvwxyz"
+
+ toDigit w =
+ case wordAsLit sym w of
+ Just (_,i) | i <= 36 -> digits !! fromInteger i
+ _ -> '?'
+
+ sliceDigits bits pfx =
+ do ws <- goDigits bits [] bv
+ let ds = map toDigit ws
+ pure (text pfx <.> text ds)
+
+ goDigits bits ds w
+ | wordLen sym w > bits =
+ do (hi,lo) <- splitWord sym (wordLen sym w - bits) bits w
+ goDigits bits (lo:ds) hi
+
+ | wordLen sym w > 0 = pure (w:ds)
+
+ | otherwise = pure ds
+
-- Value Constructors ----------------------------------------------------------
-- | Create a packed word of n bits.
@@ -413,45 +520,41 @@
| otherwise = VWord n (WordVal <$> wordLit sym n i)
-lam :: (SEval sym (GenValue sym) -> SEval sym (GenValue sym)) -> GenValue sym
-lam = VFun
-
--- | Functions that assume word inputs
-wlam :: Backend sym => sym -> (SWord sym -> SEval sym (GenValue sym)) -> GenValue sym
-wlam sym f = VFun (\arg -> arg >>= fromVWord sym "wlam" >>= f)
+-- | Construct a function value
+lam :: Backend sym => sym -> (SEval sym (GenValue sym) -> SEval sym (GenValue sym)) -> SEval sym (GenValue sym)
+lam sym f = VFun <$> sGetCallStack sym <*> pure f
-- | Functions that assume floating point inputs
-flam :: Backend sym =>
- (SFloat sym -> SEval sym (GenValue sym)) -> GenValue sym
-flam f = VFun (\arg -> arg >>= f . fromVFloat)
-
-
+flam :: Backend sym => sym ->
+ (SFloat sym -> SEval sym (GenValue sym)) -> SEval sym (GenValue sym)
+flam sym f = VFun <$> sGetCallStack sym <*> pure (\arg -> arg >>= f . fromVFloat)
-- | A type lambda that expects a 'Type'.
-tlam :: Backend sym => (TValue -> GenValue sym) -> GenValue sym
-tlam f = VPoly (return . f)
+tlam :: Backend sym => sym -> (TValue -> SEval sym (GenValue sym)) -> SEval sym (GenValue sym)
+tlam sym f = VPoly <$> sGetCallStack sym <*> pure f
-- | A type lambda that expects a 'Type' of kind #.
-nlam :: Backend sym => (Nat' -> GenValue sym) -> GenValue sym
-nlam f = VNumPoly (return . f)
+nlam :: Backend sym => sym -> (Nat' -> SEval sym (GenValue sym)) -> SEval sym (GenValue sym)
+nlam sym f = VNumPoly <$> sGetCallStack sym <*> pure f
-- | A type lambda that expects a finite numeric type.
-ilam :: Backend sym => (Integer -> GenValue sym) -> GenValue sym
-ilam f = nlam (\n -> case n of
- Nat i -> f i
- Inf -> panic "ilam" [ "Unexpected `inf`" ])
+ilam :: Backend sym => sym -> (Integer -> SEval sym (GenValue sym)) -> SEval sym (GenValue sym)
+ilam sym f =
+ nlam sym (\n -> case n of
+ Nat i -> f i
+ Inf -> panic "ilam" [ "Unexpected `inf`" ])
-- | Generate a stream.
-toStream :: Backend sym => [GenValue sym] -> SEval sym (GenValue sym)
-toStream vs =
- VStream <$> infiniteSeqMap (map pure vs)
+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 sym (map pure 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.
@@ -460,7 +563,7 @@
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 vals
+ Inf -> toStream sym vals
-- | Construct either a finite sequence, or a stream. In the finite case,
@@ -537,22 +640,25 @@
go _ (_ : _) = Nothing
-- | Extract a function from a value.
-fromVFun :: GenValue sym -> (SEval sym (GenValue sym) -> SEval sym (GenValue sym))
-fromVFun val = case val of
- VFun f -> f
- _ -> evalPanic "fromVFun" ["not a function"]
+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"]
-- | Extract a polymorphic function from a value.
-fromVPoly :: GenValue sym -> (TValue -> SEval sym (GenValue sym))
-fromVPoly val = case val of
- VPoly f -> f
- _ -> evalPanic "fromVPoly" ["not a polymorphic 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"]
-- | Extract a polymorphic function from a value.
-fromVNumPoly :: GenValue sym -> (Nat' -> SEval sym (GenValue sym))
-fromVNumPoly val = case val of
- VNumPoly f -> f
- _ -> evalPanic "fromVNumPoly" ["not a polymorphic 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"]
-- | Extract a tuple from a value.
fromVTuple :: GenValue sym -> [SEval sym (GenValue sym)]
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
@@ -18,22 +18,20 @@
module Cryptol.Eval.What4
( Value
, primTable
- , floatPrims
) where
import qualified Control.Exception as X
import Control.Concurrent.MVar
-import Control.Monad (join,foldM)
+import Control.Monad (foldM)
import Control.Monad.IO.Class
import Data.Bits
import qualified Data.Map as Map
-import Data.Map (Map)
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Parameterized.Context
-import Data.Parameterized.Some
import Data.Parameterized.TraversableFC
+import Data.Parameterized.Some
import qualified Data.BitVector.Sized as BV
import qualified What4.Interface as W4
@@ -43,10 +41,10 @@
import Cryptol.Backend
import Cryptol.Backend.Monad ( EvalError(..), Unsupported(..) )
import Cryptol.Backend.What4
-import qualified Cryptol.Backend.What4.SFloat as W4
import Cryptol.Eval.Generic
-import Cryptol.Eval.Type (finNat', TValue(..))
+import Cryptol.Eval.Prims
+import Cryptol.Eval.Type (TValue(..))
import Cryptol.Eval.Value
import qualified Cryptol.SHA as SHA
@@ -60,111 +58,17 @@
type Value sym = GenValue (What4 sym)
-- See also Cryptol.Prims.Eval.primTable
-primTable :: W4.IsSymExprBuilder sym => What4 sym -> Map.Map PrimIdent (Value sym)
-primTable sym =
+primTable :: W4.IsSymExprBuilder sym => What4 sym -> IO EvalOpts -> Map.Map PrimIdent (Prim (What4 sym))
+primTable sym getEOpts =
let w4sym = w4 sym in
- Map.union (floatPrims sym) $
Map.union (suiteBPrims sym) $
Map.union (primeECPrims sym) $
+ Map.union (genericFloatTable sym) $
+ Map.union (genericPrimTable sym getEOpts) $
Map.fromList $ map (\(n, v) -> (prelPrim n, v))
- [ -- Literals
- ("True" , VBit (bitLit sym True))
- , ("False" , VBit (bitLit sym False))
- , ("number" , ecNumberV sym) -- Converts a numeric type into its corresponding value.
- -- { val, rep } (Literal val rep) => rep
- , ("fraction" , ecFractionV sym)
- , ("ratio" , ratioV sym)
-
- -- Zero
- , ("zero" , VPoly (zeroV sym))
-
- -- Logic
- , ("&&" , binary (andV sym))
- , ("||" , binary (orV sym))
- , ("^" , binary (xorV sym))
- , ("complement" , unary (complementV sym))
-
- -- Ring
- , ("fromInteger" , fromIntegerV sym)
- , ("+" , binary (addV sym))
- , ("-" , binary (subV sym))
- , ("negate" , unary (negateV sym))
- , ("*" , binary (mulV sym))
-
- -- Integral
- , ("toInteger" , toIntegerV sym)
- , ("/" , binary (divV sym))
- , ("%" , binary (modV sym))
- , ("^^" , expV sym)
- , ("infFrom" , infFromV sym)
- , ("infFromThen" , infFromThenV sym)
-
- -- Field
- , ("recip" , recipV sym)
- , ("/." , fieldDivideV sym)
-
- -- Round
- , ("floor" , unary (floorV sym))
- , ("ceiling" , unary (ceilingV sym))
- , ("trunc" , unary (truncV sym))
- , ("roundAway" , unary (roundAwayV sym))
- , ("roundToEven" , unary (roundToEvenV sym))
-
- -- Word operations
- , ("/$" , sdivV sym)
- , ("%$" , smodV sym)
- , ("lg2" , lg2V sym)
- , (">>$" , sshrV sym)
-
- -- Cmp
- , ("<" , binary (lessThanV sym))
- , (">" , binary (greaterThanV sym))
- , ("<=" , binary (lessThanEqV sym))
- , (">=" , binary (greaterThanEqV sym))
- , ("==" , binary (eqV sym))
- , ("!=" , binary (distinctV sym))
-
- -- SignedCmp
- , ("<$" , binary (signedLessThanV sym))
-
- -- Finite enumerations
- , ("fromTo" , fromToV sym)
- , ("fromThenTo" , fromThenToV sym)
-
- -- Sequence manipulations
- , ("#" , -- {a,b,d} (fin a) => [a] d -> [b] d -> [a + b] d
- nlam $ \ front ->
- nlam $ \ back ->
- tlam $ \ elty ->
- lam $ \ l -> return $
- lam $ \ r -> join (ccatV sym front back elty <$> l <*> r))
-
- , ("join" ,
- nlam $ \ parts ->
- nlam $ \ (finNat' -> each) ->
- tlam $ \ a ->
- lam $ \ x ->
- joinV sym parts each a =<< x)
-
- , ("split" , ecSplitV sym)
-
- , ("splitAt" ,
- nlam $ \ front ->
- nlam $ \ back ->
- tlam $ \ a ->
- lam $ \ x ->
- splitAtV sym front back a =<< x)
-
- , ("reverse" , nlam $ \_a ->
- tlam $ \_b ->
- lam $ \xs -> reverseV sym =<< xs)
-
- , ("transpose" , nlam $ \a ->
- nlam $ \b ->
- tlam $ \c ->
- lam $ \xs -> transposeV sym a b c =<< xs)
+ [ (">>$" , sshrV sym)
-- Shifts and rotates
, ("<<" , logicShift sym "<<" shiftShrink
@@ -187,52 +91,9 @@
, ("update" , updatePrim sym (updateFrontSym_word sym) (updateFrontSym sym))
, ("updateEnd" , updatePrim sym (updateBackSym_word sym) (updateBackSym sym))
- -- Misc
-
- , ("foldl" , foldlV sym)
- , ("foldl'" , foldl'V sym)
-
- , ("deepseq" ,
- tlam $ \_a ->
- tlam $ \_b ->
- lam $ \x -> pure $
- lam $ \y ->
- do _ <- forceValue =<< x
- y)
-
- , ("parmap" , parmapV sym)
-
- , ("fromZ" , fromZV sym)
-
- -- {at,len} (fin len) => [len][8] -> at
- , ("error" ,
- tlam $ \a ->
- nlam $ \_ ->
- VFun $ \s -> errorV sym a =<< (valueToString sym =<< s))
-
- , ("random" ,
- tlam $ \a ->
- wlam sym $ \x ->
- case wordAsLit sym x of
- Just (_,i) -> randomV sym a i
- Nothing -> cryUserError sym "cannot evaluate 'random' with symbolic inputs")
-
- -- The trace function simply forces its first two
- -- values before returing the third in the symbolic
- -- evaluator.
- , ("trace",
- nlam $ \_n ->
- tlam $ \_a ->
- tlam $ \_b ->
- lam $ \s -> return $
- lam $ \x -> return $
- lam $ \y -> do
- _ <- s
- _ <- x
- y)
]
-primeECPrims :: W4.IsSymExprBuilder sym => What4 sym -> Map.Map PrimIdent (Value sym)
+primeECPrims :: W4.IsSymExprBuilder sym => What4 sym -> Map.Map PrimIdent (Prim (What4 sym))
primeECPrims sym = Map.fromList $ [ (primeECPrim n, v) | (n,v) <- prims ]
where
(~>) = (,)
@@ -240,8 +101,9 @@
prims =
[ -- {p} (prime p, p > 3) => ProjectivePoint p -> ProjectivePoint p
"ec_double" ~>
- ilam \p ->
- lam \s ->
+ PFinPoly \p ->
+ PFun \s ->
+ PPrim
do p' <- integerLit sym p
s' <- toProjectivePoint sym =<< s
addUninterpWarning sym "Prime ECC"
@@ -252,9 +114,10 @@
-- {p} (prime p, p > 3) => ProjectivePoint p -> ProjectivePoint p -> ProjectivePoint p
, "ec_add_nonzero" ~>
- ilam \p ->
- lam \s -> pure $
- lam \t ->
+ PFinPoly \p ->
+ PFun \s ->
+ PFun \t ->
+ PPrim
do p' <- integerLit sym p
s' <- toProjectivePoint sym =<< s
t' <- toProjectivePoint sym =<< t
@@ -266,9 +129,10 @@
-- {p} (prime p, p > 3) => Z p -> ProjectivePoint p -> ProjectivePoint p
, "ec_mult" ~>
- ilam \p ->
- lam \k -> pure $
- lam \s ->
+ PFinPoly \p ->
+ PFun \k ->
+ PFun \s ->
+ PPrim
do p' <- integerLit sym p
k' <- fromVInteger <$> k
s' <- toProjectivePoint sym =<< s
@@ -280,11 +144,12 @@
-- {p} (prime p, p > 3) => Z p -> ProjectivePoint p -> Z p -> ProjectivePoint p -> ProjectivePoint p
, "ec_twin_mult" ~>
- ilam \p ->
- lam \j -> pure $
- lam \s -> pure $
- lam \k -> pure $
- lam \t ->
+ PFinPoly \p ->
+ PFun \j ->
+ PFun \s ->
+ PFun \k ->
+ PFun \t ->
+ PPrim
do p' <- integerLit sym p
j' <- fromVInteger <$> j
s' <- toProjectivePoint sym =<< s
@@ -299,7 +164,6 @@
fromProjectivePoint sym z
]
-
type ProjectivePoint = W4.BaseStructType (EmptyCtx ::> W4.BaseIntegerType ::> W4.BaseIntegerType ::> W4.BaseIntegerType)
projectivePointRepr :: W4.BaseTypeRepr ProjectivePoint
@@ -321,37 +185,44 @@
z <- VInteger <$> W4.structField (w4 sym) p (natIndex @2)
pure $ VRecord $ recordFromFields [ (packIdent "x",pure x), (packIdent "y",pure y),(packIdent "z",pure z) ]
-suiteBPrims :: W4.IsSymExprBuilder sym => What4 sym -> Map.Map PrimIdent (Value sym)
+
+suiteBPrims :: W4.IsSymExprBuilder sym => What4 sym -> Map.Map PrimIdent (Prim (What4 sym))
suiteBPrims sym = Map.fromList $ [ (suiteBPrim n, v) | (n,v) <- prims ]
where
(~>) = (,)
prims =
[ "AESEncRound" ~>
- lam \st ->
+ PFun \st ->
+ PPrim
do addUninterpWarning sym "AES encryption"
applyAESStateFunc sym "AESEncRound" =<< st
, "AESEncFinalRound" ~>
- lam \st ->
+ PFun \st ->
+ PPrim
do addUninterpWarning sym "AES encryption"
applyAESStateFunc sym "AESEncFinalRound" =<< st
, "AESDecRound" ~>
- lam \st ->
+ PFun \st ->
+ PPrim
do addUninterpWarning sym "AES decryption"
applyAESStateFunc sym "AESDecRound" =<< st
, "AESDecFinalRound" ~>
- lam \st ->
+ PFun \st ->
+ PPrim
do addUninterpWarning sym "AES decryption"
applyAESStateFunc sym "AESDecFinalRound" =<< st
, "AESInvMixColumns" ~>
- lam \st ->
+ PFun \st ->
+ PPrim
do addUninterpWarning sym "AES key expansion"
applyAESStateFunc sym "AESInvMixColumns" =<< st
-- {k} (fin k, k >= 4, 8 >= k) => [k][32] -> [4*(k+7)][32]
, "AESKeyExpand" ~>
- ilam \k ->
- lam \st ->
+ PFinPoly \k ->
+ PFun \st ->
+ PPrim
do ss <- fromVSeq <$> st
-- pack the arguments into a k-tuple of 32-bit values
Some ws <- generateSomeM (fromInteger k) (\i -> Some <$> toWord32 sym "AESKeyExpand" ss (toInteger i))
@@ -368,12 +239,13 @@
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)
- _ -> invalidIndex sym i
+ _ -> evalPanic "AESKeyExpand" ["Index out of range", show k, show i]
-- {n} (fin n) => [n][16][32] -> [7][32]
, "processSHA2_224" ~>
- ilam \n ->
- lam \xs ->
+ PFinPoly \n ->
+ PFun \xs ->
+ PPrim
do blks <- enumerateSeqMap n . fromVSeq <$> xs
addUninterpWarning sym "SHA-224"
initSt <- liftIO (mkSHA256InitialState sym SHA.initialSHA224State)
@@ -384,13 +256,14 @@
do z <- liftIO $ W4.structField (w4 sym) finalSt idx
case W4.testEquality (W4.exprType z) (W4.BaseBVRepr (W4.knownNat @32)) of
Just W4.Refl -> fromWord32 z
- Nothing -> invalidIndex sym i
- Nothing -> invalidIndex sym i
+ Nothing -> evalPanic "processSHA2_224" ["Index out of range", show i]
+ Nothing -> evalPanic "processSHA2_224" ["Index out of range", show i]
-- {n} (fin n) => [n][16][32] -> [8][32]
, "processSHA2_256" ~>
- ilam \n ->
- lam \xs ->
+ PFinPoly \n ->
+ PFun \xs ->
+ PPrim
do blks <- enumerateSeqMap n . fromVSeq <$> xs
addUninterpWarning sym "SHA-256"
initSt <- liftIO (mkSHA256InitialState sym SHA.initialSHA256State)
@@ -401,13 +274,14 @@
do z <- liftIO $ W4.structField (w4 sym) finalSt idx
case W4.testEquality (W4.exprType z) (W4.BaseBVRepr (W4.knownNat @32)) of
Just W4.Refl -> fromWord32 z
- Nothing -> invalidIndex sym i
- Nothing -> invalidIndex sym i
+ Nothing -> evalPanic "processSHA2_256" ["Index out of range", show i]
+ Nothing -> evalPanic "processSHA2_256" ["Index out of range", show i]
-- {n} (fin n) => [n][16][64] -> [6][64]
, "processSHA2_384" ~>
- ilam \n ->
- lam \xs ->
+ PFinPoly \n ->
+ PFun \xs ->
+ PPrim
do blks <- enumerateSeqMap n . fromVSeq <$> xs
addUninterpWarning sym "SHA-384"
initSt <- liftIO (mkSHA512InitialState sym SHA.initialSHA384State)
@@ -418,13 +292,14 @@
do z <- liftIO $ W4.structField (w4 sym) finalSt idx
case W4.testEquality (W4.exprType z) (W4.BaseBVRepr (W4.knownNat @64)) of
Just W4.Refl -> fromWord64 z
- Nothing -> invalidIndex sym i
- Nothing -> invalidIndex sym i
+ Nothing -> evalPanic "processSHA2_384" ["Index out of range", show i]
+ Nothing -> evalPanic "processSHA2_384" ["Index out of range", show i]
-- {n} (fin n) => [n][16][64] -> [8][64]
, "processSHA2_512" ~>
- ilam \n ->
- lam \xs ->
+ PFinPoly \n ->
+ PFun \xs ->
+ PPrim
do blks <- enumerateSeqMap n . fromVSeq <$> xs
addUninterpWarning sym "SHA-512"
initSt <- liftIO (mkSHA512InitialState sym SHA.initialSHA512State)
@@ -435,8 +310,8 @@
do z <- liftIO $ W4.structField (w4 sym) finalSt idx
case W4.testEquality (W4.exprType z) (W4.BaseBVRepr (W4.knownNat @64)) of
Just W4.Refl -> fromWord64 z
- Nothing -> invalidIndex sym i
- Nothing -> invalidIndex sym i
+ Nothing -> evalPanic "processSHA2_512" ["Index out of range", show i]
+ Nothing -> evalPanic "processSHA2_512" ["Index out of range", show i]
]
@@ -626,7 +501,7 @@
| i == 1 -> fromWord32 =<< liftIO (W4.structField (w4 sym) z (natIndex @1))
| i == 2 -> fromWord32 =<< liftIO (W4.structField (w4 sym) z (natIndex @2))
| i == 3 -> fromWord32 =<< liftIO (W4.structField (w4 sym) z (natIndex @3))
- | otherwise -> invalidIndex sym i
+ | otherwise -> evalPanic "applyAESStateFunc" ["Index out of range", show funNm, show i]
where
nm = Text.unpack funNm
@@ -636,13 +511,14 @@
argCtx = W4.knownRepr
-sshrV :: W4.IsSymExprBuilder sym => What4 sym -> Value sym
+sshrV :: W4.IsSymExprBuilder sym => What4 sym -> Prim (What4 sym)
sshrV sym =
- nlam $ \(Nat n) ->
- tlam $ \ix ->
- wlam sym $ \x -> return $
- lam $ \y ->
- y >>= asIndex sym ">>$" ix >>= \case
+ 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
@@ -864,7 +740,7 @@
WordVal w | Just j <- SW.bvAsUnsignedInteger w ->
return $ updateSeqMap vs j val
_ ->
- memoMap $ IndexSeqMap $ \i ->
+ memoMap sym $ IndexSeqMap $ \i ->
do b <- wordValueEqualsInteger sym wv i
iteValue sym b val (lookupSeqMap vs i)
@@ -891,7 +767,7 @@
WordVal w | Just j <- SW.bvAsUnsignedInteger w ->
return $ updateSeqMap vs (n - 1 - j) val
_ ->
- memoMap $ IndexSeqMap $ \i ->
+ memoMap sym $ IndexSeqMap $ \i ->
do b <- wordValueEqualsInteger sym wv (n - 1 - i)
iteValue sym b val (lookupSeqMap vs i)
@@ -980,57 +856,3 @@
_ -> LargeBitsVal (wordValueSize sym wv) <$>
updateBackSym sym (Nat n) eltTy (asBitsMap sym bv) (Right wv) val
-
-
-
-
--- | Table of floating point primitives
-floatPrims :: W4.IsSymExprBuilder sym => What4 sym -> Map PrimIdent (Value sym)
-floatPrims sym =
- Map.fromList [ (floatPrim i,v) | (i,v) <- nonInfixTable ]
- where
- w4sym = w4 sym
- (~>) = (,)
-
- nonInfixTable =
- [ "fpNaN" ~> fpConst (W4.fpNaN w4sym)
- , "fpPosInf" ~> fpConst (W4.fpPosInf w4sym)
- , "fpFromBits" ~> ilam \e -> ilam \p -> wlam sym \w ->
- VFloat <$> liftIO (W4.fpFromBinary w4sym e p w)
- , "fpToBits" ~> ilam \e -> ilam \p -> flam \x ->
- pure $ VWord (e+p)
- $ WordVal <$> liftIO (W4.fpToBinary w4sym x)
- , "=.=" ~> ilam \_ -> ilam \_ -> flam \x -> pure $ flam \y ->
- VBit <$> liftIO (W4.fpEq w4sym x y)
- , "fpIsFinite" ~> ilam \_ -> ilam \_ -> flam \x ->
- VBit <$> liftIO do inf <- W4.fpIsInf w4sym x
- nan <- W4.fpIsNaN w4sym x
- weird <- W4.orPred w4sym inf nan
- W4.notPred w4sym weird
-
- , "fpAdd" ~> fpBinArithV sym fpPlus
- , "fpSub" ~> fpBinArithV sym fpMinus
- , "fpMul" ~> fpBinArithV sym fpMult
- , "fpDiv" ~> fpBinArithV sym fpDiv
-
- , "fpFromRational" ~>
- ilam \e -> ilam \p -> wlam sym \r -> pure $ lam \x ->
- do rat <- fromVRational <$> x
- VFloat <$> fpCvtFromRational sym e p r rat
-
- , "fpToRational" ~>
- ilam \_e -> ilam \_p -> flam \fp ->
- VRational <$> fpCvtToRational sym fp
- ]
-
-
-
--- | A helper for definitng floating point constants.
-fpConst ::
- W4.IsSymExprBuilder sym =>
- (Integer -> Integer -> IO (W4.SFloat sym)) ->
- Value sym
-fpConst mk =
- ilam \ e ->
- VNumPoly \ ~(Nat p) ->
- VFloat <$> liftIO (mk e p)
diff --git a/src/Cryptol/IR/FreeVars.hs b/src/Cryptol/IR/FreeVars.hs
--- a/src/Cryptol/IR/FreeVars.hs
+++ b/src/Cryptol/IR/FreeVars.hs
@@ -99,6 +99,7 @@
instance FreeVars Expr where
freeVars expr =
case expr of
+ ELocated _r t -> freeVars t
EList es t -> freeVars es <> freeVars t
ETuple es -> freeVars es
ERec fs -> freeVars (recordElements fs)
@@ -139,7 +140,7 @@
TUser _ _ t -> freeVars t
TRec fs -> freeVars (recordElements fs)
-
+ TNewtype nt ts -> freeVars nt <> freeVars ts
instance FreeVars TVar where
freeVars tv = case tv of
@@ -147,14 +148,11 @@
_ -> mempty
instance FreeVars TCon where
- freeVars tc =
- case tc of
- TC (TCNewtype (UserTC n _)) -> mempty { tyDeps = Set.singleton n }
- _ -> mempty
+ freeVars _tc = mempty
instance FreeVars Newtype where
freeVars nt = foldr rmTParam base (ntParams nt)
- where base = freeVars (ntConstraints nt) <> freeVars (map snd (ntFields nt))
+ where base = freeVars (ntConstraints nt) <> freeVars (recordElements (ntFields nt))
--------------------------------------------------------------------------------
diff --git a/src/Cryptol/ModuleSystem.hs b/src/Cryptol/ModuleSystem.hs
--- a/src/Cryptol/ModuleSystem.hs
+++ b/src/Cryptol/ModuleSystem.hs
@@ -14,6 +14,7 @@
, DynamicEnv(..)
, ModuleError(..), ModuleWarning(..)
, ModuleCmd, ModuleRes
+ , ModuleInput(..)
, findModule
, loadModuleByPath
, loadModuleByName
@@ -32,7 +33,6 @@
, IfaceTySyn, IfaceDecl(..)
) where
-import qualified Cryptol.Eval as E
import qualified Cryptol.Eval.Concrete as Concrete
import Cryptol.ModuleSystem.Env
import Cryptol.ModuleSystem.Interface
@@ -46,11 +46,9 @@
import qualified Cryptol.TypeCheck.AST as T
import qualified Cryptol.Utils.Ident as M
-import Data.ByteString (ByteString)
-
-- Public Interface ------------------------------------------------------------
-type ModuleCmd a = (E.EvalOpts, FilePath -> IO ByteString, ModuleEnv) -> IO (ModuleRes a)
+type ModuleCmd a = ModuleInput IO -> IO (ModuleRes a)
type ModuleRes a = (Either ModuleError (a,ModuleEnv), [ModuleWarning])
@@ -63,8 +61,8 @@
-- | Load the module contained in the given file.
loadModuleByPath :: FilePath -> ModuleCmd (ModulePath,T.Module)
-loadModuleByPath path (evo, byteReader, env) =
- runModuleM (evo, byteReader, resetModuleEnv env) $ do
+loadModuleByPath path minp =
+ runModuleM minp{ minpModuleEnv = resetModuleEnv (minpModuleEnv minp) } $ do
unloadModule ((InFile path ==) . lmFilePath)
m <- Base.loadModuleByPath path
setFocusedModule (T.mName m)
@@ -72,8 +70,8 @@
-- | Load the given parsed module.
loadModuleByName :: P.ModName -> ModuleCmd (ModulePath,T.Module)
-loadModuleByName n (evo, byteReader, env) =
- runModuleM (evo, byteReader, resetModuleEnv env) $ do
+loadModuleByName n minp =
+ runModuleM minp{ minpModuleEnv = resetModuleEnv (minpModuleEnv minp) } $ do
unloadModule ((n ==) . lmName)
(path,m') <- Base.loadModuleFrom False (FromModule n)
setFocusedModule (T.mName m')
diff --git a/src/Cryptol/ModuleSystem/Base.hs b/src/Cryptol/ModuleSystem/Base.hs
--- a/src/Cryptol/ModuleSystem/Base.hs
+++ b/src/Cryptol/ModuleSystem/Base.hs
@@ -26,7 +26,6 @@
, ModContext(..)
, ModulePath(..), modulePathLabel)
import qualified Cryptol.Eval as E
-
import qualified Cryptol.Eval.Concrete as Concrete
import Cryptol.Eval.Concrete (Concrete(..))
import qualified Cryptol.ModuleSystem.NamingEnv as R
@@ -41,6 +40,7 @@
import qualified Cryptol.TypeCheck.AST as T
import qualified Cryptol.TypeCheck.PP as T
import qualified Cryptol.TypeCheck.Sanity as TcSanity
+
import Cryptol.Transform.AddModParams (addModParams)
import Cryptol.Utils.Ident ( preludeName, floatName, arrayName, suiteBName, primeECName
, preludeReferenceName, interactiveName, modNameChunks
@@ -203,8 +203,10 @@
tcm <- optionalInstantiate =<< checkModule isrc path pm
-- extend the eval env, unless a functor.
- tbl <- Concrete.primTable <$> getEvalOpts
+ 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
@@ -453,7 +455,7 @@
data TCLinter o = TCLinter
{ lintCheck ::
- o -> T.InferInput -> Either TcSanity.Error [TcSanity.ProofObligation]
+ o -> T.InferInput -> Either (Range, TcSanity.Error) [TcSanity.ProofObligation]
, lintModule :: Maybe P.ModName
}
@@ -465,7 +467,9 @@
Left err -> Left err
Right (s1,os)
| TcSanity.same s s1 -> Right os
- | otherwise -> Left (TcSanity.TypeMismatch "exprLinter" s s1)
+ | otherwise -> Left ( fromMaybe emptyRange (getLoc e')
+ , TcSanity.TypeMismatch "exprLinter" s s1
+ )
, lintModule = Nothing
}
@@ -524,14 +528,15 @@
typeCheckingFailed nameMap errs
-- | Generate input for the typechecker.
-genInferInput :: Range -> PrimMap ->
- IfaceParams -> IfaceDecls -> ModuleM T.InferInput
+genInferInput :: Range -> PrimMap -> IfaceParams -> IfaceDecls -> ModuleM T.InferInput
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
return T.InferInput
@@ -542,6 +547,7 @@
, T.inpAbstractTypes = ifAbstractTypes env
, T.inpNameSeeds = seeds
, T.inpMonoBinds = monoBinds
+ , T.inpCallStacks = callStacks
, T.inpSolverConfig = cfg
, T.inpSearchPath = searchPath
, T.inpSupply = supply
@@ -549,30 +555,37 @@
, T.inpParamTypes = ifParamTypes params
, T.inpParamConstraints = ifParamConstraints params
, T.inpParamFuns = ifParamFuns params
+ , T.inpSolver = solver
}
-
-- Evaluation ------------------------------------------------------------------
evalExpr :: T.Expr -> ModuleM Concrete.Value
evalExpr e = do
env <- getEvalEnv
denv <- getDynEnv
- evopts <- getEvalOpts
+ evopts <- getEvalOptsAction
let tbl = Concrete.primTable evopts
let ?evalPrim = \i -> Right <$> Map.lookup i tbl
- io $ E.runEval $ (E.evalExpr Concrete (env <> deEnv denv) e)
+ let ?range = emptyRange
+ callStacks <- getCallStacks
+ let ?callStacks = callStacks
+ io $ E.runEval mempty (E.evalExpr Concrete (env <> deEnv denv) e)
+
evalDecls :: [T.DeclGroup] -> ModuleM ()
evalDecls dgs = do
env <- getEvalEnv
denv <- getDynEnv
- evOpts <- getEvalOpts
+ evOpts <- getEvalOptsAction
let env' = env <> deEnv denv
let tbl = Concrete.primTable evOpts
let ?evalPrim = \i -> Right <$> Map.lookup i tbl
- deEnv' <- io $ E.runEval $ E.evalDecls Concrete dgs env'
+ callStacks <- getCallStacks
+ let ?callStacks = callStacks
+
+ deEnv' <- io $ E.runEval mempty (E.evalDecls Concrete dgs env')
let denv' = denv { deDecls = deDecls denv ++ dgs
, deEnv = deEnv'
}
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
@@ -177,6 +177,12 @@
loadedNonParamModules :: ModuleEnv -> [T.Module]
loadedNonParamModules = map lmModule . lmLoadedModules . meLoadedModules
+loadedNewtypes :: ModuleEnv -> Map Name IfaceNewtype
+loadedNewtypes menv = Map.unions
+ [ ifNewtypes (ifPublic i) <> ifNewtypes (ifPrivate i)
+ | i <- map lmInterface (getLoadedModules (meLoadedModules menv))
+ ]
+
-- | Are any parameterized modules loaded?
hasParamModules :: ModuleEnv -> Bool
hasParamModules = not . null . lmLoadedParamModules . meLoadedModules
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
@@ -183,6 +183,7 @@
Just y -> EVar y
_ -> expr
+ ELocated r e -> ELocated r (inst env e)
EList xs t -> EList (inst env xs) (inst env t)
ETuple es -> ETuple (inst env es)
ERec xs -> ERec (fmap go xs)
@@ -243,6 +244,7 @@
TUser x ts t -> TUser y (inst env ts) (inst env t)
where y = Map.findWithDefault x x (tyNameMap env)
TRec fs -> TRec (fmap (inst env) fs)
+ TNewtype nt ts -> TNewtype (inst env nt) (inst env ts)
instance Inst TCon where
inst env tc =
@@ -253,7 +255,6 @@
instance Inst TC where
inst env tc =
case tc of
- TCNewtype x -> TCNewtype (inst env x)
TCAbstract x -> TCAbstract (inst env x)
_ -> tc
@@ -281,7 +282,7 @@
inst env nt = Newtype { ntName = instTyName env x
, ntParams = ntParams nt
, ntConstraints = inst env (ntConstraints nt)
- , ntFields = [ (f,inst env t) | (f,t) <- ntFields nt ]
+ , ntFields = fmap (inst env) (ntFields nt)
, ntDoc = ntDoc nt
}
where x = ntName nt
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
@@ -29,6 +29,8 @@
import qualified Cryptol.Parser.NoInclude as NoInc
import qualified Cryptol.TypeCheck as T
import qualified Cryptol.TypeCheck.AST as T
+import qualified Cryptol.TypeCheck.Solver.SMT as SMT
+
import Cryptol.Parser.Position (Range)
import Cryptol.Utils.Ident (interactiveName, noModuleName)
import Cryptol.Utils.PP
@@ -39,6 +41,7 @@
import Control.Exception (IOException)
import Data.ByteString (ByteString)
import Data.Function (on)
+import Data.Map (Map)
import Data.Maybe (isJust)
import Data.Text.Encoding.Error (UnicodeException)
import MonadLib
@@ -300,13 +303,20 @@
data RO m =
RO { roLoading :: [ImportSource]
- , roEvalOpts :: EvalOpts
+ , roEvalOpts :: m EvalOpts
+ , roCallStacks :: Bool
, roFileReader :: FilePath -> m ByteString
+ , roTCSolver :: SMT.Solver
}
-emptyRO :: EvalOpts -> (FilePath -> m ByteString) -> RO m
-emptyRO ev fileReader =
- RO { roLoading = [], roEvalOpts = ev, roFileReader = fileReader }
+emptyRO :: ModuleInput m -> RO m
+emptyRO minp =
+ RO { roLoading = []
+ , roEvalOpts = minpEvalOpts minp
+ , roCallStacks = minpCallStacks minp
+ , roFileReader = minpByteReader minp
+ , roTCSolver = minpTCSolver minp
+ }
newtype ModuleT m a = ModuleT
{ unModuleT :: ReaderT (RO m)
@@ -351,21 +361,34 @@
instance MonadIO m => MonadIO (ModuleT m) where
liftIO m = lift $ liftIO m
-runModuleT :: Monad m
- => (EvalOpts, FilePath -> m ByteString, ModuleEnv)
- -> ModuleT m a
- -> m (Either ModuleError (a, ModuleEnv), [ModuleWarning])
-runModuleT (ev, byteReader, env) m =
+
+data ModuleInput m =
+ ModuleInput
+ { minpCallStacks :: Bool
+ , minpEvalOpts :: m EvalOpts
+ , minpByteReader :: FilePath -> m ByteString
+ , minpModuleEnv :: ModuleEnv
+ , minpTCSolver :: SMT.Solver
+ }
+
+runModuleT ::
+ Monad m =>
+ ModuleInput m ->
+ ModuleT m a ->
+ m (Either ModuleError (a, ModuleEnv), [ModuleWarning])
+runModuleT minp m =
runWriterT
$ runExceptionT
- $ runStateT env
- $ runReaderT (emptyRO ev byteReader)
+ $ runStateT (minpModuleEnv minp)
+ $ runReaderT (emptyRO minp)
$ unModuleT m
type ModuleM = ModuleT IO
-runModuleM :: (EvalOpts, FilePath -> IO ByteString, ModuleEnv) -> ModuleM a
- -> IO (Either ModuleError (a,ModuleEnv),[ModuleWarning])
+runModuleM ::
+ ModuleInput IO ->
+ ModuleM a ->
+ IO (Either ModuleError (a,ModuleEnv),[ModuleWarning])
runModuleM = runModuleT
@@ -377,6 +400,9 @@
RO { roFileReader = readFileBytes } <- ask
return readFileBytes
+getCallStacks :: Monad m => ModuleT m Bool
+getCallStacks = ModuleT (roCallStacks <$> ask)
+
readBytes :: Monad m => FilePath -> ModuleT m ByteString
readBytes fn = do
fileReader <- getByteReader
@@ -385,6 +411,9 @@
getModuleEnv :: Monad m => ModuleT m ModuleEnv
getModuleEnv = ModuleT get
+getTCSolver :: Monad m => ModuleT m SMT.Solver
+getTCSolver = ModuleT (roTCSolver <$> ask)
+
setModuleEnv :: Monad m => ModuleEnv -> ModuleT m ()
setModuleEnv = ModuleT . set
@@ -489,15 +518,23 @@
modifyEvalEnv f = ModuleT $ do
env <- get
let evalEnv = meEvalEnv env
- evalEnv' <- inBase $ E.runEval (f evalEnv)
+ evalEnv' <- inBase $ E.runEval mempty (f evalEnv)
set $! env { meEvalEnv = evalEnv' }
getEvalEnv :: ModuleM EvalEnv
getEvalEnv = ModuleT (meEvalEnv `fmap` get)
+getEvalOptsAction :: ModuleM (IO EvalOpts)
+getEvalOptsAction = ModuleT (roEvalOpts `fmap` ask)
+
getEvalOpts :: ModuleM EvalOpts
-getEvalOpts = ModuleT (roEvalOpts `fmap` ask)
+getEvalOpts =
+ do act <- getEvalOptsAction
+ liftIO act
+getNewtypes :: ModuleM (Map T.Name T.Newtype)
+getNewtypes = ModuleT (loadedNewtypes <$> get)
+
getFocusedModule :: ModuleM (Maybe P.ModName)
getFocusedModule = ModuleT (meFocusedModule `fmap` get)
@@ -547,4 +584,3 @@
withLogger :: (Logger -> a -> IO b) -> a -> ModuleM b
withLogger f a = do l <- getEvalOpts
io (f (evalLogger l) a)
-
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
@@ -57,7 +57,6 @@
import Control.DeepSeq
-import Control.Monad.Fix (MonadFix(mfix))
import qualified Data.Map as Map
import qualified Data.Monoid as M
import Data.Ord (comparing)
@@ -294,9 +293,6 @@
instance RunM m (a,Supply) r => RunM (SupplyT m) a (Supply -> r) where
runM (SupplyT m) s = runM m s
{-# INLINE runM #-}
-
-instance MonadFix m => MonadFix (SupplyT m) where
- mfix f = SupplyT (mfix (unSupply . f))
-- | Retrieve the next unique from the supply.
nextUniqueM :: FreshM m => m Int
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
@@ -501,7 +501,7 @@
name' <- rnLocated renameType (nName n)
shadowNames (nParams n) $
do ps' <- traverse rename (nParams n)
- body' <- traverse (rnNamed rename) (nBody n)
+ body' <- traverse (traverse rename) (nBody n)
return Newtype { nName = name'
, nParams = ps'
, nBody = body' }
@@ -693,13 +693,18 @@
case more of
[] -> case h of
UpdSet -> UpdField UpdSet [l] <$> rename e
- UpdFun -> UpdField UpdFun [l] <$> rename (EFun [PVar p] e)
+ UpdFun -> UpdField UpdFun [l] <$> rename (EFun emptyFunDesc [PVar p] e)
where
p = UnQual . selName <$> last ls
_ -> UpdField UpdFun [l] <$> rename (EUpd Nothing [ UpdField h more e])
[] -> panic "rename@UpdField" [ "Empty label list." ]
+instance Rename FunDesc where
+ rename (FunDesc nm offset) =
+ do nm' <- traverse renameVar nm
+ pure (FunDesc nm' offset)
+
instance Rename Expr where
rename expr = case expr of
EVar n -> EVar <$> renameVar n
@@ -719,6 +724,10 @@
<*> traverse rename n
<*> rename e
<*> traverse rename t
+ EFromToLessThan s e t ->
+ EFromToLessThan <$> rename s
+ <*> rename e
+ <*> traverse rename t
EInfFrom a b -> EInfFrom<$> rename a <*> traverse rename b
EComp e' bs -> do arms' <- traverse renameArm bs
let (envs,bs') = unzip arms'
@@ -733,10 +742,11 @@
EWhere <$> rename e' <*> traverse rename ds
ETyped e' ty -> ETyped <$> rename e' <*> rename ty
ETypeVal ty -> ETypeVal<$> rename ty
- EFun ps e' -> do (env,ps') <- renamePats ps
+ EFun desc ps e' -> do desc' <- rename desc
+ (env,ps') <- renamePats ps
-- NOTE: renamePats will generate warnings, so we don't
-- need to duplicate them here
- shadowNames' CheckNone env (EFun ps' <$> rename e')
+ shadowNames' CheckNone env (EFun desc' ps' <$> rename e')
ELocated e' r -> withLoc r
$ ELocated <$> rename e' <*> pure r
@@ -966,10 +976,3 @@
<*> pure f
<*> traverse rename ps
<*> traverse rename cs
-
-
--- Utilities -------------------------------------------------------------------
-
-rnNamed :: (a -> RenameM b) -> Named a -> RenameM (Named b)
-rnNamed = traverse
-{-# INLINE rnNamed #-}
diff --git a/src/Cryptol/Parser.y b/src/Cryptol/Parser.y
--- a/src/Cryptol/Parser.y
+++ b/src/Cryptol/Parser.y
@@ -27,6 +27,7 @@
import Control.Applicative as A
import Data.Maybe(fromMaybe)
+import Data.List.NonEmpty ( NonEmpty(..), cons )
import Data.Text(Text)
import qualified Data.Text as T
import Control.Monad(liftM2,msum)
@@ -37,6 +38,7 @@
import Cryptol.Parser.ParserUtils
import Cryptol.Parser.Unlit(PreProc(..), guessPreProc)
import Cryptol.Utils.Ident(paramInstModName)
+import Cryptol.Utils.RecordMap(RecordMap)
import Paths_cryptol
}
@@ -91,7 +93,9 @@
'<-' { Located $$ (Token (Sym ArrL ) _)}
'..' { Located $$ (Token (Sym DotDot ) _)}
'...' { Located $$ (Token (Sym DotDotDot) _)}
+ '..<' { Located $$ (Token (Sym DotDotLt) _)}
'|' { Located $$ (Token (Sym Bar ) _)}
+ '<' { Located $$ (Token (Sym Lt ) _)}
'(' { Located $$ (Token (Sym ParenL ) _)}
')' { Located $$ (Token (Sym ParenR ) _)}
@@ -325,13 +329,13 @@
newtype :: { Newtype PName }
: 'newtype' qname '=' newtype_body
- { Newtype { nName = $2, nParams = [], nBody = $4 } }
+ { Newtype $2 [] (thing $4) }
| 'newtype' qname tysyn_params '=' newtype_body
- { Newtype { nName = $2, nParams = $3, nBody = $5 } }
+ { Newtype $2 (reverse $3) (thing $5) }
-newtype_body :: { [Named (Type PName)] }
- : '{' '}' { [] }
- | '{' field_types '}' { $2 }
+newtype_body :: { Located (RecordMap Ident (Range, Type PName)) }
+ : '{' '}' {% mkRecord (rComb $1 $2) (Located emptyRange) [] }
+ | '{' field_types '}' {% mkRecord (rComb $1 $3) (Located emptyRange) $2 }
vars_comma :: { [ LPName ] }
: var { [ $1] }
@@ -402,6 +406,7 @@
| '-' { Located $1 $ mkUnqual $ mkInfix "-" }
| '~' { Located $1 $ mkUnqual $ mkInfix "~" }
| '^^' { Located $1 $ mkUnqual $ mkInfix "^^" }
+ | '<' { Located $1 $ mkUnqual $ mkInfix "<" }
other_op :: { LPName }
@@ -424,7 +429,7 @@
-- | An expression without a `where` clause
exprNoWhere :: { Expr PName }
- : simpleExpr qop longRHS { at ($1,$3) (binOp $1 $2 $3) }
+ : simpleExpr qop longRHS { binOp $1 $2 $3 }
| longRHS { $1 }
| typedExpr { $1 }
@@ -441,13 +446,13 @@
-- A possibly infix expression (no where, no long application, no type annot)
simpleExpr :: { Expr PName }
- : simpleExpr qop simpleRHS { at ($1,$3) (binOp $1 $2 $3) }
+ : simpleExpr qop simpleRHS { binOp $1 $2 $3 }
| simpleRHS { $1 }
-- An expression without an obvious end marker
longExpr :: { Expr PName }
: 'if' ifBranches 'else' exprNoWhere { at ($1,$4) $ mkIf (reverse $2) $4 }
- | '\\' apats '->' exprNoWhere { at ($1,$4) $ EFun (reverse $2) $4 }
+ | '\\' apats '->' exprNoWhere { at ($1,$4) $ EFun emptyFunDesc (reverse $2) $4 }
ifBranches :: { [(Expr PName, Expr PName)] }
: ifBranch { [$1] }
@@ -469,7 +474,7 @@
-- Prefix application expression, ends with an atom.
simpleApp :: { Expr PName }
- : aexprs { mkEApp $1 }
+ : aexprs {% mkEApp $1 }
-- Prefix application expression, may end with a long expression
longApp :: { Expr PName }
@@ -477,9 +482,9 @@
| longExpr { $1 }
| simpleApp { $1 }
-aexprs :: { [Expr PName] }
- : aexpr { [$1] }
- | aexprs aexpr { $2 : $1 }
+aexprs :: { NonEmpty (Expr PName) }
+ : aexpr { $1 :| [] }
+ | aexprs aexpr { cons $2 $1 }
-- Expression atom (needs no parens)
@@ -567,6 +572,9 @@
| expr '..' expr {% eFromTo $2 $1 Nothing $3 }
| expr ',' expr '..' expr {% eFromTo $4 $1 (Just $3) $5 }
+
+ | expr '..' '<' expr {% eFromToLessThan $2 $1 $4 }
+ | expr '..<' expr {% eFromToLessThan $2 $1 $3 }
| expr '...' { EInfFrom $1 Nothing }
| expr ',' expr '...' { EInfFrom $1 (Just $3) }
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
@@ -68,6 +68,8 @@
, TypeInst(..)
, UpdField(..)
, UpdHow(..)
+ , FunDesc(..)
+ , emptyFunDesc
-- * Positions
, Located(..)
@@ -246,7 +248,7 @@
data Newtype name = Newtype { nName :: Located name -- ^ Type name
, nParams :: [TParam name] -- ^ Type params
- , nBody :: [Named (Type name)] -- ^ Constructor
+ , nBody :: Rec (Type name) -- ^ Body
} deriving (Eq, Show, Generic, NFData)
-- | A declaration for a type with no implementation.
@@ -312,6 +314,9 @@
| EList [Expr n] -- ^ @ [1,2,3] @
| EFromTo (Type n) (Maybe (Type n)) (Type n) (Maybe (Type n))
-- ^ @ [1, 5 .. 117 : t] @
+ | EFromToLessThan (Type n) (Type n) (Maybe (Type n))
+ -- ^ @ [ 1 .. < 10 : t ] @
+
| EInfFrom (Expr n) (Maybe (Expr n))-- ^ @ [1, 3 ...] @
| EComp (Expr n) [[Match n]] -- ^ @ [ 1 | x <- xs ] @
| EApp (Expr n) (Expr n) -- ^ @ f x @
@@ -320,7 +325,7 @@
| EWhere (Expr n) [Decl n] -- ^ @ 1 + x where { x = 2 } @
| ETyped (Expr n) (Type n) -- ^ @ 1 : [8] @
| ETypeVal (Type n) -- ^ @ `(x + 1)@, @x@ is a type
- | EFun [Pattern n] (Expr n) -- ^ @ \\x y -> x @
+ | EFun (FunDesc n) [Pattern n] (Expr n) -- ^ @ \\x y -> x @
| ELocated (Expr n) Range -- ^ position annotation
| ESplit (Expr n) -- ^ @ splitAt x @ (Introduced by NoPat)
@@ -328,6 +333,19 @@
| EInfix (Expr n) (Located n) Fixity (Expr n)-- ^ @ a + b @ (Removed by Fixity)
deriving (Eq, Show, Generic, NFData, Functor)
+-- | Description of functions. Only trivial information is provided here
+-- by the parser. The NoPat pass fills this in as required.
+data FunDesc n =
+ FunDesc
+ { funDescrName :: Maybe n -- ^ Name of this function, if it has one
+ , funDescrArgOffset :: Int -- ^ number of previous arguments to this function
+ -- bound in surrounding lambdas (defaults to 0)
+ }
+ deriving (Eq, Show, Generic, NFData, Functor)
+
+emptyFunDesc :: FunDesc n
+emptyFunDesc = FunDesc Nothing 0
+
data UpdField n = UpdField UpdHow [Located Selector] (Expr n)
-- ^ non-empty list @ x.y = e@
deriving (Eq, Show, Generic, NFData, Functor)
@@ -394,7 +412,8 @@
instance AddLoc (Expr n) where
- addLoc = ELocated
+ addLoc x@ELocated{} _ = x
+ addLoc x r = ELocated x r
dropLoc (ELocated e _) = dropLoc e
dropLoc e = e
@@ -496,7 +515,7 @@
| null locs = Nothing
| otherwise = Just (rCombs locs)
where
- locs = catMaybes [ getLoc (nName n), getLoc (nBody n) ]
+ locs = catMaybes ([ getLoc (nName n)] ++ map (Just . fst . snd) (displayFields (nBody n)))
--------------------------------------------------------------------------------
@@ -575,7 +594,7 @@
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 ":") (nBody nt))) ]
+ , braces (commaSep (map (ppNamed' ":") (displayFields (nBody nt)))) ]
instance PP Import where
ppPrec _ d = text "import" <+> sep [ pp (iModule d), mbAs, mbSpec ]
@@ -732,6 +751,9 @@
EFromTo e1 e2 e3 t1 -> brackets (pp e1 <.> step <+> text ".." <+> end)
where step = maybe empty (\e -> comma <+> pp e) e2
end = maybe (pp e3) (\t -> pp e3 <+> colon <+> pp t) t1
+ 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))
@@ -744,7 +766,7 @@
ESel e l -> ppPrec 4 e <.> text "." <.> pp l
-- low prec
- EFun xs e -> wrap n 0 ((text "\\" <.> hsep (map (ppPrec 3) xs)) <+>
+ EFun _ xs e -> wrap n 0 ((text "\\" <.> hsep (map (ppPrec 3) xs)) <+>
text "->" <+> pp e)
EIf e1 e2 e3 -> wrap n 0 $ sep [ text "if" <+> pp e1
@@ -938,7 +960,7 @@
instance NoPos (Newtype name) where
noPos n = Newtype { nName = noPos (nName n)
, nParams = nParams n
- , nBody = noPos (nBody n)
+ , nBody = fmap noPos (nBody n)
}
instance NoPos (Bind name) where
@@ -979,6 +1001,7 @@
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)
+ 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)
EApp x y -> EApp (noPos x) (noPos y)
@@ -987,7 +1010,7 @@
EWhere x y -> EWhere (noPos x) (noPos y)
ETyped x y -> ETyped (noPos x) (noPos y)
ETypeVal x -> ETypeVal (noPos x)
- EFun x y -> EFun (noPos x) (noPos y)
+ EFun dsc x y -> EFun dsc (noPos x) (noPos y)
ELocated x _ -> noPos x
ESplit x -> ESplit (noPos x)
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
@@ -142,6 +142,7 @@
"`" { emit $ Sym BackTick }
".." { emit $ Sym DotDot }
"..." { emit $ Sym DotDotDot }
+"..<" { emit $ Sym DotDotLt }
"|" { emit $ Sym Bar }
"(" { emit $ Sym ParenL }
")" { emit $ Sym ParenR }
@@ -161,6 +162,9 @@
"*" { emit (Op Mul ) }
"^^" { emit (Op Exp ) }
+-- < can appear in the enumeration syntax `[ x .. < y ]
+"<" { emit $ Sym Lt }
+
-- hash is used as a kind, and as a pattern
"#" { emit (Op Hash ) }
@@ -202,7 +206,7 @@
primLexer :: Config -> Text -> ([Located Token], Position)
primLexer cfg cs = run inp Normal
where
- inp = Inp { alexPos = start
+ inp = Inp { alexPos = cfgStart cfg
, alexInputPrevChar = '\n'
, input = unLit (cfgPreProc cfg) cs }
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
@@ -32,6 +32,7 @@
data Config = Config
{ cfgSource :: !FilePath -- ^ File that we are working on
+ , cfgStart :: !Position -- ^ Starting position for the parser
, cfgLayout :: !Layout -- ^ Settings for layout processing
, cfgPreProc :: PreProc -- ^ Preprocessor settings
, cfgAutoInclude :: [FilePath] -- ^ Implicit includes
@@ -43,6 +44,7 @@
defaultConfig :: Config
defaultConfig = Config
{ cfgSource = ""
+ , cfgStart = start
, cfgLayout = Layout
, cfgPreProc = None
, cfgAutoInclude = []
@@ -522,12 +524,14 @@
| Dot
| DotDot
| DotDotDot
+ | DotDotLt
| Colon
| BackTick
| ParenL | ParenR
| BracketL | BracketR
| CurlyL | CurlyR
| TriL | TriR
+ | Lt
| Underscore
deriving (Eq, Show, Generic, NFData)
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
@@ -84,6 +84,7 @@
in Set.unions (e : map namesUF fs)
EList es -> Set.unions (map namesE es)
EFromTo{} -> 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)
in Set.union (boundLNames (concat dss) (namesE e))
@@ -95,7 +96,7 @@
in Set.union (boundLNames bs (namesE e)) xs
ETyped e _ -> namesE e
ETypeVal _ -> Set.empty
- EFun ps e -> boundLNames (namesPs ps) (namesE e)
+ EFun _ ps e -> boundLNames (namesPs ps) (namesE e)
ELocated e _ -> namesE e
ESplit e -> namesE e
@@ -203,6 +204,8 @@
`Set.union` maybe Set.empty tnamesT b
`Set.union` tnamesT c
`Set.union` 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')
EComp e mss -> Set.union (tnamesE e) (Set.unions (map tnamesM (concat mss)))
EApp e1 e2 -> Set.union (tnamesE e1) (tnamesE e2)
@@ -212,7 +215,7 @@
in Set.union (boundLNames bs (tnamesE e)) xs
ETyped e t -> Set.union (tnamesE e) (tnamesT t)
ETypeVal t -> tnamesT t
- EFun ps e -> Set.union (Set.unions (map tnamesP ps)) (tnamesE e)
+ EFun _ ps e -> Set.union (Set.unions (map tnamesP ps)) (tnamesE e)
ELocated e _ -> tnamesE e
ESplit e -> tnamesE e
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
@@ -154,6 +154,7 @@
EUpd mb fs -> EUpd <$> traverse noPatE mb <*> traverse noPatUF fs
EList es -> EList <$> mapM noPatE es
EFromTo {} -> return expr
+ EFromToLessThan{} -> return expr
EInfFrom e e' -> EInfFrom <$> noPatE e <*> traverse noPatE e'
EComp e mss -> EComp <$> noPatE e <*> mapM noPatArm mss
EApp e1 e2 -> EApp <$> noPatE e1 <*> noPatE e2
@@ -162,8 +163,7 @@
EWhere e ds -> EWhere <$> noPatE e <*> noPatDs ds
ETyped e t -> ETyped <$> noPatE e <*> return t
ETypeVal {} -> return expr
- EFun ps e -> do (ps1,e1) <- noPatFun ps e
- return (EFun ps1 e1)
+ EFun desc ps e -> noPatFun (funDescrName desc) (funDescrArgOffset desc) ps e
ELocated e r1 -> ELocated <$> inRange r1 (noPatE e) <*> return r1
ESplit e -> ESplit <$> noPatE e
@@ -174,15 +174,26 @@
noPatUF :: UpdField PName -> NoPatM (UpdField PName)
noPatUF (UpdField h ls e) = UpdField h ls <$> noPatE e
-noPatFun :: [Pattern PName] -> Expr PName -> NoPatM ([Pattern PName], Expr PName)
-noPatFun ps e =
- do (xs,bs) <- unzip <$> mapM noPat ps
- e1 <- noPatE e
- let body = case concat bs of
- [] -> e1
- ds -> EWhere e1 $ map DBind ds
- return (xs, body)
-
+-- Desugar lambdas with multiple patterns into a sequence of
+-- lambdas with a single, simple pattern each. Bindings required
+-- to simplify patterns are placed inside "where" blocks that are
+-- interspersed into the lambdas to ensure that the lexical
+-- structure is reliable, with names on the right shadowing names
+-- on the left.
+noPatFun :: Maybe PName -> Int -> [Pattern PName] -> Expr PName -> NoPatM (Expr PName)
+noPatFun _ _ [] e = noPatE e
+noPatFun mnm offset (p:ps) e =
+ do (p',ds) <- noPat p
+ e' <- noPatFun mnm (offset+1) ps e
+ let body = case ds of
+ [] -> e'
+ _ -> EWhere e' $ map DBind (reverse ds)
+ -- ^
+ -- This reverse isn't strictly necessary, but yields more sensible
+ -- variable ordering results from type inference. I'm not entirely
+ -- sure why.
+ let desc = FunDesc mnm offset
+ return (EFun desc [p'] body)
noPatArm :: [Match PName] -> NoPatM [Match PName]
noPatArm ms = concat <$> mapM noPatM ms
@@ -203,8 +214,8 @@
, show b ]
DExpr e ->
- do (ps,e') <- noPatFun (bParams b) e
- return b { bParams = ps, bDef = DExpr e' <$ bDef b }
+ do e' <- noPatFun (Just (thing (bName b))) 0 (bParams b) e
+ return b { bParams = [], bDef = DExpr e' <$ bDef b }
noMatchD :: Decl PName -> NoPatM [Decl PName]
noMatchD decl =
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
@@ -17,6 +17,8 @@
import Data.Maybe(fromMaybe)
import Data.Bits(testBit,setBit)
+import Data.List.NonEmpty ( NonEmpty(..) )
+import qualified Data.List.NonEmpty as NE
import Control.Monad(liftM,ap,unless,guard)
import qualified Control.Monad.Fail as Fail
import Data.Text(Text)
@@ -65,7 +67,7 @@
case sTokens s of
t : _ | Err e <- tokenType it ->
Left $ HappyErrorMsg (srcRange t) $
- case e of
+ [case e of
UnterminatedComment -> "unterminated comment"
UnterminatedString -> "unterminated string"
UnterminatedChar -> "unterminated character"
@@ -79,6 +81,7 @@
T.unpack (tokenText it)
MalformedSelector -> "malformed selector: " ++
T.unpack (tokenText it)
+ ]
where it = thing t
t : more -> unP (k t) cfg p s { sPrevTok = Just t, sTokens = more }
@@ -86,7 +89,7 @@
data ParseError = HappyError FilePath {- Name of source file -}
(Located Token) {- Offending token -}
- | HappyErrorMsg Range String
+ | HappyErrorMsg Range [String]
| HappyUnexpected FilePath (Maybe (Located Token)) String
| HappyOutOfTokens FilePath Position
deriving (Show, Generic, NFData)
@@ -123,7 +126,7 @@
text "Unexpected end of file at:" <+>
text path <.> char ':' <.> pp pos
-ppError (HappyErrorMsg p x) = text "Parse error at" <+> pp p $$ nest 2 (text x)
+ppError (HappyErrorMsg p xs) = text "Parse error at" <+> pp p $$ nest 2 (vcat (map text xs))
ppError (HappyUnexpected path ltok e) =
text "Parse error at" <+>
@@ -159,13 +162,13 @@
case sPrevTok s of
Just t -> Left (HappyError (cfgSource cfg) t)
Nothing ->
- Left (HappyErrorMsg emptyRange "Parse error at the beginning of the file")
+ Left (HappyErrorMsg emptyRange ["Parse error at the beginning of the file"])
-errorMessage :: Range -> String -> ParseM a
-errorMessage r x = P $ \_ _ _ -> Left (HappyErrorMsg r x)
+errorMessage :: Range -> [String] -> ParseM a
+errorMessage r xs = P $ \_ _ _ -> Left (HappyErrorMsg r xs)
customError :: String -> Located Token -> ParseM a
-customError x t = P $ \_ _ _ -> Left (HappyErrorMsg (srcRange t) x)
+customError x t = P $ \_ _ _ -> Left (HappyErrorMsg (srcRange t) [x])
expected :: String -> ParseM a
expected x = P $ \cfg _ s ->
@@ -231,19 +234,19 @@
intVal tok =
case tokenType (thing tok) of
Num x _ _ -> return x
- _ -> errorMessage (srcRange tok) "Expected an integer"
+ _ -> errorMessage (srcRange tok) ["Expected an integer"]
mkFixity :: Assoc -> Located Token -> [LPName] -> ParseM (Decl PName)
mkFixity assoc tok qns =
do l <- intVal tok
unless (l >= 1 && l <= 100)
- (errorMessage (srcRange tok) "Fixity levels must be between 1 and 100")
+ (errorMessage (srcRange tok) ["Fixity levels must be between 1 and 100"])
return (DFixity (Fixity assoc (fromInteger l)) qns)
fromStrLit :: Located Token -> ParseM (Located String)
fromStrLit loc = case tokenType (thing loc) of
StrLit str -> return loc { thing = str }
- _ -> errorMessage (srcRange loc) "Expected a string literal"
+ _ -> errorMessage (srcRange loc) ["Expected a string literal"]
validDemotedType :: Range -> Type PName -> ParseM (Type PName)
@@ -264,14 +267,14 @@
TParens t -> validDemotedType rng t
TInfix{} -> ok
- where bad x = errorMessage rng (x ++ " cannot be demoted.")
+ where bad x = errorMessage rng [x ++ " cannot be demoted."]
ok = return $ at rng ty
-- | Input fields are reversed!
mkRecord :: AddLoc b => Range -> (RecordMap Ident (Range, a) -> b) -> [Named a] -> ParseM b
mkRecord rng f xs =
case res of
- Left (nm,(nmRng,_)) -> errorMessage nmRng ("Record has repeated field: " ++ show (pp nm))
+ Left (nm,(nmRng,_)) -> errorMessage nmRng ["Record has repeated field: " ++ show (pp nm)]
Right r -> pure $ at rng (f r)
where
@@ -280,11 +283,14 @@
-- | Input expression are reversed
-mkEApp :: [Expr PName] -> Expr PName
-mkEApp es@(eLast : _) = at (eFirst,eLast) $ foldl EApp f xs
+mkEApp :: NonEmpty (Expr PName) -> ParseM (Expr PName)
+
+mkEApp es@(eLast :| _) =
+ do f :| xs <- cvtTypeParams eFirst rest
+ pure (at (eFirst,eLast) $ foldl EApp f xs)
+
where
- eFirst : rest = reverse es
- f : xs = cvtTypeParams eFirst rest
+ eFirst :| rest = NE.reverse es
{- Type applications are parsed as `ETypeVal (TTyApp fs)` expressions.
Here we associate them with their corresponding functions,
@@ -293,23 +299,62 @@
[ f, x, `{ a = 2 }, y ]
becomes
[ f, x ` { a = 2 }, y ]
+
+ The parser associates field and tuple projectors that follow an
+ explicit type application onto the TTyApp term, so we also
+ have to unwind those projections and reapply them. For example:
+
+ [ f, x, `{ a = 2 }.f.2, y ]
+ becomes
+ [ f, (x`{ a = 2 }).f.2, y ]
+
-}
- cvtTypeParams e [] = [e]
+ cvtTypeParams e [] = pure (e :| [])
cvtTypeParams e (p : ps) =
- case toTypeParam p of
- Just fs -> cvtTypeParams (EAppT e fs) ps
- Nothing -> e : cvtTypeParams p ps
+ case toTypeParam p Nothing of
+ Nothing -> NE.cons e <$> cvtTypeParams p ps
- toTypeParam e =
- case dropLoc e of
- ETypeVal t -> case dropLoc t of
- TTyApp fs -> Just (map mkTypeInst fs)
- _ -> Nothing
- _ -> Nothing
+ Just (fs,ss,rng) ->
+ if checkAppExpr e then
+ let e' = foldr (flip ESel) (EAppT e fs) ss
+ e'' = case rCombMaybe (getLoc e) rng of
+ Just r -> ELocated e' r
+ Nothing -> e'
+ in cvtTypeParams e'' ps
+ else
+ errorMessage (fromMaybe emptyRange (getLoc e))
+ [ "Explicit type applications can only be applied to named values."
+ , "Unexpected: " ++ show (pp e)
+ ]
-mkEApp es = panic "[Parser] mkEApp" ["Unexpected:", show es]
+ {- Check if the given expression is a legal target for explicit type application.
+ This is basically only variables, but we also allow the parenthesis and
+ the phantom "located" AST node.
+ -}
+ checkAppExpr e =
+ case e of
+ ELocated e' _ -> checkAppExpr e'
+ EParens e' -> checkAppExpr e'
+ EVar{} -> True
+ _ -> False
+ {- Look under a potential chain of selectors to see if we have a TTyApp.
+ If so, return the ty app information and the collected selectors
+ to reapply.
+ -}
+ toTypeParam e mr =
+ case e of
+ ELocated e' rng -> toTypeParam e' (rCombMaybe mr (Just rng))
+ ETypeVal t -> toTypeParam' t mr
+ ESel e' s -> ( \(fs,ss,r) -> (fs,s:ss,r) ) <$> toTypeParam e' mr
+ _ -> Nothing
+ toTypeParam' t mr =
+ case t of
+ TLocated t' rng -> toTypeParam' t' (rCombMaybe mr (Just rng))
+ TTyApp fs -> Just (map mkTypeInst fs, [], mr)
+ _ -> Nothing
+
unOp :: Expr PName -> Expr PName -> Expr PName
unOp f x = at (f,x) $ EApp f x
@@ -325,12 +370,13 @@
(Nothing, Just (e2', t), Nothing) -> eFromToType r e1 (Just e2') e3 (Just t)
(Nothing, Nothing, Just (e3', t)) -> eFromToType r e1 e2 e3' (Just t)
(Nothing, Nothing, Nothing) -> eFromToType r e1 e2 e3 Nothing
- _ -> errorMessage r "A sequence enumeration may have at most one element type annotation."
- where
- asETyped (ELocated e _) = asETyped e
- asETyped (ETyped e t) = Just (e, t)
- asETyped _ = Nothing
+ _ -> errorMessage r ["A sequence enumeration may have at most one element type annotation."]
+asETyped :: Expr n -> Maybe (Expr n, Type n)
+asETyped (ELocated e _) = asETyped e
+asETyped (ETyped e t) = Just (e, t)
+asETyped _ = Nothing
+
eFromToType ::
Range -> Expr PName -> Maybe (Expr PName) -> Expr PName -> Maybe (Type PName) -> ParseM (Expr PName)
eFromToType r e1 e2 e3 t =
@@ -339,22 +385,40 @@
<*> exprToNumT r e3
<*> pure t
+eFromToLessThan ::
+ Range -> Expr PName -> Expr PName -> ParseM (Expr PName)
+eFromToLessThan r e1 e2 =
+ case asETyped e2 of
+ Just _ -> errorMessage r ["The exclusive upper bound of an enumeration may not have a type annotation."]
+ Nothing ->
+ case asETyped e1 of
+ Nothing -> eFromToLessThanType r e1 e2 Nothing
+ Just (e1',t) -> eFromToLessThanType r e1' e2 (Just t)
+
+eFromToLessThanType ::
+ Range -> Expr PName -> Expr PName -> Maybe (Type PName) -> ParseM (Expr PName)
+eFromToLessThanType r e1 e2 t =
+ EFromToLessThan
+ <$> exprToNumT r e1
+ <*> exprToNumT r e2
+ <*> pure t
+
exprToNumT :: Range -> Expr PName -> ParseM (Type PName)
exprToNumT r expr =
case translateExprToNumT expr of
Just t -> return t
Nothing -> bad
where
- bad = errorMessage (fromMaybe r (getLoc expr)) $ unlines
+ bad = errorMessage (fromMaybe r (getLoc expr))
[ "The boundaries of .. sequences should be valid numeric types."
- , "The expression `" ++ show expr ++ "` is not."
+ , "The expression `" ++ show (pp expr) ++ "` is not."
]
-- | WARNING: This is a bit of a hack.
-- It is used to represent anonymous type applications.
anonTyApp :: Maybe Range -> [Type PName] -> Type PName
-anonTyApp ~(Just r) ts = TTyApp (map toField ts)
+anonTyApp ~(Just r) ts = TLocated (TTyApp (map toField ts)) r
where noName = Located { srcRange = r, thing = mkIdent (T.pack "") }
toField t = Named { name = noName, value = t }
@@ -413,13 +477,13 @@
mkTParam :: Located Ident -> Maybe Kind -> ParseM (TParam PName)
mkTParam Located { srcRange = rng, thing = n } k
- | n == widthIdent = errorMessage rng "`width` is not a valid type parameter name."
+ | n == widthIdent = errorMessage rng ["`width` is not a valid type parameter name."]
| otherwise = return (TParam (mkUnqual n) k (Just rng))
mkTySyn :: Located PName -> [TParam PName] -> Type PName -> ParseM (Decl PName)
mkTySyn ln ps b
| getIdent (thing ln) == widthIdent =
- errorMessage (srcRange ln) "`width` is not a valid type synonym name."
+ errorMessage (srcRange ln) ["`width` is not a valid type synonym name."]
| otherwise =
return $ DType $ TySyn ln Nothing ps b
@@ -427,7 +491,7 @@
mkPropSyn :: Located PName -> [TParam PName] -> Type PName -> ParseM (Decl PName)
mkPropSyn ln ps b
| getIdent (thing ln) == widthIdent =
- errorMessage (srcRange ln) "`width` is not a valid constraint synonym name."
+ errorMessage (srcRange ln) ["`width` is not a valid constraint synonym name."]
| otherwise =
DProp . PropSyn ln Nothing ps . thing <$> mkProp b
@@ -436,12 +500,12 @@
polyTerm rng k p
| k == 0 = return (False, p)
| k == 1 = return (True, p)
- | otherwise = errorMessage rng "Invalid polynomial coefficient"
+ | otherwise = errorMessage rng ["Invalid polynomial coefficient"]
mkPoly :: Range -> [ (Bool,Integer) ] -> ParseM (Expr PName)
mkPoly rng terms
| w <= toInteger (maxBound :: Int) = mk 0 (map fromInteger bits)
- | otherwise = errorMessage rng ("Polynomial literal too large: " ++ show w)
+ | otherwise = errorMessage rng ["Polynomial literal too large: " ++ show w]
where
w = case terms of
@@ -455,8 +519,7 @@
mk res (n : ns)
| testBit res n = errorMessage rng
- ("Polynomial contains multiple terms with exponent "
- ++ show n)
+ ["Polynomial contains multiple terms with exponent " ++ show n]
| otherwise = mk (setBit res n) ns
@@ -495,11 +558,11 @@
mkIndexedExpr :: ([Pattern PName], [Pattern PName]) -> Expr PName -> Expr PName
mkIndexedExpr (ps, ixs) body
| null ps = mkGenerate (reverse ixs) body
- | otherwise = EFun (reverse ps) (mkGenerate (reverse ixs) body)
+ | otherwise = EFun emptyFunDesc (reverse ps) (mkGenerate (reverse ixs) body)
mkGenerate :: [Pattern PName] -> Expr PName -> Expr PName
mkGenerate pats body =
- foldr (\pat e -> EGenerate (EFun [pat] e)) body pats
+ foldr (\pat e -> EGenerate (EFun emptyFunDesc [pat] e)) body pats
mkIf :: [(Expr PName, Expr PName)] -> Expr PName -> Expr PName
mkIf ifThens theElse = foldr addIfThen theElse ifThens
@@ -540,17 +603,17 @@
Just (n,xs) ->
do vs <- mapM tpK as
unless (distinct (map fst vs)) $
- errorMessage schema_rng "Repeated parameters."
+ errorMessage schema_rng ["Repeated parameters."]
let kindMap = Map.fromList vs
lkp v = case Map.lookup (thing v) kindMap of
Just (k,tp) -> pure (k,tp)
Nothing ->
errorMessage
(srcRange v)
- ("Undefined parameter: " ++ show (pp (thing v)))
+ ["Undefined parameter: " ++ show (pp (thing v))]
(as',ins) <- unzip <$> mapM lkp xs
unless (length vs == length xs) $
- errorMessage schema_rng "All parameters should appear in the type."
+ errorMessage schema_rng ["All parameters should appear in the type."]
let ki = finK { thing = foldr KFun (thing finK) ins }
@@ -565,7 +628,7 @@
}
]
- Nothing -> errorMessage schema_rng "Invalid primitive signature"
+ Nothing -> errorMessage schema_rng ["Invalid primitive signature"]
where
splitT r ty = case ty of
@@ -592,7 +655,7 @@
Just k -> pure (tpName tp, (tp,k))
Nothing ->
case tpRange tp of
- Just r -> errorMessage r "Parameters need a kind annotation"
+ Just r -> errorMessage r ["Parameters need a kind annotation"]
Nothing -> panic "mkPrimTypeDecl"
[ "Missing range on schema parameter." ]
@@ -671,7 +734,7 @@
TTyApp{} -> err
where
- err = errorMessage r "Invalid constraint"
+ err = errorMessage r ["Invalid constraint"]
-- | Make an ordinary module
mkModule :: Located ModName ->
@@ -708,7 +771,7 @@
(UpdSet, [l]) | RecordSel i Nothing <- thing l ->
pure Named { name = l { thing = i }, value = e }
_ -> errorMessage (srcRange (head ls))
- "Invalid record field. Perhaps you meant to update a record?"
+ ["Invalid record field. Perhaps you meant to update a record?"]
exprToFieldPath :: Expr PName -> ParseM [Located Selector]
exprToFieldPath e0 = reverse <$> go noLoc e0
@@ -744,7 +807,7 @@
}
]
- _ -> errorMessage loc "Invalid label in record update."
+ _ -> errorMessage loc ["Invalid label in record update."]
mkSelector :: Token -> Selector
@@ -754,4 +817,3 @@
Selector (RecordSelectorTok t) -> RecordSel (mkIdent t) Nothing
_ -> panic "mkSelector"
[ "Unexpected selector token", show tok ]
-
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
@@ -57,6 +57,11 @@
where rFrom = min (from r1) (from r2)
rTo = max (to r1) (to r2)
+rCombMaybe :: Maybe Range -> Maybe Range -> Maybe Range
+rCombMaybe Nothing y = y
+rCombMaybe x Nothing = x
+rCombMaybe (Just x) (Just y) = Just (rComb x y)
+
rCombs :: [Range] -> Range
rCombs = foldl1 rComb
@@ -123,5 +128,4 @@
combLoc f l1 l2 = Located { srcRange = rComb (srcRange l1) (srcRange l2)
, thing = f (thing l1) (thing l2)
}
-
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
@@ -6,6 +6,8 @@
-- Stability : provisional
-- Portability : portable
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
@@ -34,7 +36,8 @@
, replCheckExpr
-- Check, SAT, and prove
- , qcCmd, QCMode(..)
+ , TestReport(..)
+ , qcExpr, qcCmd, QCMode(..)
, satCmd
, proveCmd
, onlineProveSat
@@ -72,6 +75,7 @@
import Cryptol.Parser
(parseExprWith,parseReplWith,ParseError(),Config(..),defaultConfig
,parseModName,parseHelpName)
+import Cryptol.Parser.Position (Position(..),Range(..),HasLoc(..))
import qualified Cryptol.TypeCheck.AST as T
import qualified Cryptol.TypeCheck.Error as T
import qualified Cryptol.TypeCheck.Parseable as T
@@ -135,7 +139,7 @@
-- | Commands.
data Command
- = Command (REPL ()) -- ^ Successfully parsed command
+ = Command (Int -> Maybe FilePath -> REPL ()) -- ^ Successfully parsed command
| Ambiguous String [String] -- ^ Ambiguous command, list of conflicting
-- commands
| Unknown String -- ^ The unknown command
@@ -159,8 +163,8 @@
compare = compare `on` cNames
data CommandBody
- = ExprArg (String -> REPL ())
- | FileExprArg (FilePath -> String -> REPL ())
+ = ExprArg (String -> (Int,Int) -> Maybe FilePath -> REPL ())
+ | FileExprArg (FilePath -> String -> (Int,Int) -> Maybe FilePath -> REPL ())
| DeclsArg (String -> REPL ())
| ExprTypeArg (String -> REPL ())
| ModNameArg (String -> REPL ())
@@ -214,10 +218,10 @@
, CommandDescr [ ":s", ":set" ] ["[ OPTION [ = VALUE ] ]"] (OptionArg setOptionCmd)
"Set an environmental option (:set on its own displays current values)."
""
- , CommandDescr [ ":check" ] ["[ EXPR ]"] (ExprArg (void . qcCmd QCRandom))
+ , CommandDescr [ ":check" ] ["[ EXPR ]"] (ExprArg (qcCmd QCRandom))
"Use random testing to check that the argument always returns true.\n(If no argument, check all properties.)"
""
- , CommandDescr [ ":exhaust" ] ["[ EXPR ]"] (ExprArg (void . qcCmd QCExhaust))
+ , CommandDescr [ ":exhaust" ] ["[ EXPR ]"] (ExprArg (qcCmd QCExhaust))
"Use exhaustive testing to prove that the argument always returns\ntrue. (If no argument, check all properties.)"
""
, CommandDescr [ ":prove" ] ["[ EXPR ]"] (ExprArg proveCmd)
@@ -295,10 +299,10 @@
-- Command Evaluation ----------------------------------------------------------
-- | Run a command.
-runCommand :: Command -> REPL CommandExitCode
-runCommand c = case c of
+runCommand :: Int -> Maybe FilePath -> Command -> REPL CommandExitCode
+runCommand lineNum mbBatch c = case c of
- Command cmd -> (cmd >> return CommandOk) `Cryptol.REPL.Monad.catch` handler
+ Command cmd -> (cmd lineNum mbBatch >> return CommandOk) `Cryptol.REPL.Monad.catch` handler
where
handler re = rPutStrLn "" >> rPrint (pp re) >> return CommandError
@@ -311,36 +315,9 @@
return CommandError
--- Get the setting we should use for displaying values.
-getPPValOpts :: REPL E.PPOpts
-getPPValOpts =
- do base <- getKnownUser "base"
- ascii <- getKnownUser "ascii"
- infLength <- getKnownUser "infLength"
-
- fpBase <- getKnownUser "fp-base"
- fpFmtTxt <- getKnownUser "fp-format"
- let fpFmt = case parsePPFloatFormat fpFmtTxt of
- Just f -> f
- Nothing -> panic "getPPValOpts"
- [ "Failed to parse fp-format" ]
-
- return E.PPOpts { E.useBase = base
- , E.useAscii = ascii
- , E.useInfLength = infLength
- , E.useFPBase = fpBase
- , E.useFPFormat = fpFmt
- }
-
-getEvalOpts :: REPL E.EvalOpts
-getEvalOpts =
- do ppOpts <- getPPValOpts
- l <- getLogger
- return E.EvalOpts { E.evalPPOpts = ppOpts, E.evalLogger = l }
-
-evalCmd :: String -> REPL ()
-evalCmd str = do
- ri <- replParseInput str
+evalCmd :: String -> Int -> Maybe FilePath -> REPL ()
+evalCmd str lineNum mbBatch = do
+ ri <- replParseInput str lineNum mbBatch
case ri of
P.ExprInput expr -> do
(val,_ty) <- replEvalExpr expr
@@ -363,27 +340,25 @@
-- comment or empty input does nothing
pure ()
-printCounterexample :: CounterExampleType -> P.Expr P.PName -> [Concrete.Value] -> REPL ()
-printCounterexample cexTy pexpr vs =
+printCounterexample :: CounterExampleType -> Doc -> [Concrete.Value] -> REPL ()
+printCounterexample cexTy exprDoc vs =
do ppOpts <- getPPValOpts
docs <- mapM (rEval . E.ppValue Concrete ppOpts) vs
- let doc = ppPrec 3 pexpr -- function application has precedence 3
- rPrint $ hang doc 2 (sep docs) <+>
+ rPrint $ hang exprDoc 2 (sep docs) <+>
case cexTy of
SafetyViolation -> text "~> ERROR"
PredicateFalsified -> text "= False"
-printSatisfyingModel :: P.Expr P.PName -> [Concrete.Value] -> REPL ()
-printSatisfyingModel pexpr vs =
+printSatisfyingModel :: Doc -> [Concrete.Value] -> REPL ()
+printSatisfyingModel exprDoc vs =
do ppOpts <- getPPValOpts
docs <- mapM (rEval . E.ppValue Concrete ppOpts) vs
- let doc = ppPrec 3 pexpr -- function application has precedence 3
- rPrint $ hang doc 2 (sep docs) <+> text ("= True")
+ rPrint $ hang exprDoc 2 (sep docs) <+> text ("= True")
-dumpTestsCmd :: FilePath -> String -> REPL ()
-dumpTestsCmd outFile str =
- do expr <- replParseExpr str
+dumpTestsCmd :: FilePath -> String -> (Int,Int) -> Maybe FilePath -> REPL ()
+dumpTestsCmd outFile str pos fnm =
+ do expr <- replParseExpr str pos fnm
(val, ty) <- replEvalExpr expr
ppopts <- getPPValOpts
testNum <- getKnownUser "tests" :: REPL Int
@@ -409,28 +384,54 @@
data QCMode = QCRandom | QCExhaust deriving (Eq, Show)
+
-- | Randomly test a property, or exhaustively check it if the number
-- of values in the type under test is smaller than the @tests@
-- environment variable, or we specify exhaustive testing.
-qcCmd :: QCMode -> String -> REPL [TestReport]
-qcCmd qcMode "" =
+qcCmd :: QCMode -> String -> (Int,Int) -> Maybe FilePath -> REPL ()
+qcCmd qcMode "" _pos _fnm =
do (xs,disp) <- getPropertyNames
let nameStr x = show (fixNameDisp disp (pp x))
if null xs
- then rPutStrLn "There are no properties in scope." *> return []
- else concat <$> (forM xs $ \x ->
+ then rPutStrLn "There are no properties in scope."
+ else forM_ xs $ \(x,d) ->
do let str = nameStr x
rPutStr $ "property " ++ str ++ " "
- qcCmd qcMode str)
+ let texpr = T.EVar x
+ let schema = M.ifDeclSig d
+ nd <- M.mctxNameDisp <$> getFocusedEnv
+ let doc = fixNameDisp nd (pp texpr)
+ void (qcExpr qcMode doc texpr schema)
-qcCmd qcMode str =
- do expr <- replParseExpr str
- (val,ty) <- replEvalExpr expr
+qcCmd qcMode str pos fnm =
+ do expr <- replParseExpr str pos fnm
+ (_,texpr,schema) <- replCheckExpr expr
+ nd <- M.mctxNameDisp <$> getFocusedEnv
+ let doc = fixNameDisp nd (ppPrec 3 expr) -- function application has precedence 3
+ void (qcExpr qcMode doc texpr schema)
+
+
+data TestReport = TestReport
+ { reportExpr :: Doc
+ , reportResult :: TestResult
+ , reportTestsRun :: Integer
+ , reportTestsPossible :: Maybe Integer
+ }
+
+qcExpr ::
+ QCMode ->
+ Doc ->
+ T.Expr ->
+ T.Schema ->
+ REPL TestReport
+qcExpr qcMode exprDoc texpr schema =
+ do (val,ty) <- replEvalCheckedExpr texpr schema
testNum <- (toInteger :: Int -> Integer) <$> getKnownUser "tests"
tenv <- E.envTypes . M.deEnv <$> getDynEnv
let tyv = E.evalValType tenv ty
percentRef <- io $ newIORef Nothing
testsRef <- io $ newIORef 0
+
case testableType tyv of
Just (Just sz,tys,vss,_gens) | qcMode == QCExhaust || sz <= testNum -> do
rPutStrLn "Using exhaustive testing."
@@ -440,15 +441,15 @@
val vss)
(\ex -> do rPutStrLn "\nTest interrupted..."
num <- io $ readIORef testsRef
- let report = TestReport Pass str num (Just sz)
- ppReport (map E.tValTy tys) expr False report
+ let report = TestReport exprDoc Pass num (Just sz)
+ ppReport tys False report
rPutStrLn $ interruptedExhaust num sz
Ex.throwM (ex :: Ex.SomeException))
- let report = TestReport res str num (Just sz)
+ let report = TestReport exprDoc res num (Just sz)
delProgress
delTesting
- ppReport (map E.tValTy tys) expr True report
- return [report]
+ ppReport tys True report
+ return report
Just (sz,tys,_,gens) | qcMode == QCRandom -> do
rPutStrLn "Using random testing."
@@ -459,20 +460,20 @@
testNum val gens g)
(\ex -> do rPutStrLn "\nTest interrupted..."
num <- io $ readIORef testsRef
- let report = TestReport Pass str num sz
- ppReport (map E.tValTy tys) expr False report
+ let report = TestReport exprDoc Pass num sz
+ ppReport tys False report
case sz of
Just n -> rPutStrLn $ coverageString num n
_ -> return ()
Ex.throwM (ex :: Ex.SomeException))
- let report = TestReport res str num sz
+ let report = TestReport exprDoc res num sz
delProgress
delTesting
- ppReport (map E.tValTy tys) expr False report
+ ppReport tys False report
case sz of
Just n | isPass res -> rPutStrLn $ coverageString testNum n
_ -> return ()
- return [report]
+ return report
_ -> raise (TypeNotTestable ty)
where
@@ -502,7 +503,6 @@
++ showValNum
++ " values)"
-
totProgressWidth = 4 -- 100%
lg2 :: Integer -> Integer
@@ -512,7 +512,6 @@
in round $ logBase 2 valNumD :: Integer
prt msg = rPutStr msg >> io (hFlush stdout)
- prtLn msg = rPutStrLn msg >> io (hFlush stdout)
ppProgress percentRef testsRef this tot =
do io $ writeIORef testsRef this
@@ -536,34 +535,45 @@
delTesting = del (length testingMsg)
delProgress = del totProgressWidth
- ppReport _tys _expr isExhaustive (TestReport Pass _str testNum _testPossible) =
- do prtLn $ "Passed " ++ show testNum ++ " tests."
+
+ppReport :: [E.TValue] -> Bool -> TestReport -> REPL ()
+ppReport _tys isExhaustive (TestReport _exprDoc Pass testNum _testPossible) =
+ do rPutStrLn ("Passed " ++ show testNum ++ " tests.")
when isExhaustive (rPutStrLn "Q.E.D.")
- ppReport tys expr _ (TestReport failure _str _testNum _testPossible) =
- ppFailure tys expr failure
+ppReport tys _ (TestReport exprDoc failure _testNum _testPossible) =
+ do ppFailure tys exprDoc failure
- ppFailure tys pexpr failure = do
- opts <- getPPValOpts
- case failure of
- FailFalse vs -> do
- printCounterexample PredicateFalsified pexpr vs
- case (tys,vs) of
- ([t],[v]) -> bindItVariableVal t v
- _ -> let fs = [ M.packIdent ("arg" ++ show (i::Int)) | i <- [ 1 .. ] ]
- t = T.TRec (recordFromFields (zip fs tys))
- v = E.VRecord (recordFromFields (zip fs (map return vs)))
- in bindItVariableVal t v
+ppFailure :: [E.TValue] -> Doc -> TestResult -> REPL ()
+ppFailure tys exprDoc failure = do
+ ~(EnvBool showEx) <- getUser "showExamples"
- FailError err [] -> do
- prtLn "ERROR"
- rPrint (pp err)
- FailError err vs -> do
- prtLn "ERROR for the following inputs:"
- mapM_ (\v -> rPrint =<< (rEval $ E.ppValue Concrete opts v)) vs
- rPrint (pp err)
- Pass -> panic "Cryptol.REPL.Command" ["unexpected Test.Pass"]
+ vs <- case failure of
+ FailFalse vs ->
+ do rPutStrLn "Counterexample"
+ when showEx (printCounterexample PredicateFalsified exprDoc vs)
+ pure vs
+ FailError err vs
+ | null vs || not showEx ->
+ do rPutStrLn "ERROR"
+ rPrint (pp err)
+ pure vs
+ | otherwise ->
+ do rPutStrLn "ERROR for the following inputs:"
+ printCounterexample SafetyViolation exprDoc vs
+ rPrint (pp err)
+ pure vs
+ Pass -> panic "Cryptol.REPL.Command" ["unexpected Test.Pass"]
+ -- bind the 'it' variable
+ case (tys,vs) of
+ ([t],[v]) -> bindItVariableVal t v
+ _ -> let fs = [ M.packIdent ("arg" ++ show (i::Int)) | i <- [ 1 .. ] ]
+ t = E.TVRec (recordFromFields (zip fs tys))
+ v = E.VRecord (recordFromFields (zip fs (map return vs)))
+ in bindItVariableVal t v
+
+
-- | This function computes the expected coverage percentage and
-- expected number of unique test vectors when using random testing.
--
@@ -606,7 +616,7 @@
proportion = negate (expm1 (numD * log1p (negate (recip szD))))
-satCmd, proveCmd :: String -> REPL ()
+satCmd, proveCmd :: String -> (Int,Int) -> Maybe FilePath -> REPL ()
satCmd = cmdProveSat True
proveCmd = cmdProveSat False
@@ -628,16 +638,22 @@
]
-- | Attempts to prove the given term is safe for all inputs
-safeCmd :: String -> REPL ()
-safeCmd str = do
+safeCmd :: String -> (Int,Int) -> Maybe FilePath -> REPL ()
+safeCmd str pos fnm = do
proverName <- getKnownUser "prover"
- fileName <- getKnownUser "smtfile"
+ fileName <- getKnownUser "smtFile"
let mfile = if fileName == "-" then Nothing else Just fileName
+ pexpr <- replParseExpr str pos fnm
+ nd <- M.mctxNameDisp <$> getFocusedEnv
+ let exprDoc = fixNameDisp nd (ppPrec 3 pexpr) -- function application has precedence 3
+ let rng = fromMaybe (mkInteractiveRange pos fnm) (getLoc pexpr)
+ (_,texpr,schema) <- replCheckExpr pexpr
+
if proverName `elem` ["offline","sbv-offline","w4-offline"] then
- offlineProveSat proverName SafetyQuery str mfile
+ offlineProveSat proverName SafetyQuery texpr schema mfile
else
- do (firstProver,result,stats) <- rethrowErrorCall (onlineProveSat proverName SafetyQuery str mfile)
+ do (firstProver,result,stats) <- rethrowErrorCall (onlineProveSat proverName SafetyQuery texpr schema mfile)
case result of
EmptyResult ->
panic "REPL.Command" [ "got EmptyResult for online prover query" ]
@@ -651,11 +667,11 @@
let tes = map ( \(t,e,_) -> (t,e)) tevs
vs = map ( \(_,_,v) -> v) tevs
- (t,e) <- mkSolverResult "counterexample" False (Right tes)
- pexpr <- replParseExpr str
+ (t,e) <- mkSolverResult "counterexample" rng False (Right tes)
- ~(EnvBool yes) <- getUser "show-examples"
- when yes $ printCounterexample cexType pexpr vs
+ ~(EnvBool yes) <- getUser "showExamples"
+ when yes $ printCounterexample cexType exprDoc vs
+ when yes $ printSafetyViolation texpr schema vs
void $ bindItVariable t e
@@ -670,30 +686,50 @@
-- console, and binds the @it@ variable to a record whose form depends
-- on the expression given. See ticket #66 for a discussion of this
-- design.
-cmdProveSat :: Bool -> String -> REPL ()
-cmdProveSat isSat "" =
+cmdProveSat :: Bool -> String -> (Int,Int) -> Maybe FilePath -> REPL ()
+cmdProveSat isSat "" _pos _fnm =
do (xs,disp) <- getPropertyNames
let nameStr x = show (fixNameDisp disp (pp x))
if null xs
then rPutStrLn "There are no properties in scope."
- else forM_ xs $ \x ->
+ else forM_ xs $ \(x,d) ->
do let str = nameStr x
if isSat
then rPutStr $ ":sat " ++ str ++ "\n\t"
else rPutStr $ ":prove " ++ str ++ "\n\t"
- cmdProveSat isSat str
-cmdProveSat isSat str = do
+ let texpr = T.EVar x
+ let schema = M.ifDeclSig d
+ nd <- M.mctxNameDisp <$> getFocusedEnv
+ let doc = fixNameDisp nd (pp texpr)
+ proveSatExpr isSat (M.nameLoc x) doc texpr schema
+
+cmdProveSat isSat str pos fnm = do
+ pexpr <- replParseExpr str pos fnm
+ nd <- M.mctxNameDisp <$> getFocusedEnv
+ let doc = fixNameDisp nd (ppPrec 3 pexpr) -- function application has precedence 3
+ (_,texpr,schema) <- replCheckExpr pexpr
+ let rng = fromMaybe (mkInteractiveRange pos fnm) (getLoc pexpr)
+ proveSatExpr isSat rng doc texpr schema
+
+proveSatExpr ::
+ Bool ->
+ Range ->
+ Doc ->
+ T.Expr ->
+ T.Schema ->
+ REPL ()
+proveSatExpr isSat rng exprDoc texpr schema = do
let cexStr | isSat = "satisfying assignment"
| otherwise = "counterexample"
qtype <- if isSat then SatQuery <$> getUserSatNum else pure ProveQuery
proverName <- getKnownUser "prover"
- fileName <- getKnownUser "smtfile"
+ fileName <- getKnownUser "smtFile"
let mfile = if fileName == "-" then Nothing else Just fileName
if proverName `elem` ["offline","sbv-offline","w4-offline"] then
- offlineProveSat proverName qtype str mfile
+ offlineProveSat proverName qtype texpr schema mfile
else
- do (firstProver,result,stats) <- rethrowErrorCall (onlineProveSat proverName qtype str mfile)
+ do (firstProver,result,stats) <- rethrowErrorCall (onlineProveSat proverName qtype texpr schema mfile)
case result of
EmptyResult ->
panic "REPL.Command" [ "got EmptyResult for online prover query" ]
@@ -702,7 +738,7 @@
ThmResult ts -> do
rPutStrLn (if isSat then "Unsatisfiable" else "Q.E.D.")
- (t, e) <- mkSolverResult cexStr (not isSat) (Left ts)
+ (t, e) <- mkSolverResult cexStr rng (not isSat) (Left ts)
void $ bindItVariable t e
CounterExample cexType tevs -> do
@@ -710,19 +746,24 @@
let tes = map ( \(t,e,_) -> (t,e)) tevs
vs = map ( \(_,_,v) -> v) tevs
- (t,e) <- mkSolverResult cexStr isSat (Right tes)
- pexpr <- replParseExpr str
+ (t,e) <- mkSolverResult cexStr rng isSat (Right tes)
- ~(EnvBool yes) <- getUser "show-examples"
- when yes $ printCounterexample cexType pexpr vs
+ ~(EnvBool yes) <- getUser "showExamples"
+ when yes $ printCounterexample cexType exprDoc vs
+ -- if there's a safety violation, evalute the counterexample to
+ -- find and print the actual concrete error
+ case cexType of
+ SafetyViolation -> when yes $ printSafetyViolation texpr schema vs
+ _ -> return ()
+
void $ bindItVariable t e
AllSatResult tevss -> do
rPutStrLn "Satisfiable"
let tess = map (map $ \(t,e,_) -> (t,e)) tevss
vss = map (map $ \(_,_,v) -> v) tevss
- resultRecs <- mapM (mkSolverResult cexStr isSat . Right) tess
+ resultRecs <- mapM (mkSolverResult cexStr rng isSat . Right) tess
let collectTes tes = (t, es)
where
(ts, es) = unzip tes
@@ -736,32 +777,42 @@
[ "no satisfying assignments after mkSolverResult" ]
[(t, e)] -> (t, [e])
_ -> collectTes resultRecs
- pexpr <- replParseExpr str
- ~(EnvBool yes) <- getUser "show-examples"
- when yes $ forM_ vss (printSatisfyingModel pexpr)
+ ~(EnvBool yes) <- getUser "showExamples"
+ when yes $ forM_ vss (printSatisfyingModel exprDoc)
- case (ty, exprs) of
- (t, [e]) -> void $ bindItVariable t e
- (t, es ) -> bindItVariables t es
+ case exprs of
+ [e] -> void $ bindItVariable ty e
+ _ -> bindItVariables ty exprs
seeStats <- getUserShowProverStats
when seeStats (showProverStats firstProver stats)
-onlineProveSat :: String
- -> QueryType
- -> String -> Maybe FilePath
- -> REPL (Maybe String,ProverResult,ProverStats)
-onlineProveSat proverName qtype str mfile = do
+
+printSafetyViolation :: T.Expr -> T.Schema -> [E.GenValue Concrete] -> REPL ()
+printSafetyViolation texpr schema vs =
+ catch
+ (do (fn,_) <- replEvalCheckedExpr texpr schema
+ rEval (E.forceValue =<< foldM (\f v -> E.fromVFun Concrete f (pure v)) fn vs))
+ (\case
+ EvalError eex -> rPutStrLn (show (pp eex))
+ ex -> raise ex)
+
+onlineProveSat ::
+ String ->
+ QueryType ->
+ T.Expr ->
+ T.Schema ->
+ Maybe FilePath ->
+ REPL (Maybe String,ProverResult,ProverStats)
+onlineProveSat proverName qtype expr schema mfile = do
verbose <- getKnownUser "debug"
modelValidate <- getUserProverValidate
- parseExpr <- replParseExpr str
- (_, expr, schema) <- replCheckExpr parseExpr
validEvalContext expr
validEvalContext schema
decls <- fmap M.deDecls getDynEnv
timing <- io (newIORef 0)
- ~(EnvBool ignoreSafety) <- getUser "ignore-safety"
+ ~(EnvBool ignoreSafety) <- getUser "ignoreSafety"
let cmd = ProverCommand {
pcQueryType = qtype
, pcProverName = proverName
@@ -777,22 +828,21 @@
(firstProver, res) <- getProverConfig >>= \case
Left sbvCfg -> liftModuleCmd $ SBV.satProve sbvCfg cmd
Right w4Cfg ->
- do ~(EnvBool hashConsing) <- getUser "hash-consing"
+ do ~(EnvBool hashConsing) <- getUser "hashConsing"
~(EnvBool warnUninterp) <- getUser "warnUninterp"
liftModuleCmd $ W4.satProve w4Cfg hashConsing warnUninterp cmd
stas <- io (readIORef timing)
return (firstProver,res,stas)
-offlineProveSat :: String -> QueryType -> String -> Maybe FilePath -> REPL ()
-offlineProveSat proverName qtype str mfile = do
+offlineProveSat :: String -> QueryType -> T.Expr -> T.Schema -> Maybe FilePath -> REPL ()
+offlineProveSat proverName qtype expr schema mfile = do
verbose <- getKnownUser "debug"
modelValidate <- getUserProverValidate
- parseExpr <- replParseExpr str
- (_, expr, schema) <- replCheckExpr parseExpr
+
decls <- fmap M.deDecls getDynEnv
timing <- io (newIORef 0)
- ~(EnvBool ignoreSafety) <- getUser "ignore-safety"
+ ~(EnvBool ignoreSafety) <- getUser "ignoreSafety"
let cmd = ProverCommand {
pcQueryType = qtype
, pcProverName = proverName
@@ -832,7 +882,7 @@
Nothing -> rPutStr smtlib
Right w4Cfg ->
- do ~(EnvBool hashConsing) <- getUser "hash-consing"
+ do ~(EnvBool hashConsing) <- getUser "hashConsing"
~(EnvBool warnUninterp) <- getUser "warnUninterp"
result <- liftModuleCmd $ W4.satProveOffline w4Cfg hashConsing warnUninterp cmd $ \f ->
do displayMsg
@@ -855,13 +905,15 @@
-- | Make a type/expression pair that is suitable for binding to @it@
-- after running @:sat@ or @:prove@
-mkSolverResult :: String
- -> Bool
- -> Either [T.Type] [(T.Type, T.Expr)]
- -> REPL (T.Type, T.Expr)
-mkSolverResult thing result earg =
+mkSolverResult ::
+ String ->
+ Range ->
+ Bool ->
+ Either [E.TValue] [(E.TValue, T.Expr)] ->
+ REPL (E.TValue, T.Expr)
+mkSolverResult thing rng result earg =
do prims <- getPrimMap
- let addError t = (t, T.eError prims t ("no " ++ thing ++ " available"))
+ let addError t = (t, T.ELocated rng (T.eError prims (E.tValTy t) ("no " ++ thing ++ " available")))
argF = case earg of
Left ts -> mkArgs (map addError ts)
@@ -871,7 +923,7 @@
eFalse = T.ePrim prims (M.prelPrim "False")
resultE = if result then eTrue else eFalse
- rty = T.TRec (recordFromFields $ [(rIdent, T.tBit )] ++ map fst argF)
+ rty = E.TVRec (recordFromFields $ [(rIdent, E.TVBit)] ++ map fst argF)
re = T.ERec (recordFromFields $ [(rIdent, resultE)] ++ map snd argF)
return (rty, re)
@@ -882,9 +934,9 @@
let argName = M.packIdent ("arg" ++ show n)
in ((argName,t),(argName,e))
-specializeCmd :: String -> REPL ()
-specializeCmd str = do
- parseExpr <- replParseExpr str
+specializeCmd :: String -> (Int,Int) -> Maybe FilePath -> REPL ()
+specializeCmd str pos fnm = do
+ parseExpr <- replParseExpr str pos fnm
(_, expr, schema) <- replCheckExpr parseExpr
spexpr <- replSpecExpr expr
rPutStrLn "Expression type:"
@@ -894,9 +946,9 @@
rPutStrLn "Specialized expression:"
rPutStrLn $ dump spexpr
-refEvalCmd :: String -> REPL ()
-refEvalCmd str = do
- parseExpr <- replParseExpr str
+refEvalCmd :: String -> (Int,Int) -> Maybe FilePath -> REPL ()
+refEvalCmd str pos fnm = do
+ parseExpr <- replParseExpr str pos fnm
(_, expr, schema) <- replCheckExpr parseExpr
validEvalContext expr
validEvalContext schema
@@ -904,9 +956,9 @@
opts <- getPPValOpts
rPrint $ R.ppEValue opts val
-astOfCmd :: String -> REPL ()
-astOfCmd str = do
- expr <- replParseExpr str
+astOfCmd :: String -> (Int,Int) -> Maybe FilePath -> REPL ()
+astOfCmd str pos fnm = do
+ expr <- replParseExpr str pos fnm
(re,_,_) <- replCheckExpr (P.noPos expr)
rPrint (fmap M.nameUnique re)
@@ -915,10 +967,10 @@
me <- getModuleEnv
rPrint $ T.showParseable $ concatMap T.mDecls $ M.loadedModules me
-typeOfCmd :: String -> REPL ()
-typeOfCmd str = do
+typeOfCmd :: String -> (Int,Int) -> Maybe FilePath -> REPL ()
+typeOfCmd str pos fnm = do
- expr <- replParseExpr str
+ expr <- replParseExpr str pos fnm
(_re,def,sig) <- replCheckExpr expr
-- XXX need more warnings from the module system
@@ -942,7 +994,7 @@
let t = T.tWord (T.tNum (toInteger len * 8))
let x = T.EProofApp (T.ETApp (T.ETApp number (T.tNum val)) t)
let expr = T.EApp f x
- void $ bindItVariable (T.tString len) expr
+ void $ bindItVariable (E.TVSeq (toInteger len) (E.TVSeq 8 E.TVBit)) expr
-- | Convert a 'ByteString' (big-endian) of length @n@ to an 'Integer'
-- with @8*n@ bits. This function uses a balanced binary fold to
@@ -963,9 +1015,9 @@
x1 = byteStringToInteger bs1
x2 = byteStringToInteger bs2
-writeFileCmd :: FilePath -> String -> REPL ()
-writeFileCmd file str = do
- expr <- replParseExpr str
+writeFileCmd :: FilePath -> String -> (Int,Int) -> Maybe FilePath -> REPL ()
+writeFileCmd file str pos fnm = do
+ expr <- replParseExpr str pos fnm
(val,ty) <- replEvalExpr expr
if not (tIsByteSeq ty)
then rPrint $ "Cannot write expression of types other than [n][8]."
@@ -990,10 +1042,10 @@
rEval :: E.Eval a -> REPL a
-rEval m = io (E.runEval m)
+rEval m = io (E.runEval mempty m)
rEvalRethrow :: E.Eval a -> REPL a
-rEvalRethrow m = io $ rethrowEvalError $ E.runEval m
+rEvalRethrow m = io $ rethrowEvalError $ E.runEval mempty m
reloadCmd :: REPL ()
reloadCmd = do
@@ -1348,9 +1400,9 @@
| null cmd = mapM_ rPutStrLn (genHelp commandList)
| cmd0 : args <- words cmd, ":" `isPrefixOf` cmd0 =
case findCommandExact cmd0 of
- [] -> void $ runCommand (Unknown cmd0)
+ [] -> void $ runCommand 1 Nothing (Unknown cmd0)
[c] -> showCmdHelp c args
- cs -> void $ runCommand (Ambiguous cmd0 (concatMap cNames cs))
+ cs -> void $ runCommand 1 Nothing (Ambiguous cmd0 (concatMap cNames cs))
| otherwise =
case parseHelpName cmd of
Just qname ->
@@ -1557,12 +1609,34 @@
Right a -> return a
Left e -> raise (ParseError e)
-replParseInput :: String -> REPL (P.ReplInput P.PName)
-replParseInput = replParse (parseReplWith interactiveConfig . T.pack)
+replParseInput :: String -> Int -> Maybe FilePath -> REPL (P.ReplInput P.PName)
+replParseInput str lineNum fnm = replParse (parseReplWith cfg . T.pack) str
+ where
+ cfg = case fnm of
+ Nothing -> interactiveConfig{ cfgStart = Position lineNum 1 }
+ Just f -> defaultConfig
+ { cfgSource = f
+ , cfgStart = Position lineNum 1
+ }
-replParseExpr :: String -> REPL (P.Expr P.PName)
-replParseExpr = replParse (parseExprWith interactiveConfig . T.pack)
+replParseExpr :: String -> (Int,Int) -> Maybe FilePath -> REPL (P.Expr P.PName)
+replParseExpr str (l,c) fnm = replParse (parseExprWith cfg. T.pack) str
+ where
+ cfg = case fnm of
+ Nothing -> interactiveConfig{ cfgStart = Position l c }
+ Just f -> defaultConfig
+ { cfgSource = f
+ , cfgStart = Position l c
+ }
+mkInteractiveRange :: (Int,Int) -> Maybe FilePath -> Range
+mkInteractiveRange (l,c) mb = Range p p src
+ where
+ p = Position l c
+ src = case mb of
+ Nothing -> ""
+ Just b -> b
+
interactiveConfig :: Config
interactiveConfig = defaultConfig { cfgSource = "" }
@@ -1571,9 +1645,19 @@
liftModuleCmd :: M.ModuleCmd a -> REPL a
liftModuleCmd cmd =
- do evo <- getEvalOpts
+ do evo <- getEvalOptsAction
env <- getModuleEnv
- moduleCmdResult =<< io (cmd (evo, BS.readFile, env))
+ callStacks <- getCallStacks
+ let cfg = M.meSolverConfig env
+ let minp s =
+ M.ModuleInput
+ { minpCallStacks = callStacks
+ , minpEvalOpts = evo
+ , minpByteReader = BS.readFile
+ , minpModuleEnv = env
+ , minpTCSolver = s
+ }
+ moduleCmdResult =<< io (SMT.withSolver cfg (cmd . minp))
moduleCmdResult :: M.ModuleRes a -> REPL a
moduleCmdResult (res,ws0) = do
@@ -1644,8 +1728,13 @@
replEvalExpr :: P.Expr P.PName -> REPL (Concrete.Value, T.Type)
replEvalExpr expr =
do (_,def,sig) <- replCheckExpr expr
- validEvalContext def
+ replEvalCheckedExpr def sig
+
+replEvalCheckedExpr :: T.Expr -> T.Schema -> REPL (Concrete.Value, T.Type)
+replEvalCheckedExpr def sig =
+ do validEvalContext def
validEvalContext sig
+
me <- getModuleEnv
let cfg = M.meSolverConfig me
mbDef <- io $ SMT.withSolver cfg (\s -> defaultReplExpr s def sig)
@@ -1658,12 +1747,20 @@
let su = T.listParamSubst tys
return (def1, T.apSubst su (T.sType sig))
+ whenDebug (rPutStrLn (dump def1))
+
+ tenv <- E.envTypes . M.deEnv <$> getDynEnv
+ let tyv = E.evalValType tenv ty
+
-- add "it" to the namespace via a new declaration
- itVar <- bindItVariable ty def1
+ itVar <- bindItVariable tyv def1
+ let itExpr = case getLoc def of
+ Nothing -> T.EVar itVar
+ Just rng -> T.ELocated rng (T.EVar itVar)
+
-- evaluate the it variable
- val <- liftModuleCmd (rethrowEvalError . M.evalExpr (T.EVar itVar))
- whenDebug (rPutStrLn (dump def1))
+ val <- liftModuleCmd (rethrowEvalError . M.evalExpr itExpr)
return (val,ty)
where
warnDefaults ts =
@@ -1692,12 +1789,12 @@
-- | Creates a fresh binding of "it" to the expression given, and adds
-- it to the current dynamic environment. The fresh name generated
-- is returned.
-bindItVariable :: T.Type -> T.Expr -> REPL T.Name
+bindItVariable :: E.TValue -> T.Expr -> REPL T.Name
bindItVariable ty expr = do
freshIt <- freshName itIdent M.UserName
let schema = T.Forall { T.sVars = []
, T.sProps = []
- , T.sType = ty
+ , T.sType = E.tValTy ty
}
decl = T.Decl { T.dName = freshIt
, T.dSignature = schema
@@ -1718,7 +1815,7 @@
-- | Extend the dynamic environment with a fresh binding for "it",
-- as defined by the given value. If we cannot determine the definition
-- of the value, then we don't bind `it`.
-bindItVariableVal :: T.Type -> Concrete.Value -> REPL ()
+bindItVariableVal :: E.TValue -> Concrete.Value -> REPL ()
bindItVariableVal ty val =
do prims <- getPrimMap
mb <- rEval (Concrete.toExpr prims ty val)
@@ -1730,12 +1827,12 @@
-- | Creates a fresh binding of "it" to a finite sequence of
-- expressions of the same type, and adds that sequence to the current
-- dynamic environment
-bindItVariables :: T.Type -> [T.Expr] -> REPL ()
+bindItVariables :: E.TValue -> [T.Expr] -> REPL ()
bindItVariables ty exprs = void $ bindItVariable seqTy seqExpr
where
len = length exprs
- seqTy = T.tSeq (T.tNum len) ty
- seqExpr = T.EList exprs ty
+ seqTy = E.TVSeq (toInteger len) ty
+ seqExpr = T.EList exprs (E.tValTy ty)
replEvalDecl :: P.Decl P.PName -> REPL ()
replEvalDecl decl = do
@@ -1770,19 +1867,26 @@
trim = sanitizeEnd . sanitize
-- | Split at the first word boundary.
-splitCommand :: String -> Maybe (String,String)
-splitCommand txt =
- case sanitize txt of
- ':' : more
+splitCommand :: String -> Maybe (Int,String,String)
+splitCommand = go 0
+ where
+ go !len (c : more)
+ | isSpace c = go (len+1) more
+
+ go !len (':': more)
| (as,bs) <- span (\x -> isPunctuation x || isSymbol x) more
- , not (null as) -> Just (':' : as, sanitize bs)
+ , (ws,cs) <- span isSpace bs
+ , not (null as) = Just (len+1+length as+length ws, ':' : as, cs)
| (as,bs) <- break isSpace more
- , not (null as) -> Just (':' : as, sanitize bs)
+ , (ws,cs) <- span isSpace bs
+ , not (null as) = Just (len+1+length as+length ws, ':' : as, cs)
- | otherwise -> Nothing
+ | otherwise = Nothing
- expr -> guard (not (null expr)) >> return (expr,[])
+ go !len expr
+ | null expr = Nothing
+ | otherwise = Just (len+length expr, expr, [])
-- | Uncons a list.
uncons :: [a] -> Maybe (a,[a])
@@ -1807,23 +1911,24 @@
-- | Parse a line as a command.
parseCommand :: (String -> [CommandDescr]) -> String -> Maybe Command
parseCommand findCmd line = do
- (cmd,args) <- splitCommand line
+ (cmdLen,cmd,args) <- splitCommand line
let args' = sanitizeEnd args
case findCmd cmd of
[c] -> case cBody c of
- ExprArg body -> Just (Command (body args'))
- DeclsArg body -> Just (Command (body args'))
- ExprTypeArg body -> Just (Command (body args'))
- ModNameArg body -> Just (Command (body args'))
- FilenameArg body -> Just (Command (body =<< expandHome args'))
- OptionArg body -> Just (Command (body args'))
- ShellArg body -> Just (Command (body args'))
- HelpArg body -> Just (Command (body args'))
- NoArg body -> Just (Command body)
+ ExprArg body -> Just (Command \l fp -> (body args' (l,cmdLen+1) fp))
+ DeclsArg body -> Just (Command \_ _ -> (body args'))
+ ExprTypeArg body -> Just (Command \_ _ -> (body args'))
+ ModNameArg body -> Just (Command \_ _ -> (body args'))
+ FilenameArg body -> Just (Command \_ _ -> (body =<< expandHome args'))
+ OptionArg body -> Just (Command \_ _ -> (body args'))
+ ShellArg body -> Just (Command \_ _ -> (body args'))
+ HelpArg body -> Just (Command \_ _ -> (body args'))
+ NoArg body -> Just (Command \_ _ -> body)
FileExprArg body ->
- case extractFilePath args' of
- Just (fp,expr) -> Just (Command (expandHome fp >>= flip body expr))
- Nothing -> Nothing
+ do (fpLen,fp,expr) <- extractFilePath args'
+ Just (Command \l fp' -> do let col = cmdLen + fpLen + 1
+ hm <- expandHome fp
+ body hm expr (l,col) fp')
[] -> case uncons cmd of
Just (':',_) -> Just (Unknown cmd)
Just _ -> Just (Command (evalCmd line))
@@ -1839,9 +1944,10 @@
_ -> return path
extractFilePath ipt =
- let quoted q = (\(a,b) -> (a, drop 1 b)) . break (== q)
+ let quoted q = (\(a,b) -> (length a + 2, a, drop 1 b)) . break (== q)
in case ipt of
"" -> Nothing
'\'':rest -> Just $ quoted '\'' rest
'"':rest -> Just $ quoted '"' rest
- _ -> Just $ break isSpace ipt
+ _ -> let (a,b) = break isSpace ipt in
+ if null a then Nothing else Just (length a, a, b)
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
@@ -35,8 +35,11 @@
, getFocusedEnv
, getModuleEnv, setModuleEnv
, getDynEnv, setDynEnv
+ , getCallStacks
, uniqify, freshName
, whenDebug
+ , getEvalOptsAction
+ , getPPValOpts
, getExprNames
, getTypeNames
, getPropertyNames
@@ -57,6 +60,7 @@
, OptionDescr(..)
, setUser, getUser, getKnownUser, tryGetUser
, userOptions
+ , userOptionsWithAliases
, getUserSatNum
, getUserShowProverStats
, getUserProverValidate
@@ -76,7 +80,7 @@
import Cryptol.REPL.Trie
-import Cryptol.Eval (EvalError, Unsupported)
+import Cryptol.Eval (EvalErrorEx, Unsupported, WordTooWide,EvalOpts(..))
import qualified Cryptol.ModuleSystem as M
import qualified Cryptol.ModuleSystem.Env as M
import qualified Cryptol.ModuleSystem.Name as M
@@ -96,7 +100,6 @@
import Cryptol.Symbolic (SatNum(..))
import Cryptol.Symbolic.SBV (SBVPortfolioException)
import Cryptol.Symbolic.What4 (W4Exception)
-import Cryptol.Backend.Monad(PPFloatFormat(..),PPFloatExp(..))
import qualified Cryptol.Symbolic.SBV as SBV (proverNames, setupProver, defaultProver, SBVProverConfig)
import qualified Cryptol.Symbolic.What4 as W4 (proverNames, setupProver, W4ProverConfig)
@@ -155,6 +158,8 @@
, eLogger :: Logger
-- ^ Use this to send messages to the user
+ , eCallStacks :: Bool
+
, eUpdateTitle :: REPL ()
-- ^ Execute this every time we load a module.
-- This is used to change the title of terminal when loading a module.
@@ -163,8 +168,8 @@
}
-- | Initial, empty environment.
-defaultRW :: Bool -> Logger -> IO RW
-defaultRW isBatch l = do
+defaultRW :: Bool -> Bool ->Logger -> IO RW
+defaultRW isBatch callStacks l = do
env <- M.initialModuleEnv
return RW
{ eLoadedMod = Nothing
@@ -174,6 +179,7 @@
, eModuleEnv = env
, eUserEnv = mkUserEnv userOptions
, eLogger = l
+ , eCallStacks = callStacks
, eUpdateTitle = return ()
, eProverConfig = Left SBV.defaultProver
}
@@ -220,9 +226,9 @@
newtype REPL a = REPL { unREPL :: IORef RW -> IO a }
-- | Run a REPL action with a fresh environment.
-runREPL :: Bool -> Logger -> REPL a -> IO a
-runREPL isBatch l m = do
- ref <- newIORef =<< defaultRW isBatch l
+runREPL :: Bool -> Bool -> Logger -> REPL a -> IO a
+runREPL isBatch callStacks l m = do
+ ref <- newIORef =<< defaultRW isBatch callStacks l
unREPL m ref
instance Functor REPL where
@@ -289,7 +295,8 @@
| DirectoryNotFound FilePath
| NoPatError [Error]
| NoIncludeError [IncludeError]
- | EvalError EvalError
+ | EvalError EvalErrorEx
+ | TooWide WordTooWide
| Unsupported Unsupported
| ModuleSystemError NameDisp M.ModuleError
| EvalPolyError T.Schema
@@ -319,6 +326,7 @@
ModuleSystemError ns me -> fixNameDisp ns (pp me)
EvalError e -> pp e
Unsupported e -> pp e
+ TooWide e -> pp e
EvalPolyError s -> text "Cannot evaluate polymorphic value."
$$ text "Type:" <+> pp s
TypeNotTestable t -> text "The expression is not of a testable type."
@@ -344,15 +352,21 @@
rethrowEvalError :: IO a -> IO a
-rethrowEvalError m = run `X.catch` rethrow `X.catch` rethrowUnsupported
+rethrowEvalError m =
+ run `X.catch` rethrow
+ `X.catch` rethrowTooWide
+ `X.catch` rethrowUnsupported
where
run = do
a <- m
return $! a
- rethrow :: EvalError -> IO a
+ rethrow :: EvalErrorEx -> IO a
rethrow exn = X.throwIO (EvalError exn)
+ rethrowTooWide :: WordTooWide -> IO a
+ rethrowTooWide exn = X.throwIO (TooWide exn)
+
rethrowUnsupported :: Unsupported -> IO a
rethrowUnsupported exn = X.throwIO (Unsupported exn)
@@ -376,6 +390,36 @@
getPrompt :: REPL String
getPrompt = mkPrompt `fmap` getRW
+getCallStacks :: REPL Bool
+getCallStacks = eCallStacks <$> getRW
+
+-- Get the setting we should use for displaying values.
+getPPValOpts :: REPL PPOpts
+getPPValOpts =
+ do base <- getKnownUser "base"
+ ascii <- getKnownUser "ascii"
+ infLength <- getKnownUser "infLength"
+
+ fpBase <- getKnownUser "fpBase"
+ fpFmtTxt <- getKnownUser "fpFormat"
+ 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
+ }
+
+getEvalOptsAction :: REPL (IO EvalOpts)
+getEvalOptsAction = REPL $ \rwRef -> pure $
+ do ppOpts <- unREPL getPPValOpts rwRef
+ l <- unREPL getLogger rwRef
+ return EvalOpts { evalPPOpts = ppOpts, evalLogger = l }
+
clearLoadedMod :: REPL ()
clearLoadedMod = do modifyRW_ (\rw -> rw { eLoadedMod = upd <$> eLoadedMod rw })
updateREPLTitle
@@ -513,12 +557,12 @@
return (map (show . pp) (Map.keys (M.neTypes fNames)))
-- | Return a list of property names, sorted by position in the file.
-getPropertyNames :: REPL ([M.Name],NameDisp)
+getPropertyNames :: REPL ([(M.Name,M.IfaceDecl)],NameDisp)
getPropertyNames =
do fe <- getFocusedEnv
let xs = M.ifDecls (M.mctxDecls fe)
- ps = sortBy (comparing (from . M.nameLoc))
- [ x | (x,d) <- Map.toList xs,
+ ps = sortBy (comparing (from . M.nameLoc . fst))
+ [ (x,d) | (x,d) <- Map.toList xs,
T.PragmaProperty `elem` M.ifDeclPragmas d ]
return (ps, M.mctxNameDisp fe)
@@ -594,7 +638,7 @@
-- | Set a user option.
setUser :: String -> String -> REPL ()
-setUser name val = case lookupTrieExact name userOptions of
+setUser name val = case lookupTrieExact name userOptionsWithAliases of
[opt] -> setUserOpt opt
[] -> rPutStrLn ("Unknown env value `" ++ name ++ "`")
@@ -697,10 +741,10 @@
getUserShowProverStats :: REPL Bool
-getUserShowProverStats = getKnownUser "prover-stats"
+getUserShowProverStats = getKnownUser "proverStats"
getUserProverValidate :: REPL Bool
-getUserProverValidate = getKnownUser "prover-validate"
+getUserProverValidate = getKnownUser "proverValidate"
-- Environment Options ---------------------------------------------------------
@@ -722,47 +766,53 @@
data OptionDescr = OptionDescr
{ optName :: String
+ , optAliases :: [String]
, optDefault :: EnvVal
, optCheck :: Checker
, optHelp :: String
, optEff :: EnvVal -> REPL ()
}
-simpleOpt :: String -> EnvVal -> Checker -> String -> OptionDescr
-simpleOpt optName optDefault optCheck optHelp =
+simpleOpt :: String -> [String] -> EnvVal -> Checker -> String -> OptionDescr
+simpleOpt optName optAliases optDefault optCheck optHelp =
OptionDescr { optEff = \ _ -> return (), .. }
+userOptionsWithAliases :: OptionMap
+userOptionsWithAliases = foldl insert userOptions (leaves userOptions)
+ where
+ insert m d = foldl (\m' n -> insertTrie n d m') m (optAliases d)
+
userOptions :: OptionMap
userOptions = mkOptionMap
- [ simpleOpt "base" (EnvNum 16) checkBase
+ [ simpleOpt "base" [] (EnvNum 16) checkBase
"The base to display words at (2, 8, 10, or 16)."
- , simpleOpt "debug" (EnvBool False) noCheck
+ , simpleOpt "debug" [] (EnvBool False) noCheck
"Enable debugging output."
- , simpleOpt "ascii" (EnvBool False) noCheck
+ , simpleOpt "ascii" [] (EnvBool False) noCheck
"Whether to display 7- or 8-bit words using ASCII notation."
- , simpleOpt "infLength" (EnvNum 5) checkInfLength
+ , simpleOpt "infLength" ["inf-length"] (EnvNum 5) checkInfLength
"The number of elements to display for infinite sequences."
- , simpleOpt "tests" (EnvNum 100) noCheck
+ , simpleOpt "tests" [] (EnvNum 100) noCheck
"The number of random tests to try with ':check'."
- , simpleOpt "satNum" (EnvString "1") checkSatNum
+ , simpleOpt "satNum" ["sat-num"] (EnvString "1") checkSatNum
"The maximum number of :sat solutions to display (\"all\" for no limit)."
- , simpleOpt "prover" (EnvString "z3") checkProver $
+ , simpleOpt "prover" [] (EnvString "z3") checkProver $
"The external SMT solver for ':prove' and ':sat'\n(" ++ proverListString ++ ")."
- , simpleOpt "warnDefaulting" (EnvBool False) noCheck
+ , simpleOpt "warnDefaulting" ["warn-defaulting"] (EnvBool False) noCheck
"Choose whether to display warnings when defaulting."
- , simpleOpt "warnShadowing" (EnvBool True) noCheck
+ , simpleOpt "warnShadowing" ["warn-shadowing"] (EnvBool True) noCheck
"Choose whether to display warnings when shadowing symbols."
- , simpleOpt "warnUninterp" (EnvBool True) noCheck
+ , simpleOpt "warnUninterp" ["warn-uninterp"] (EnvBool True) noCheck
"Choose whether to issue a warning when uninterpreted functions are used to implement primitives in the symbolic simulator."
- , simpleOpt "smtfile" (EnvString "-") noCheck
+ , simpleOpt "smtFile" ["smt-file"] (EnvString "-") noCheck
"The file to use for SMT-Lib scripts (for debugging or offline proving).\nUse \"-\" for stdout."
- , OptionDescr "mono-binds" (EnvBool True) noCheck
+ , OptionDescr "monoBinds" ["mono-binds"] (EnvBool True) noCheck
"Whether or not to generalize bindings in a 'where' clause." $
\case EnvBool b -> do me <- getModuleEnv
setModuleEnv me { M.meMonoBinds = b }
_ -> return ()
- , OptionDescr "tc-solver" (EnvProg "z3" [ "-smt2", "-in" ])
+ , 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
@@ -772,7 +822,7 @@
, T.solverArgs = args } }
_ -> return ()
- , OptionDescr "tc-debug" (EnvNum 0)
+ , OptionDescr "tcDebug" ["tc-debug"] (EnvNum 0)
noCheck
(unlines
[ "Enable type-checker debugging output:"
@@ -783,7 +833,7 @@
let cfg = M.meSolverConfig me
setModuleEnv me { M.meSolverConfig = cfg{ T.solverVerbose = n } }
_ -> return ()
- , OptionDescr "core-lint" (EnvBool False)
+ , OptionDescr "coreLint" ["core-lint"] (EnvBool False)
noCheck
"Enable sanity checking of type-checker." $
let setIt x = do me <- getModuleEnv
@@ -792,22 +842,22 @@
EnvBool False -> setIt M.NoCoreLint
_ -> return ()
- , simpleOpt "hash-consing" (EnvBool True) noCheck
+ , simpleOpt "hashConsing" ["hash-consing"] (EnvBool True) noCheck
"Enable hash-consing in the What4 symbolic backends."
- , simpleOpt "prover-stats" (EnvBool True) noCheck
+ , simpleOpt "proverStats" ["prover-stats"] (EnvBool True) noCheck
"Enable prover timing statistics."
- , simpleOpt "prover-validate" (EnvBool False) noCheck
+ , simpleOpt "proverValidate" ["prover-validate"] (EnvBool False) noCheck
"Validate :sat examples and :prove counter-examples for correctness."
- , simpleOpt "show-examples" (EnvBool True) noCheck
+ , simpleOpt "showExamples" ["show-examples"] (EnvBool True) noCheck
"Print the (counter) example after :sat or :prove"
- , simpleOpt "fp-base" (EnvNum 16) checkBase
+ , simpleOpt "fpBase" ["fp-base"] (EnvNum 16) checkBase
"The base to display floating point numbers at (2, 8, 10, or 16)."
- , simpleOpt "fp-format" (EnvString "free") checkPPFloatFormat
+ , simpleOpt "fpFormat" ["fp-format"] (EnvString "free") checkPPFloatFormat
$ unlines
[ "Specifies the format to use when showing floating point numbers:"
, " * free show using as many digits as needed"
@@ -817,7 +867,7 @@
, " * NUM+exp like NUM but always show exponent"
]
- , simpleOpt "ignore-safety" (EnvBool False) noCheck
+ , simpleOpt "ignoreSafety" ["ignore-safety"] (EnvBool False) noCheck
"Ignore safety predicates when performing :sat or :prove checks"
]
diff --git a/src/Cryptol/REPL/Trie.hs b/src/Cryptol/REPL/Trie.hs
--- a/src/Cryptol/REPL/Trie.hs
+++ b/src/Cryptol/REPL/Trie.hs
@@ -9,6 +9,7 @@
module Cryptol.REPL.Trie where
import Cryptol.Utils.Panic (panic)
+import Data.Char (toLower)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe,maybeToList)
@@ -20,13 +21,13 @@
emptyTrie :: Trie a
emptyTrie = Node Map.empty Nothing
--- | Insert a value into the Trie. Will call `panic` if a value already exists
--- with that key.
+-- | Insert a value into the Trie, forcing the key value to lower case.
+-- Will call `panic` if a value already exists with that key.
insertTrie :: String -> a -> Trie a -> Trie a
insertTrie k a = loop k
where
loop key (Node m mb) = case key of
- c:cs -> Node (Map.alter (Just . loop cs . fromMaybe emptyTrie) c m) mb
+ c:cs -> Node (Map.alter (Just . loop cs . fromMaybe emptyTrie) (toLower c) m) mb
[] -> case mb of
Nothing -> Node m (Just a)
Just _ -> panic "[REPL] Trie" ["key already exists:", "\t" ++ k]
@@ -35,7 +36,7 @@
lookupTrie :: String -> Trie a -> [a]
lookupTrie key t@(Node mp _) = case key of
- c:cs -> case Map.lookup c mp of
+ c:cs -> case Map.lookup (toLower c) mp of
Just m' -> lookupTrie cs m'
Nothing -> []
@@ -47,7 +48,7 @@
lookupTrieExact [] (Node _ (Just x)) = return x
lookupTrieExact [] t = leaves t
lookupTrieExact (c:cs) (Node mp _) =
- case Map.lookup c mp of
+ case Map.lookup (toLower c) mp of
Just m' -> lookupTrieExact cs m'
Nothing -> []
diff --git a/src/Cryptol/Symbolic.hs b/src/Cryptol/Symbolic.hs
--- a/src/Cryptol/Symbolic.hs
+++ b/src/Cryptol/Symbolic.hs
@@ -54,7 +54,8 @@
import qualified Cryptol.Eval.Concrete as Concrete
import Cryptol.Eval.Value
import Cryptol.TypeCheck.AST
-import Cryptol.Eval.Type (TValue(..), evalType)
+import Cryptol.TypeCheck.Solver.InfNat
+import Cryptol.Eval.Type (TValue(..), evalType,tValTy,tNumValTy)
import Cryptol.Utils.Ident (Ident,prelPrim,floatPrim)
import Cryptol.Utils.RecordMap
import Cryptol.Utils.Panic
@@ -65,7 +66,7 @@
import Prelude.Compat
import Data.Time (NominalDiffTime)
-type SatResult = [(Type, Expr, Concrete.Value)]
+type SatResult = [(TValue, Expr, Concrete.Value)]
data SatNum = AllSat | SomeSat Int
deriving (Show)
@@ -108,7 +109,7 @@
-- for the offline prover), a counterexample or a lazy list of
-- satisfying assignments.
data ProverResult = AllSatResult [SatResult] -- LAZY
- | ThmResult [Type]
+ | ThmResult [TValue]
| CounterExample CounterExampleType SatResult
| EmptyResult
| ProverError String
@@ -141,41 +142,57 @@
| FTIntMod Integer
| FTRational
| FTFloat Integer Integer
- | FTSeq Int FinType
+ | FTSeq Integer FinType
| FTTuple [FinType]
| FTRecord (RecordMap Ident FinType)
-
-numType :: Integer -> Maybe Int
-numType n
- | 0 <= n && n <= toInteger (maxBound :: Int) = Just (fromInteger n)
- | otherwise = Nothing
+ | FTNewtype Newtype [Either Nat' TValue] (RecordMap Ident FinType)
finType :: TValue -> Maybe FinType
finType ty =
case ty of
- TVBit -> Just FTBit
- TVInteger -> Just FTInteger
- TVIntMod n -> Just (FTIntMod n)
- TVRational -> Just FTRational
- TVFloat e p -> Just (FTFloat e p)
- TVSeq n t -> FTSeq <$> numType n <*> finType t
- TVTuple ts -> FTTuple <$> traverse finType ts
- TVRec fields -> FTRecord <$> traverse finType fields
- TVAbstract {} -> Nothing
- _ -> Nothing
+ TVBit -> Just FTBit
+ TVInteger -> Just FTInteger
+ TVIntMod n -> Just (FTIntMod n)
+ TVRational -> Just FTRational
+ TVFloat e p -> Just (FTFloat e p)
+ TVSeq n t -> FTSeq n <$> finType t
+ TVTuple ts -> FTTuple <$> traverse finType ts
+ TVRec fields -> FTRecord <$> traverse finType fields
+ TVNewtype u ts body -> FTNewtype u ts <$> traverse finType body
+ TVAbstract {} -> Nothing
+ TVArray{} -> Nothing
+ TVStream{} -> Nothing
+ TVFun{} -> Nothing
-unFinType :: FinType -> Type
-unFinType fty =
+finTypeToType :: FinType -> Type
+finTypeToType fty =
case fty of
- FTBit -> tBit
- FTInteger -> tInteger
- FTIntMod n -> tIntMod (tNum n)
- FTRational -> tRational
- FTFloat e p -> tFloat (tNum e) (tNum p)
- FTSeq l ety -> tSeq (tNum l) (unFinType ety)
- FTTuple ftys -> tTuple (unFinType <$> ftys)
- FTRecord fs -> tRec (unFinType <$> fs)
+ FTBit -> tBit
+ FTInteger -> tInteger
+ FTIntMod n -> tIntMod (tNum n)
+ FTRational -> tRational
+ FTFloat e p -> tFloat (tNum e) (tNum p)
+ FTSeq l ety -> tSeq (tNum l) (finTypeToType ety)
+ FTTuple ftys -> tTuple (finTypeToType <$> ftys)
+ FTRecord fs -> tRec (finTypeToType <$> fs)
+ FTNewtype u ts _ -> tNewtype u (map unArg ts)
+ where
+ unArg (Left Inf) = tInf
+ unArg (Left (Nat n)) = tNum n
+ unArg (Right t) = tValTy t
+unFinType :: FinType -> TValue
+unFinType fty =
+ case fty of
+ FTBit -> TVBit
+ FTInteger -> TVInteger
+ FTIntMod n -> TVIntMod n
+ FTRational -> TVRational
+ FTFloat e p -> TVFloat e p
+ FTSeq n ety -> TVSeq n (unFinType ety)
+ FTTuple ftys -> TVTuple (unFinType <$> ftys)
+ FTRecord fs -> TVRec (unFinType <$> fs)
+ FTNewtype u ts fs -> TVNewtype u ts (unFinType <$> fs)
data VarShape sym
= VarBit (SBit sym)
@@ -188,12 +205,11 @@
| VarRecord (RecordMap Ident (VarShape sym))
ppVarShape :: Backend sym => sym -> VarShape sym -> Doc
-ppVarShape sym (VarBit b) = ppBit sym b
-ppVarShape sym (VarInteger i) = ppInteger sym defaultPPOpts i
-ppVarShape sym (VarFloat f) = ppFloat sym defaultPPOpts f
-ppVarShape sym (VarRational n d) =
- text "(ratio" <+> ppInteger sym defaultPPOpts n <+> ppInteger sym defaultPPOpts d <+> text ")"
-ppVarShape sym (VarWord w) = ppWord sym defaultPPOpts w
+ppVarShape _sym (VarBit _b) = text ""
+ppVarShape _sym (VarInteger _i) = text ""
+ppVarShape _sym (VarFloat _f) = text ""
+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)))
ppVarShape sym (VarTuple xs) =
@@ -212,7 +228,7 @@
VarRational n d -> VRational (SRational n d)
VarWord w -> VWord (wordLen sym w) (return (WordVal w))
VarFloat f -> VFloat f
- VarFinSeq n vs -> VSeq n (finiteSeqMap sym (map (pure . varShapeToValue sym) vs))
+ VarFinSeq n vs -> VSeq n (finiteSeqMap (map (pure . varShapeToValue sym) vs))
VarTuple vs -> VTuple (map (pure . varShapeToValue sym) vs)
VarRecord fs -> VRecord (fmap (pure . varShapeToValue sym) fs)
@@ -225,7 +241,8 @@
}
freshVar :: Backend sym => FreshVarFns sym -> FinType -> IO (VarShape sym)
-freshVar fns tp = case tp of
+freshVar fns tp =
+ case tp of
FTBit -> VarBit <$> freshBitVar fns
FTInteger -> VarInteger <$> freshIntegerVar fns Nothing Nothing
FTRational -> VarRational
@@ -234,16 +251,17 @@
FTIntMod 0 -> panic "freshVariable" ["0 modulus not allowed"]
FTIntMod m -> VarInteger <$> freshIntegerVar fns (Just 0) (Just (m-1))
FTFloat e p -> VarFloat <$> freshFloatVar fns e p
- FTSeq n FTBit | n > 0 -> VarWord <$> freshWordVar fns (toInteger n)
+ FTSeq n FTBit -> VarWord <$> freshWordVar fns (toInteger n)
FTSeq n t -> VarFinSeq (toInteger n) <$> sequence (genericReplicate n (freshVar fns t))
FTTuple ts -> VarTuple <$> mapM (freshVar fns) ts
FTRecord fs -> VarRecord <$> traverse (freshVar fns) fs
+ FTNewtype _ _ fs -> VarRecord <$> traverse (freshVar fns) fs
computeModel ::
PrimMap ->
[FinType] ->
[VarShape Concrete.Concrete] ->
- [(Type, Expr, Concrete.Value)]
+ [(TValue, Expr, Concrete.Value)]
computeModel _ [] [] = []
computeModel primMap (t:ts) (v:vs) =
do let v' = varShapeToValue Concrete.Concrete v
@@ -304,6 +322,14 @@
go :: FinType -> VarShape Concrete.Concrete -> Expr
go ty val =
case (ty,val) of
+ (FTNewtype nt ts tfs, VarRecord vfs) ->
+ let res = zipRecords (\_lbl v t -> go t v) vfs tfs
+ in case res of
+ Left _ -> mismatch -- different fields
+ Right efs ->
+ let f = foldl (\x t -> ETApp x (tNumValTy t)) (EVar (ntName nt)) ts
+ in EApp f (ERec efs)
+
(FTRecord tfs, VarRecord vfs) ->
let res = zipRecords (\_lbl v t -> go t v) vfs tfs
in case res of
@@ -317,11 +343,11 @@
(FTInteger, VarInteger i) ->
-- This works uniformly for values of type Integer or Z n
- ETApp (ETApp (prim "number") (tNum i)) (unFinType ty)
+ ETApp (ETApp (prim "number") (tNum i)) (finTypeToType ty)
(FTIntMod _, VarInteger i) ->
-- This works uniformly for values of type Integer or Z n
- ETApp (ETApp (prim "number") (tNum i)) (unFinType ty)
+ ETApp (ETApp (prim "number") (tNum i)) (finTypeToType ty)
(FTRational, VarRational n d) ->
let n' = ETApp (ETApp (prim "number") (tNum n)) tInteger
@@ -332,17 +358,17 @@
floatToExpr prims e p (bfValue f)
(FTSeq _ FTBit, VarWord (Concrete.BV _ v)) ->
- ETApp (ETApp (prim "number") (tNum v)) (unFinType ty)
+ ETApp (ETApp (prim "number") (tNum v)) (finTypeToType ty)
(FTSeq _ t, VarFinSeq _ svs) ->
- EList (map (go t) svs) (unFinType t)
+ EList (map (go t) svs) (finTypeToType t)
_ -> mismatch
where
mismatch =
panic "Cryptol.Symbolic.varToExpr"
["type mismatch:"
- , show (pp (unFinType ty))
+ , show (pp (finTypeToType ty))
, show (ppVarShape Concrete.Concrete val)
]
diff --git a/src/Cryptol/Symbolic/SBV.hs b/src/Cryptol/Symbolic/SBV.hs
--- a/src/Cryptol/Symbolic/SBV.hs
+++ b/src/Cryptol/Symbolic/SBV.hs
@@ -6,6 +6,7 @@
-- Stability : provisional
-- Portability : portable
+{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE LambdaCase #-}
@@ -57,6 +58,7 @@
import qualified Cryptol.Eval.Concrete as Concrete
import qualified Cryptol.Eval.Value as Eval
import Cryptol.Eval.SBV
+import Cryptol.Parser.Position (emptyRange)
import Cryptol.Symbolic
import Cryptol.TypeCheck.AST
import Cryptol.Utils.Ident (preludeReferenceName, prelPrim, identText)
@@ -70,7 +72,7 @@
doSBVEval :: MonadIO m => SBVEval a -> m (SBV.SVal, a)
doSBVEval m =
- (liftIO $ Eval.runEval (sbvEval m)) >>= \case
+ (liftIO $ Eval.runEval mempty (sbvEval m)) >>= \case
SBVError err -> liftIO (X.throwIO err)
SBVResult p x -> pure (p, x)
@@ -124,7 +126,11 @@
setupProver :: String -> IO (Either String ([String], SBVProverConfig))
setupProver nm
| nm `elem` ["any","sbv-any"] =
+#if MIN_VERSION_sbv(8,9,0)
+ do ps <- SBV.getAvailableSolvers
+#else
do ps <- SBV.sbvAvailableSolvers
+#endif
case ps of
[] -> pure (Left "SBV could not find any provers")
_ -> let msg = "SBV found the following solvers: " ++ show (map (SBV.name . SBV.solver) ps) in
@@ -155,14 +161,18 @@
satSMTResults (SBV.SatResult r) = [r]
allSatSMTResults :: SBV.AllSatResult -> [SBV.SMTResult]
+#if MIN_VERSION_sbv(8,8,0)
+allSatSMTResults (SBV.AllSatResult {allSatResults = rs}) = rs
+#else
allSatSMTResults (SBV.AllSatResult (_, _, _, rs)) = rs
+#endif
thmSMTResults :: SBV.ThmResult -> [SBV.SMTResult]
thmSMTResults (SBV.ThmResult r) = [r]
proverError :: String -> M.ModuleCmd (Maybe String, ProverResult)
-proverError msg (_, _, modEnv) =
- return (Right ((Nothing, ProverError msg), modEnv), [])
+proverError msg minp =
+ return (Right ((Nothing, ProverError msg), M.minpModuleEnv minp), [])
isFailedResult :: [SBV.SMTResult] -> Maybe String
@@ -297,6 +307,13 @@
modEnv <- M.getModuleEnv
let extDgs = M.allDeclGroups modEnv ++ pcExtraDecls
+ callStacks <- M.getCallStacks
+ let ?callStacks = callStacks
+
+ getEOpts <- M.getEvalOptsAction
+
+ ntEnv <- M.getNewtypes
+
-- The `addAsm` function is used to combine assumptions that
-- arise from the types of symbolic variables (e.g. Z n values
-- are assumed to be integers in the range `0 <= x < n`) with
@@ -316,9 +333,11 @@
stateMVar <- liftIO (newMVar sbvState)
defRelsVar <- liftIO (newMVar SBV.svTrue)
let sym = SBV stateMVar defRelsVar
- let tbl = primTable sym
+ let tbl = primTable sym getEOpts
let ?evalPrim = \i -> (Right <$> Map.lookup i tbl) <|>
(Left <$> Map.lookup i ds)
+ let ?range = emptyRange
+
-- Compute the symbolic inputs, and any domain constraints needed
-- according to their types.
args <- map (pure . varShapeToValue sym) <$>
@@ -327,9 +346,10 @@
-- evaluation environment, then we compute the value, finally
-- we apply it to the symbolic inputs.
(safety,b) <- doSBVEval $
- do env <- Eval.evalDecls sym extDgs mempty
+ do env <- Eval.evalDecls sym extDgs =<<
+ Eval.evalNewtypeDecls sym ntEnv mempty
v <- Eval.evalExpr sym env pcExpr
- appliedVal <- foldM Eval.fromVFun v args
+ appliedVal <- foldM (Eval.fromVFun sym) v args
case pcQueryType of
SafetyQuery ->
do Eval.forceValue appliedVal
@@ -389,7 +409,11 @@
-- otherwise something is wrong
_ -> return $ ProverError (rshow results)
+#if MIN_VERSION_sbv(8,8,0)
+ where rshow | isSat = show . (SBV.AllSatResult False False False False)
+#else
where rshow | isSat = show . SBV.AllSatResult . (False,False,False,)
+#endif
| otherwise = show . SBV.ThmResult . head
where
@@ -398,7 +422,7 @@
-- to always be the first value in the model assignment list.
let Right (_, (safetyCV : cvs)) = SBV.getModelAssignment result
safety = SBV.cvToBool safetyCV
- (vs, []) = parseValues ts cvs
+ (vs, _) = parseValues ts cvs
mdl = computeModel prims ts vs
return (safety, mdl)
@@ -409,10 +433,10 @@
-- solver that completes the given query (if any) along with the result
-- of executing the query.
satProve :: SBVProverConfig -> ProverCommand -> M.ModuleCmd (Maybe String, ProverResult)
-satProve proverCfg pc@ProverCommand {..} =
- protectStack proverError $ \(evo, byteReader, modEnv) ->
-
- M.runModuleM (evo, byteReader, modEnv) $ do
+satProve proverCfg pc =
+ protectStack proverError $ \minp ->
+ M.runModuleM minp $ do
+ evo <- liftIO (M.minpEvalOpts minp)
let lPutStrLn = logPutStrLn (Eval.evalLogger evo)
@@ -431,12 +455,13 @@
-- the SMT input file corresponding to the given prover command.
satProveOffline :: SBVProverConfig -> ProverCommand -> M.ModuleCmd (Either String String)
satProveOffline _proverCfg pc@ProverCommand {..} =
- protectStack (\msg (_,_,modEnv) -> return (Right (Left msg, modEnv), [])) $
- \(evo, byteReader, modEnv) -> M.runModuleM (evo,byteReader,modEnv) $
+ protectStack (\msg minp -> return (Right (Left msg, M.minpModuleEnv minp), [])) $
+ \minp -> M.runModuleM minp $
do let isSat = case pcQueryType of
ProveQuery -> False
SafetyQuery -> False
SatQuery _ -> True
+ evo <- liftIO (M.minpEvalOpts minp)
prepareQuery evo pc >>= \case
Left msg -> return (Left msg)
@@ -479,11 +504,11 @@
return (VarRational n d, cvs'')
parseValue (FTSeq 0 FTBit) cvs = (VarWord (Concrete.mkBv 0 0), cvs)
parseValue (FTSeq n FTBit) cvs =
- case SBV.genParse (SBV.KBounded False n) cvs of
+ case SBV.genParse (SBV.KBounded False (fromInteger n)) cvs of
Just (x, cvs') -> (VarWord (Concrete.mkBv (toInteger n) x), cvs')
Nothing -> panic "Cryptol.Symbolic.parseValue" ["no bitvector"]
parseValue (FTSeq n t) cvs = (VarFinSeq (toInteger n) vs, cvs')
- where (vs, cvs') = parseValues (replicate n t) cvs
+ where (vs, cvs') = parseValues (replicate (fromInteger n) t) cvs
parseValue (FTTuple ts) cvs = (VarTuple vs, cvs')
where (vs, cvs') = parseValues ts cvs
parseValue (FTRecord r) cvs = (VarRecord r', cvs')
@@ -492,6 +517,8 @@
fs = zip ns vs
r' = recordFromFieldsWithDisplay (displayOrder r) fs
+parseValue (FTNewtype _ _ r) cvs = parseValue (FTRecord r) cvs
+
parseValue (FTFloat e p) cvs =
(VarFloat FH.BF { FH.bfValue = bfNaN
, FH.bfExpWidth = e
@@ -513,11 +540,16 @@
Nothing -> pure ()
return x
+freshBitvector :: SBV -> Integer -> IO SBV.SVal
+freshBitvector sym w
+ | w == 0 = pure (SBV.svInteger (SBV.KBounded False 0) 0)
+ | otherwise = freshBV_ sym (fromInteger w)
+
sbvFreshFns :: SBV -> FreshVarFns SBV
sbvFreshFns sym =
FreshVarFns
{ freshBitVar = freshSBool_ sym
- , freshWordVar = freshBV_ sym . fromInteger
+ , freshWordVar = freshBitvector sym
, freshIntegerVar = freshBoundedInt sym
, freshFloatVar = \_ _ -> return () -- TODO
}
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
@@ -56,12 +56,12 @@
import qualified Cryptol.Backend.FloatHelpers as FH
import Cryptol.Backend.What4
-import qualified Cryptol.Backend.What4.SFloat as W4
import qualified Cryptol.Eval as Eval
import qualified Cryptol.Eval.Concrete as Concrete
import qualified Cryptol.Eval.Value as Eval
import Cryptol.Eval.What4
+import Cryptol.Parser.Position (emptyRange)
import Cryptol.Symbolic
import Cryptol.TypeCheck.AST
import Cryptol.Utils.Logger(logPutStrLn,logPutStr,Logger)
@@ -72,6 +72,7 @@
import qualified What4.Expr.Builder as W4
import qualified What4.Expr.GroundEval as W4
import qualified What4.SatResult as W4
+import qualified What4.SFloat as W4
import qualified What4.SWord as SW
import What4.Solver
import qualified What4.Solver.Adapter as W4
@@ -123,7 +124,7 @@
(W4.IsExprBuilder sym, MonadIO m) =>
sym -> W4Eval sym a -> m (W4.Pred sym, a)
doW4Eval sym m =
- do res <- liftIO $ Eval.runEval (w4Eval m sym)
+ do res <- liftIO $ Eval.runEval mempty (w4Eval m sym)
case res of
W4Error err -> liftIO (X.throwIO err)
W4Result p x -> pure (p,x)
@@ -198,8 +199,8 @@
proverError :: String -> M.ModuleCmd (Maybe String, ProverResult)
-proverError msg (_, _, modEnv) =
- return (Right ((Nothing, ProverError msg), modEnv), [])
+proverError msg minp =
+ return (Right ((Nothing, ProverError msg), M.minpModuleEnv minp), [])
data CryptolState t = CryptolState
@@ -234,12 +235,13 @@
M.ModuleT IO (Either String
([FinType],[VarShape (What4 sym)],W4.Pred sym, W4.Pred sym)
)
-prepareQuery sym ProverCommand { .. } =
+prepareQuery sym ProverCommand { .. } = do
+ ntEnv <- M.getNewtypes
case predArgTypes pcQueryType pcSchema of
Left msg -> pure (Left msg)
Right ts ->
do args <- liftIO (mapM (freshVar (what4FreshFns (w4 sym))) ts)
- (safety,b) <- simulate args
+ (safety,b) <- simulate ntEnv args
liftIO
do -- Ignore the safety condition if the flag is set
let safety' = if pcIgnoreSafety then W4.truePred (w4 sym) else safety
@@ -263,7 +265,7 @@
q' <- W4.andPred (w4 sym) defs q
pure (ts,args,safety',q')
where
- simulate args =
+ simulate ntEnv args =
do let lPutStrLn = M.withLogger logPutStrLn
when pcVerbose (lPutStrLn "Simulating...")
@@ -273,18 +275,24 @@
let ds = Map.fromList [ (prelPrim (identText (M.nameIdent nm)), EWhere (EVar nm) decls) | nm <- nms ]
pure ds
- let tbl = primTable sym
+ getEOpts <- M.getEvalOptsAction
+ let tbl = primTable sym getEOpts
let ?evalPrim = \i -> (Right <$> Map.lookup i tbl) <|>
(Left <$> Map.lookup i ds)
+ let ?range = emptyRange
+ callStacks <- M.getCallStacks
+ let ?callStacks = callStacks
modEnv <- M.getModuleEnv
let extDgs = M.allDeclGroups modEnv ++ pcExtraDecls
doW4Eval (w4 sym)
- do env <- Eval.evalDecls sym extDgs mempty
+ do env <- Eval.evalDecls sym extDgs =<<
+ Eval.evalNewtypeDecls sym ntEnv mempty
+
v <- Eval.evalExpr sym env pcExpr
appliedVal <-
- foldM Eval.fromVFun v (map (pure . varShapeToValue sym) args)
+ foldM (Eval.fromVFun sym) v (map (pure . varShapeToValue sym) args)
case pcQueryType of
SafetyQuery ->
@@ -302,8 +310,8 @@
M.ModuleCmd (Maybe String, ProverResult)
satProve solverCfg hashConsing warnUninterp ProverCommand {..} =
- protectStack proverError \(evo, byteReader, modEnv) ->
- M.runModuleM (evo, byteReader, modEnv)
+ protectStack proverError \modIn ->
+ M.runModuleM modIn
do w4sym <- liftIO makeSym
defVar <- liftIO (newMVar (W4.truePred w4sym))
funVar <- liftIO (newMVar mempty)
@@ -374,8 +382,8 @@
satProveOffline (W4ProverConfig p) hashConsing warnUninterp cmd outputContinuation
satProveOffline (W4ProverConfig (AnAdapter adpt)) hashConsing warnUninterp ProverCommand {..} outputContinuation =
- protectStack onError \(evo,byteReader,modEnv) ->
- M.runModuleM (evo,byteReader,modEnv)
+ protectStack onError \modIn ->
+ M.runModuleM modIn
do w4sym <- liftIO makeSym
defVar <- liftIO (newMVar (W4.truePred w4sym))
funVar <- liftIO (newMVar mempty)
@@ -400,7 +408,7 @@
when hashConsing (W4.startCaching sym)
pure sym
- onError msg (_,_,modEnv) = pure (Right (Just msg, modEnv), [])
+ onError msg minp = pure (Right (Just msg, M.minpModuleEnv minp), [])
decSatNum :: SatNum -> SatNum
@@ -545,8 +553,8 @@
let w = W4.intValue (W4.bvWidth x)
in VarWord . Concrete.mkBv w . BV.asUnsigned <$> W4.groundEval evalFn x
VarFloat fv@(W4.SFloat f) ->
- do let (e,p) = W4.fpSize fv
- VarFloat . FH.floatFromBits e p . BV.asUnsigned <$> W4.groundEval evalFn f
+ let (e,p) = W4.fpSize fv
+ in VarFloat . FH.BF e p <$> W4.groundEval evalFn f
VarFinSeq n vs ->
VarFinSeq n <$> mapM (varShapeToConcrete evalFn) vs
VarTuple vs ->
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
@@ -10,6 +10,7 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE Trustworthy #-}
@@ -19,7 +20,6 @@
, randomValue
, dumpableType
, testableType
-, TestReport(..)
, TestResult(..)
, isPass
, returnTests
@@ -28,21 +28,23 @@
) where
import qualified Control.Exception as X
-import Control.Monad (join, liftM2)
+import Control.Monad (liftM2)
import Control.Monad.IO.Class (MonadIO(..))
-import Data.Ratio ((%))
+import Data.Bits
import Data.List (unfoldr, genericTake, genericIndex, genericReplicate)
import qualified Data.Sequence as Seq
import System.Random (RandomGen, split, random, randomR)
import Cryptol.Backend (Backend(..), SRational(..))
-import Cryptol.Backend.Monad (runEval,Eval,EvalError(..))
+import Cryptol.Backend.FloatHelpers (floatFromBits)
+import Cryptol.Backend.Monad (runEval,Eval,EvalErrorEx(..))
import Cryptol.Backend.Concrete
import Cryptol.Eval.Type (TValue(..))
import Cryptol.Eval.Value (GenValue(..),SeqMap(..), WordValue(..),
- ppValue, defaultPPOpts, finiteSeqMap)
+ ppValue, defaultPPOpts, finiteSeqMap, fromVFun)
+import Cryptol.TypeCheck.Solver.InfNat (widthInteger)
import Cryptol.Utils.Ident (Ident)
import Cryptol.Utils.Panic (panic)
import Cryptol.Utils.RecordMap
@@ -68,7 +70,7 @@
runOneTest fun argGens sz g0 = do
let (args, g1) = foldr mkArg ([], g0) argGens
mkArg argGen (as, g) = let (a, g') = argGen sz g in (a:as, g')
- args' <- runEval (sequence args)
+ args' <- runEval mempty (sequence args)
result <- evalTest fun args'
return (result, g1)
@@ -81,12 +83,14 @@
returnOneTest fun argGens sz g0 =
do let (args, g1) = foldr mkArg ([], g0) argGens
mkArg argGen (as, g) = let (a, g') = argGen sz g in (a:as, g')
- args' <- runEval (sequence args)
- result <- runEval (go fun args')
+ args' <- runEval mempty (sequence args)
+ result <- runEval mempty (go fun args')
return (args', result, g1)
where
- go (VFun f) (v : vs) = join (go <$> (f (pure v)) <*> pure vs)
- go (VFun _) [] = panic "Cryptol.Testing.Random" ["Not enough arguments to function while generating tests"]
+ go f@VFun{} (v : vs) =
+ do f' <- fromVFun Concrete f (pure v)
+ go f' vs
+ go VFun{} [] = panic "Cryptol.Testing.Random" ["Not enough arguments to function while generating tests"]
go _ (_ : _) = panic "Cryptol.Testing.Random" ["Too many arguments to function while generating tests"]
go v [] = return v
@@ -147,7 +151,9 @@
TVRec fs ->
do gs <- traverse (randomValue sym) fs
return (randomRecord gs)
-
+ TVNewtype _ _ fs ->
+ do gs <- traverse (randomValue sym) fs
+ return (randomRecord gs)
TVArray{} -> Nothing
TVFun{} -> Nothing
TVAbstract{} -> Nothing
@@ -226,7 +232,8 @@
let f g = let (x,g') = mkElem sz g
in seq x (Just (x, g'))
let xs = Seq.fromList $ genericTake w $ unfoldr f g1
- seq xs (pure $ VSeq w $ IndexSeqMap $ (Seq.index xs . fromInteger), g2)
+ let v = VSeq w $ IndexSeqMap $ \i -> Seq.index xs (fromInteger i)
+ seq xs (pure v, g2)
{-# INLINE randomTuple #-}
@@ -256,20 +263,42 @@
Integer {- ^ Exponent width -} ->
Integer {- ^ Precision width -} ->
Gen g sym
-randomFloat sym e p w g =
- ( VFloat <$> fpLit sym e p (nu % de)
- , g3
- )
+randomFloat sym e p w g0 =
+ let sz = max 0 (min 100 w)
+ ( x, g') = randomR (0, 10*(sz+1)) g0
+ in if | x < 2 -> (VFloat <$> fpNaN sym e p, g')
+ | x < 4 -> (VFloat <$> fpPosInf sym e p, g')
+ | x < 6 -> (VFloat <$> (fpNeg sym =<< fpPosInf sym e p), g')
+ | x < 8 -> (VFloat <$> fpLit sym e p 0, g')
+ | x < 10 -> (VFloat <$> (fpNeg sym =<< fpLit sym e p 0), g')
+ | x <= sz -> genSubnormal g' -- about 10% of the time
+ | x <= 4*(sz+1) -> genBinary g' -- about 40%
+ | otherwise -> genNormal (toInteger sz) g' -- remaining ~50%
+
where
- -- XXX: we never generat NaN
- -- XXX: Not sure that we need such big integers, we should probably
- -- use `e` and `p` as a guide.
- (n, g1) = if w < 100 then (fromInteger w, g) else randomSize 8 100 g
- (nu, g2) = randomR (- 256^n, 256^n) g1
- (de, g3) = randomR (1, 256^n) g2
+ emax = bit (fromInteger e) - 1
+ smax = bit (fromInteger p) - 1
+ -- generates floats uniformly chosen from among all bitpatterns
+ genBinary g =
+ let (v, g1) = randomR (0, bit (fromInteger (e+p)) - 1) g
+ in (VFloat <$> (fpFromBits sym e p =<< wordLit sym (e+p) v), g1)
+ -- generates floats corresponding to subnormal values. These are
+ -- values with 0 biased exponent and nonzero mantissa.
+ genSubnormal g =
+ let (sgn, g1) = random g
+ (v, g2) = randomR (1, bit (fromInteger p) - 1) g1
+ in (VFloat <$> ((if sgn then fpNeg sym else pure) =<< fpFromBits sym e p =<< wordLit sym (e+p) v), g2)
+ -- generates floats where the exponent and mantissa are scaled by the size
+ genNormal sz g =
+ let (sgn, g1) = random g
+ (ex, g2) = randomR ((1-emax)*sz `div` 100, (sz*emax) `div` 100) g1
+ (mag, g3) = randomR (1, max 1 ((sz*smax) `div` 100)) g2
+ r = fromInteger mag ^^ (ex - widthInteger mag)
+ r' = if sgn then negate r else r
+ in (VFloat <$> fpLit sym e p r', g3)
-- | A test result is either a pass, a failure due to evaluating to
@@ -277,7 +306,7 @@
data TestResult
= Pass
| FailFalse [Value]
- | FailError EvalError [Value]
+ | FailError EvalErrorEx [Value]
isPass :: TestResult -> Bool
isPass Pass = True
@@ -291,15 +320,16 @@
evalTest v0 vs0 = run `X.catch` handle
where
run = do
- result <- runEval (go v0 vs0)
+ result <- runEval mempty (go v0 vs0)
if result
then return Pass
else return (FailFalse vs0)
handle e = return (FailError e vs0)
go :: Value -> [Value] -> Eval Bool
- go (VFun f) (v : vs) = join (go <$> (f (pure v)) <*> return vs)
- go (VFun _) [] = panic "Not enough arguments while applying function"
+ go f@VFun{} (v : vs) = do f' <- fromVFun Concrete f (pure v)
+ go f' vs
+ go VFun{} [] = panic "Not enough arguments while applying function"
[]
go (VBit b) [] = return b
go v vs = do vdoc <- ppValue Concrete defaultPPOpts v
@@ -348,7 +378,7 @@
TVInteger -> Nothing
TVRational -> Nothing
TVIntMod n -> Just n
- TVFloat{} -> Nothing -- TODO?
+ TVFloat e p -> Just (2 ^ (e+p))
TVArray{} -> Nothing
TVStream{} -> Nothing
TVSeq n el -> (^ n) <$> typeSize el
@@ -356,25 +386,26 @@
TVRec fs -> product <$> traverse typeSize fs
TVFun{} -> Nothing
TVAbstract{} -> Nothing
+ TVNewtype _ _ tbody -> typeSize (TVRec tbody)
{- | Returns all the values in a type. Returns an empty list of values,
for types where 'typeSize' returned 'Nothing'. -}
typeValues :: TValue -> [Value]
typeValues ty =
case ty of
- TVBit -> [ VBit False, VBit True ]
- TVInteger -> []
- TVRational -> []
- TVIntMod n -> [ VInteger x | x <- [ 0 .. (n-1) ] ]
- TVFloat{} -> [] -- TODO?
- TVArray{} -> []
- TVStream{} -> []
+ TVBit -> [ VBit False, VBit True ]
+ TVInteger -> []
+ TVRational -> []
+ TVIntMod n -> [ VInteger x | x <- [ 0 .. (n-1) ] ]
+ TVFloat e p -> [ VFloat (floatFromBits e p v) | v <- [0 .. 2^(e+p) - 1] ]
+ TVArray{} -> []
+ TVStream{} -> []
TVSeq n TVBit ->
[ VWord n (pure (WordVal (BV n x)))
| x <- [ 0 .. 2^n - 1 ]
]
TVSeq n el ->
- [ VSeq n (finiteSeqMap Concrete (map pure xs))
+ [ VSeq n (finiteSeqMap (map pure xs))
| xs <- sequence (genericReplicate n (typeValues el))
]
TVTuple ts ->
@@ -387,16 +418,10 @@
]
TVFun{} -> []
TVAbstract{} -> []
+ TVNewtype _ _ tbody -> typeValues (TVRec tbody)
--------------------------------------------------------------------------------
-- Driver function
-
-data TestReport = TestReport {
- reportResult :: TestResult
- , reportProp :: String -- ^ The property as entered by the user
- , reportTestsRun :: Integer
- , reportTestsPossible :: Maybe Integer
- }
exhaustiveTests :: MonadIO m =>
(Integer -> m ()) {- ^ progress callback -} ->
diff --git a/src/Cryptol/Transform/AddModParams.hs b/src/Cryptol/Transform/AddModParams.hs
--- a/src/Cryptol/Transform/AddModParams.hs
+++ b/src/Cryptol/Transform/AddModParams.hs
@@ -230,6 +230,7 @@
in ESel (EVar paramModRecParam) (RecordSel (nameIdent x) (Just sh))
| otherwise -> EVar x
+ ELocated r t -> ELocated r (inst ps t)
EList es t -> EList (inst ps es) (inst ps t)
ETuple es -> ETuple (inst ps es)
ERec fs -> ERec (fmap (inst ps) fs)
@@ -288,17 +289,13 @@
where ts1 = inst ps ts
t1 = inst ps t
- TCon tc ts ->
- case tc of
- TC (TCNewtype (UserTC x k))
- | needsInst ps x -> TCon (TC (TCNewtype (UserTC x (k1 k))))
- (newTs ++ ts1)
- _ -> TCon tc ts1
- where
- ts1 = inst ps ts
- newTs = instTyParams ps
- k1 k = foldr (:->) k (map kindOf newTs)
+ TNewtype nt ts
+ | needsInst ps (ntName nt) -> TNewtype (inst ps nt) (instTyParams ps ++ ts1)
+ | otherwise -> TNewtype nt ts1
+ where ts1 = inst ps ts
+ TCon tc ts -> TCon tc (inst ps ts)
+
TVar x | Just x' <- isTParam ps x -> TVar (TVBound x')
| otherwise -> ty
@@ -311,7 +308,7 @@
instance Inst Newtype where
inst ps nt = nt { ntConstraints = inst ps (ntConstraints nt)
- , ntFields = [ (f, inst ps t) | (f,t) <- ntFields nt ]
+ , ntFields = fmap (inst ps) (ntFields nt)
}
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
@@ -179,6 +179,7 @@
Nothing -> EProofApp <$> go e
Just yes -> return yes
+ ELocated r t -> ELocated r <$> go t
EList es t -> EList <$> mapM go es <*> return t
ETuple es -> ETuple <$> mapM go es
ERec fs -> ERec <$> traverse go fs
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
@@ -59,17 +59,18 @@
-- type-specialized versions of all functions called (transitively) by
-- the body of the expression.
specialize :: Expr -> M.ModuleCmd Expr
-specialize expr (ev, byteReader, modEnv) = run $ do
- let extDgs = allDeclGroups modEnv
+specialize expr minp = run $ do
+ let extDgs = allDeclGroups (M.minpModuleEnv minp)
let (tparams, expr') = destETAbs expr
spec' <- specializeEWhere expr' extDgs
return (foldr ETAbs spec' tparams)
where
- run = M.runModuleT (ev, byteReader, modEnv) . fmap fst . runSpecT Map.empty
+ run = M.runModuleT minp . fmap fst . runSpecT Map.empty
specializeExpr :: Expr -> SpecM Expr
specializeExpr expr =
case expr of
+ ELocated r e -> ELocated r <$> specializeExpr e
EList es t -> EList <$> traverse specializeExpr es <*> pure t
ETuple es -> ETuple <$> traverse specializeExpr es
ERec fs -> ERec <$> traverse specializeExpr fs
diff --git a/src/Cryptol/TypeCheck.hs b/src/Cryptol/TypeCheck.hs
--- a/src/Cryptol/TypeCheck.hs
+++ b/src/Cryptol/TypeCheck.hs
@@ -52,6 +52,8 @@
import Cryptol.Utils.PP
import Cryptol.Utils.Panic(panic)
+
+
tcModule :: P.Module Name -> InferInput -> IO (InferOutput Module)
tcModule m inp = runInferM inp (inferModule m)
@@ -78,7 +80,9 @@
where
go loc expr =
case expr of
- P.ELocated e loc' -> go loc' e
+ P.ELocated e loc' ->
+ do (te, sch) <- go loc' e
+ pure $! if inpCallStacks inp then (ELocated loc' te, sch) else (te,sch)
P.EVar x ->
do res <- lookupVar x
case res of
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
@@ -28,7 +28,7 @@
, module Cryptol.TypeCheck.Type
) where
-import Cryptol.Parser.Position(Located)
+import Cryptol.Parser.Position(Located,Range,HasLoc(..))
import Cryptol.ModuleSystem.Name
import Cryptol.ModuleSystem.Exports(ExportSpec(..)
, isExportedBind, isExportedType)
@@ -124,6 +124,8 @@
| EAbs Name Type Expr -- ^ Function value
+ | ELocated Range Expr -- ^ Source location information
+
{- | Proof abstraction. Because we don't keep proofs around
we don't need to name the assumption, but we still need to
record the assumption. The assumption is the 'Type' term,
@@ -200,6 +202,8 @@
instance PP (WithNames Expr) where
ppPrec prec (WithNames expr nm) =
case expr of
+ ELocated _ t -> ppWP prec t
+
EList [] t -> optParens (prec > 0)
$ text "[]" <+> colon <+> ppWP prec t
@@ -319,7 +323,9 @@
(ts,e2) = splitWhile splitTApp e1
-
+instance HasLoc Expr where
+ getLoc (ELocated r _) = Just r
+ getLoc _ = Nothing
instance PP Expr where
ppPrec n t = ppWithNamesPrec IntMap.empty n t
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
@@ -112,7 +112,7 @@
src = CtPartialTypeFun nm
mapM_ (newGoal src) (ntConstraints nt)
- return (tp, TCon (TC (TCNewtype (UserTC nm k2))) [])
+ return (tp, TNewtype nt [])
-- Check that a type parameter defined as another type parameter is OK
checkTP tp tp1 =
diff --git a/src/Cryptol/TypeCheck/Default.hs b/src/Cryptol/TypeCheck/Default.hs
--- a/src/Cryptol/TypeCheck/Default.hs
+++ b/src/Cryptol/TypeCheck/Default.hs
@@ -3,7 +3,7 @@
import qualified Data.Set as Set
import Data.Map (Map)
import qualified Data.Map as Map
-import Data.Maybe(mapMaybe)
+import Data.Maybe(mapMaybe, isJust)
import Data.List((\\),nub)
import Control.Monad(guard,mzero)
@@ -35,14 +35,16 @@
allProps = saturatedPropSet gSet
has p a = Set.member (p (TVar a)) allProps
+ isLiteralGoal a = isJust (Map.lookup a (literalGoals gSet)) ||
+ isJust (Map.lookup a (literalLessThanGoals gSet))
tryDefVar a =
-- If there is an `FLiteral` constraint we use that for defaulting.
case Map.lookup a (flitDefaultCandidates gSet) of
Just m -> m
-- Otherwise we try to use a `Literal`
- Nothing ->
- do _gt <- Map.lookup a (literalGoals gSet)
+ Nothing
+ | isLiteralGoal a -> do
defT <- if has pLogic a then mzero
else if has pField a && not (has pIntegral a)
then pure tRational
@@ -56,6 +58,7 @@
-- to depend on
return ((a,defT),w)
+ | otherwise -> mzero
flitDefaultCandidates :: Goals -> Map TVar (Maybe ((TVar,Type),Warning))
flitDefaultCandidates gs =
diff --git a/src/Cryptol/TypeCheck/Depends.hs b/src/Cryptol/TypeCheck/Depends.hs
--- a/src/Cryptol/TypeCheck/Depends.hs
+++ b/src/Cryptol/TypeCheck/Depends.hs
@@ -15,9 +15,10 @@
import Cryptol.Parser.Position(Range, Located(..), thing)
import Cryptol.Parser.Names (namesB, tnamesT, tnamesC,
boundNamesSet, boundNames)
-import Cryptol.TypeCheck.Monad( InferM, recordError, getTVars )
+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)
@@ -28,6 +29,7 @@
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
@@ -48,13 +50,13 @@
-- | Check for duplicate and recursive type synonyms.
-- Returns the type-synonyms in dependency order.
-orderTyDecls :: [TyDecl] -> InferM [TyDecl]
+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) ]
- concat `fmap` mapM check ordered
+ runExceptionT (concat `fmap` mapM check ordered)
where
toMap vs ty@(PT p _) =
@@ -81,7 +83,7 @@
boundNamesSet vs $
boundNames (map P.tpName as) $
Set.unions $
- map (tnamesT . P.value) fs
+ map (tnamesT . snd) (recordElements fs)
)
}
)
@@ -112,17 +114,12 @@
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) =
- do recordError (RecursiveTypeDecls (map getN xs))
- return [] -- XXX: This is likely to cause fake errors for missing
- -- type synonyms. We could avoid this by, for example, checking
- -- for recursive synonym errors, when looking up tycons.
-
-
+ 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)]
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
@@ -117,6 +117,10 @@
-- ^ Too many positional type arguments, in an explicit
-- type instantiation
+ | BadParameterKind TParam Kind
+ -- ^ Kind other than `*` or `#` given to parameter of
+ -- type synonym, newtype, function signature, etc.
+
| CannotMixPositionalAndNamedTypeParams
| UndefinedTypeParameter (Located Ident)
@@ -128,6 +132,9 @@
-- but we know it must be at least as large as the given type
-- (or unconstrained, if Nothing).
+ | BareTypeApp
+ -- ^ Bare expression of the form `{_}
+
| UndefinedExistVar Name
| TypeShadowing String Name String
| MissingModTParam (Located Ident)
@@ -139,6 +146,7 @@
errorImportance :: Error -> Int
errorImportance err =
case err of
+ BareTypeApp -> 11 -- basically a parse error
KindMismatch {} -> 10
TyVarWithParams {} -> 9
TypeMismatch {} -> 8
@@ -151,7 +159,7 @@
MissingModTParam {} -> 10
MissingModVParam {} -> 10
-
+ BadParameterKind{} -> 9
CannotMixPositionalAndNamedTypeParams {} -> 8
TooManyTypeParams {} -> 8
TooFewTyParams {} -> 8
@@ -180,6 +188,7 @@
+
instance TVars Warning where
apSubst su warn =
case warn of
@@ -215,10 +224,12 @@
TooManyPositionalTypeParams -> err
CannotMixPositionalAndNamedTypeParams -> err
+ BadParameterKind{} -> err
UndefinedTypeParameter {} -> err
RepeatedTypeParameter {} -> err
AmbiguousSize x t -> AmbiguousSize x !$ (apSubst su t)
+ BareTypeApp -> err
UndefinedExistVar {} -> err
TypeShadowing {} -> err
@@ -249,7 +260,10 @@
UndefinedTypeParameter {} -> Set.empty
RepeatedTypeParameter {} -> Set.empty
AmbiguousSize _ t -> fvs t
+ BadParameterKind tp _ -> Set.singleton (TVBound tp)
+ BareTypeApp -> Set.empty
+
UndefinedExistVar {} -> Set.empty
TypeShadowing {} -> Set.empty
MissingModTParam {} -> Set.empty
@@ -378,9 +392,15 @@
, "When checking" <+> pp src
]
+ BadParameterKind tp k ->
+ addTVarsDescsAfter names err $
+ vcat [ "Illegal kind assigned to type variable:" <+> ppWithNames names tp
+ , "Unexpected:" <+> pp k
+ ]
+
TooManyPositionalTypeParams ->
addTVarsDescsAfter names err $
- "Too many positional type-parameters in explicit type application"
+ "Too many positional type-parameters in explicit type application."
CannotMixPositionalAndNamedTypeParams ->
addTVarsDescsAfter names err $
@@ -403,6 +423,10 @@
Nothing -> empty
in addTVarsDescsAfter names err ("Ambiguous numeric type:" <+> pp (tvarDesc x) $$ sizeMsg)
+ BareTypeApp ->
+ "Unexpected bare type application." $$
+ "Perhaps you meant `( ... ) instead."
+
UndefinedExistVar x -> "Undefined type" <+> quotes (pp x)
TypeShadowing this new that ->
"Type" <+> text this <+> quotes (pp new) <+>
@@ -475,7 +499,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
@@ -513,6 +537,10 @@
let doc2 = tys !! 1
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 <> "."))
+
PFLiteral ->
case ts of
~[m,n,_r,_a] ->
@@ -544,7 +572,7 @@
{- XXX: Currently we pick the names based on the unique of the variable:
smaller uniques get an earlier name (e.g., 100 might get `a` and 200 `b`)
- This may still lead to changes in the names if the uniques got reordred
+ This may still lead to changes in the names if the uniques got reordered
for some reason. A more stable approach might be to order the variables
on their location in the error/warning, but that's quite a bit more code
so for now we just go with the simple approximation. -}
@@ -570,4 +598,3 @@
variant n x = if n == 0 then x else x ++ suff n
variants roots = [ variant n r | n <- [ 0 .. ], r <- roots ]
-
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
@@ -169,7 +169,9 @@
-- XXX: Is there a scoping issue here? I think not, but check.
P.ELocated e r ->
- inRange r (appTys e ts tGoal)
+ do e' <- inRange r (appTys e ts tGoal)
+ cs <- getCallStacks
+ if cs then pure (ELocated r e') else pure e'
P.ENeg {} -> mono
P.EComplement {} -> mono
@@ -181,6 +183,7 @@
P.ESel {} -> mono
P.EList {} -> mono
P.EFromTo {} -> mono
+ P.EFromToLessThan {} -> mono
P.EInfFrom {} -> mono
P.EComp {} -> mono
P.EApp {} -> mono
@@ -292,6 +295,20 @@
es' <- mapM checkElem es
return (EList es' a)
+ P.EFromToLessThan t1 t2 mety ->
+ do l <- curRange
+ let fs0 =
+ case mety of
+ Just ety -> [("a", ety)]
+ Nothing -> []
+ let fs = [("first", t1), ("bound", t2)] ++ fs0
+ prim <- mkPrim "fromToLessThan"
+ let e' = P.EAppT prim
+ [ P.NamedInst P.Named { name = Located l (packIdent x), value = y }
+ | (x,y) <- fs
+ ]
+ checkE e' tGoal
+
P.EFromTo t1 mbt2 t3 mety ->
do l <- curRange
let fs0 =
@@ -366,9 +383,12 @@
P.Named { name = Located l (packIdent "val")
, value = t }]) tGoal
- P.EFun ps e -> checkFun Nothing ps e tGoal
+ P.EFun desc ps e -> checkFun desc ps e tGoal
- P.ELocated e r -> inRange r (checkE e tGoal)
+ P.ELocated e r ->
+ do e' <- inRange r (checkE e tGoal)
+ cs <- getCallStacks
+ if cs then pure (ELocated r e') else pure e'
P.ESplit e ->
do prim <- mkPrim "splitAt"
@@ -388,7 +408,7 @@
Nothing ->
do r <- newParamName (packIdent "r")
let p = P.PVar Located { srcRange = nameLoc r, thing = r }
- fe = P.EFun [p] (P.EUpd (Just (P.EVar r)) fs)
+ fe = P.EFun P.emptyFunDesc [p] (P.EUpd (Just (P.EVar r)) fs)
checkE fe tGoal
Just e ->
@@ -561,11 +581,11 @@
checkFun ::
- Maybe 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 fun ps e tGoal =
+checkFun (P.FunDesc fun offset) ps e tGoal =
inNewScope $
- do let descs = [ TypeOfArg (ArgDescr fun (Just n)) | n <- [ 1 :: Int .. ] ]
+ do let descs = [ TypeOfArg (ArgDescr fun (Just n)) | n <- [ 1 + offset .. ] ]
(tys,tRes) <- expectFun fun (length ps) tGoal
largs <- sequence (zipWith checkP ps (zipWith WithSource tys descs))
@@ -826,8 +846,13 @@
* and vars in the inferred types that do not appear anywhere else. -}
let as = sortBy numFst
$ as0 ++ Set.toList (Set.difference inSigs asmpVs)
- asPs = [ TParam { tpUnique = x, tpKind = k, tpFlav = TPOther Nothing
- , tpInfo = i } | TVFree x k _ i <- as ]
+ asPs = [ TParam { tpUnique = x
+ , tpKind = k
+ , tpFlav = TPUnifyVar
+ , tpInfo = i
+ }
+ | TVFree x k _ i <- as
+ ]
{- Finally, we replace free variables with bound ones, and fix-up
the definitions as needed to reflect that we are now working
@@ -866,7 +891,7 @@
P.DExpr e ->
do let nm = thing (P.bName b)
let tGoal = WithSource t (DefinitionOf nm)
- e1 <- checkFun (Just nm) (P.bParams b) e tGoal
+ e1 <- checkFun (P.FunDesc (Just nm) 0) (P.bParams b) e tGoal
let f = thing (P.bName b)
return Decl { dName = f
, dSignature = Forall [] [] t
@@ -898,7 +923,7 @@
do (e1,cs0) <- collectGoals $
do let nm = thing (P.bName b)
tGoal = WithSource t0 (DefinitionOf nm)
- e1 <- checkFun (Just nm) (P.bParams b) e0 tGoal
+ e1 <- checkFun (P.FunDesc (Just nm) 0) (P.bParams b) e0 tGoal
addGoals validSchema
() <- simplifyAllConstraints -- XXX: using `asmps` also?
return e1
@@ -941,8 +966,10 @@
}
inferDs :: FromDecl d => [d] -> ([DeclGroup] -> InferM a) -> InferM a
-inferDs ds continue = checkTyDecls =<< orderTyDecls (mapMaybe toTyDecl ds)
+inferDs ds continue = either onErr checkTyDecls =<< orderTyDecls (mapMaybe toTyDecl ds)
where
+ onErr err = recordError err >> continue []
+
isTopLevel = isTopDecl (head ds)
checkTyDecls (AT t mbD : ts) =
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
@@ -47,6 +47,7 @@
-- ^ Look for the solver prelude in these locations.
} deriving (Show, Generic, NFData)
+
-- | The types of variables in the environment.
data VarType = ExtVar Schema
-- ^ Known type
@@ -66,6 +67,10 @@
, literalGoals :: Map TVar LitGoal
-- ^ An entry @(a,t)@ corresponds to @Literal t a@.
+
+ , literalLessThanGoals :: Map TVar LitGoal
+ -- ^ An entry @(a,t)@ corresponds to @LiteralLessThan t a@.
+
} deriving (Show)
-- | This abuses the type 'Goal' a bit. The 'goal' field contains
@@ -84,15 +89,35 @@
return (a, g { goal = tn })
+litLessThanGoalToGoal :: (TVar,LitGoal) -> Goal
+litLessThanGoalToGoal (a,g) = g { goal = pLiteralLessThan (goal g) (TVar a) }
+goalToLitLessThanGoal :: Goal -> Maybe (TVar,LitGoal)
+goalToLitLessThanGoal g =
+ do (tn,a) <- matchMaybe $ do (tn,b) <- aLiteralLessThan (goal g)
+ a <- aTVar b
+ return (tn,a)
+ return (a, g { goal = tn })
+
+
emptyGoals :: Goals
-emptyGoals = Goals { goalSet = Set.empty, saturatedPropSet = Set.empty, literalGoals = Map.empty }
+emptyGoals =
+ Goals
+ { goalSet = Set.empty
+ , saturatedPropSet = Set.empty
+ , literalGoals = Map.empty
+ , literalLessThanGoals = Map.empty
+ }
nullGoals :: Goals -> Bool
-nullGoals gs = Set.null (goalSet gs) && Map.null (literalGoals gs)
+nullGoals gs =
+ Set.null (goalSet gs) &&
+ Map.null (literalGoals gs) &&
+ Map.null (literalLessThanGoals gs)
fromGoals :: Goals -> [Goal]
fromGoals gs = map litGoalToGoal (Map.toList (literalGoals gs)) ++
+ map litLessThanGoalToGoal (Map.toList (literalLessThanGoals gs)) ++
Set.toList (goalSet gs)
goalsFromList :: [Goal] -> Goals
@@ -106,6 +131,11 @@
let jn g1 g2 = g1 { goal = tMax (goal g1) (goal g2) } in
gls { literalGoals = Map.insertWith jn a newG (literalGoals gls)
, saturatedPropSet = Set.insert (pFin (TVar a)) (saturatedPropSet gls)
+ }
+
+ | Just (a,newG) <- goalToLitLessThanGoal g =
+ let jn g1 g2 = g1 { goal = tMax (goal g1) (goal g2) } in
+ gls { literalLessThanGoals = Map.insertWith jn a newG (literalLessThanGoals gls)
}
-- If the goal is already implied by some other goal, skip it
diff --git a/src/Cryptol/TypeCheck/Instantiate.hs b/src/Cryptol/TypeCheck/Instantiate.hs
--- a/src/Cryptol/TypeCheck/Instantiate.hs
+++ b/src/Cryptol/TypeCheck/Instantiate.hs
@@ -102,9 +102,9 @@
where
src = case drop (n-1) {- count from 1 -} as of
p:_ ->
- case tpFlav p of
- TPOther (Just a) -> TypeParamInstNamed nm (nameIdent a)
- _ -> TypeParamInstPos nm n
+ case tpName p of
+ Just a -> TypeParamInstNamed nm (nameIdent a)
+ _ -> TypeParamInstPos nm n
_ -> panic "instantiateWithPos"
[ "Invalid parameter index", show n, show as ]
diff --git a/src/Cryptol/TypeCheck/Kind.hs b/src/Cryptol/TypeCheck/Kind.hs
--- a/src/Cryptol/TypeCheck/Kind.hs
+++ b/src/Cryptol/TypeCheck/Kind.hs
@@ -20,7 +20,6 @@
) where
import qualified Cryptol.Parser.AST as P
-import Cryptol.Parser.AST (Named(..))
import Cryptol.Parser.Position
import Cryptol.TypeCheck.AST
import Cryptol.TypeCheck.Error
@@ -37,7 +36,7 @@
import Data.Maybe(fromMaybe)
import Data.Function(on)
import Data.Text (Text)
-import Control.Monad(unless,forM,when)
+import Control.Monad(unless,when)
@@ -114,11 +113,8 @@
do ((as1,fs1),gs) <- collectGoals $
inRange (srcRange x) $
do r <- withTParams NoWildCards newtypeParam as $
- forM fs $ \field ->
- let n = name field
- in kInRange (srcRange n) $
- do t1 <- doCheckType (value field) (Just KType)
- return (thing n, t1)
+ flip traverseRecordMap fs $ \_n (rng,f) ->
+ kInRange rng $ doCheckType f (Just KType)
simplifyAllConstraints
return r
@@ -132,7 +128,7 @@
checkPrimType :: P.PrimType Name -> Maybe Text -> InferM AbstractType
checkPrimType p mbD =
do let (as,cs) = P.primTCts p
- (as',cs') <- withTParams NoWildCards (TPOther . Just) as $
+ (as',cs') <- withTParams NoWildCards TPPrimParam as $
mapM checkProp cs
pure AbstractType { atName = thing (P.primTName p)
, atKind = cvtK (thing (P.primTKind p))
@@ -265,10 +261,13 @@
checkKind (TUser x ts1 t1) k k1
checkNewTypeUse nt =
- do let tc = newtypeTyCon nt
- (ts1,_) <- appTy ts (kindOf tc)
- ts2 <- checkParams (ntParams nt) ts1
- return (TCon tc ts2)
+ do (ts1,k1) <- appTy ts (kindOf nt)
+ let as = ntParams nt
+ ts2 <- checkParams as ts1
+ let su = zip as ts2
+ ps1 <- mapM (`kInstantiateT` su) (ntConstraints nt)
+ kNewGoals (CtPartialTypeFun (ntName nt)) ps1
+ checkKind (TNewtype nt ts2) k k1
checkAbstractTypeUse absT =
do let tc = abstractTypeTC absT
@@ -388,8 +387,8 @@
P.TInfix t x _ u-> doCheckType (P.TUser (thing x) [t, u]) k
- P.TTyApp _fs -> panic "doCheckType"
- ["TTyApp found when kind checking, but it should have been eliminated already"]
+ P.TTyApp _fs -> do kRecordError BareTypeApp
+ kNewType TypeWildCard KNum
where
checkF _nm (rng,v) = kInRange rng $ doCheckType v (Just KType)
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
@@ -74,6 +74,8 @@
, inpMonoBinds :: Bool -- ^ Should local bindings without
-- signatures be monomorphized?
+ , inpCallStacks :: Bool -- ^ Are we tracking call stacks?
+
, inpSolverConfig :: SolverConfig -- ^ Options for the constraint solver
, inpSearchPath :: [FilePath]
-- ^ Where to look for Cryptol theory file.
@@ -83,8 +85,9 @@
-- identifier (e.g., @number@).
, inpSupply :: !Supply -- ^ The supply for fresh name generation
- } deriving Show
+ , inpSolver :: SMT.Solver -- ^ Solver connection for typechecking
+ }
-- | This is used for generating various names.
data NameSeeds = NameSeeds
@@ -114,7 +117,7 @@
io $ modifyIORef' iSolveCounter (+1)
runInferM :: TVars a => InferInput -> InferM a -> IO (InferOutput a)
-runInferM info (IM m) = SMT.withSolver (inpSolverConfig info) $ \solver ->
+runInferM info (IM m) =
do counter <- newIORef 0
rec ro <- return RO { iRange = inpRange info
, iVars = Map.map ExtVar (inpVars info)
@@ -128,7 +131,8 @@
, iSolvedHasLazy = iSolvedHas finalRW -- RECURSION
, iMonoBinds = inpMonoBinds info
- , iSolver = solver
+ , iCallStacks = inpCallStacks info
+ , iSolver = inpSolver info
, iPrimNames = inpPrimNames info
, iSolveCounter = counter
}
@@ -232,6 +236,10 @@
-- in where-blocks will never be generalized. Bindings with type
-- signatures, and all bindings at top level are unaffected.
+ , iCallStacks :: Bool
+ -- ^ When this flag is true, retain source location information
+ -- in typechecked terms
+
, iSolver :: SMT.Solver
, iPrimNames :: !PrimMap
@@ -475,22 +483,54 @@
in (TVFree x k vs msg, s { seedTVar = x + 1 })
+-- | Check that the given "flavor" of parameter is allowed to
+-- have the given type, and raise an error if not
+checkParamKind :: TParam -> TPFlavor -> Kind -> InferM ()
+checkParamKind tp flav k =
+ case flav of
+ TPModParam _ -> return () -- All kinds allowed as module parameters
+ TPPropSynParam _ -> starOrHashOrProp
+ TPTySynParam _ -> starOrHash
+ TPSchemaParam _ -> starOrHash
+ TPNewtypeParam _ -> starOrHash
+ TPPrimParam _ -> starOrHash
+ TPUnifyVar -> starOrHash
+
+ where
+ starOrHashOrProp =
+ case k of
+ KNum -> return ()
+ KType -> return ()
+ KProp -> return ()
+ _ -> recordError (BadParameterKind tp k)
+
+ starOrHash =
+ case k of
+ KNum -> return ()
+ KType -> return ()
+ _ -> recordError (BadParameterKind tp k)
+
+
-- | Generate a new free type variable.
newTParam :: P.TParam Name -> TPFlavor -> Kind -> InferM TParam
-newTParam nm flav k = newName $ \s ->
- let x = seedTVar s
- in (TParam { tpUnique = x
- , tpKind = k
- , tpFlav = flav
- , tpInfo = desc
- }
- , s { seedTVar = x + 1 })
- where desc = TVarInfo { tvarDesc = TVFromSignature (P.tpName nm)
- , tvarSource = fromMaybe emptyRange (P.tpRange nm)
+newTParam nm flav k =
+ do let desc = TVarInfo { tvarDesc = TVFromSignature (P.tpName nm)
+ , tvarSource = fromMaybe emptyRange (P.tpRange nm)
+ }
+ tp <- newName $ \s ->
+ let x = seedTVar s
+ in (TParam { tpUnique = x
+ , tpKind = k
+ , tpFlav = flav
+ , tpInfo = desc
}
+ , s { seedTVar = x + 1 })
+ checkParamKind tp flav k
+ return tp
+
-- | Generate an unknown type. The doc is a note about what is this type about.
newType :: TypeSource -> Kind -> InferM Type
newType src k = TVar `fmap` newTVar src k
@@ -692,6 +732,9 @@
getMonoBinds :: InferM Bool
getMonoBinds = IM (asks iMonoBinds)
+getCallStacks :: InferM Bool
+getCallStacks = IM (asks iCallStacks)
+
{- | We disallow shadowing between type synonyms and type variables
because it is confusing. As a bonus, in the implementation we don't
need to worry about where we lookup things (i.e., in the variable or
@@ -942,5 +985,3 @@
kInInferM :: InferM a -> KindM a
kInInferM m = KM $ lift $ lift m
-
-
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
@@ -31,6 +31,7 @@
showParseable :: t -> Doc
instance ShowParseable Expr where
+ showParseable (ELocated _ e) = showParseable e -- TODO? emit range information
showParseable (EList es _) = parens (text "EList" <+> showParseable es)
showParseable (ETuple es) = parens (text "ETuple" <+> showParseable es)
showParseable (ERec ides) = parens (text "ERec" <+> showParseable (canonicalFields ides))
diff --git a/src/Cryptol/TypeCheck/Sanity.hs b/src/Cryptol/TypeCheck/Sanity.hs
--- a/src/Cryptol/TypeCheck/Sanity.hs
+++ b/src/Cryptol/TypeCheck/Sanity.hs
@@ -15,7 +15,7 @@
) where
-import Cryptol.Parser.Position(thing)
+import Cryptol.Parser.Position(thing,Range,emptyRange)
import Cryptol.TypeCheck.AST
import Cryptol.TypeCheck.Subst (apSubst, singleTParamSubst)
import Cryptol.TypeCheck.Monad(InferInput(..))
@@ -31,15 +31,15 @@
import qualified Data.Map as Map
-tcExpr :: InferInput -> Expr -> Either Error (Schema, [ ProofObligation ])
+tcExpr :: InferInput -> Expr -> Either (Range, Error) (Schema, [ ProofObligation ])
tcExpr env e = runTcM env (exprSchema e)
-tcDecls :: InferInput -> [DeclGroup] -> Either Error [ ProofObligation ]
+tcDecls :: InferInput -> [DeclGroup] -> Either (Range, Error) [ ProofObligation ]
tcDecls env ds0 = case runTcM env (checkDecls ds0) of
Left err -> Left err
Right (_,ps) -> Right ps
-tcModule :: InferInput -> Module -> Either Error [ ProofObligation ]
+tcModule :: InferInput -> Module -> Either (Range, Error) [ ProofObligation ]
tcModule env m = case runTcM env check of
Left err -> Left err
Right (_,ps) -> Right ps
@@ -68,6 +68,10 @@
do ks <- mapM checkType ts
checkKind (kindOf tc) ks
+ TNewtype nt ts ->
+ do ks <- mapM checkType ts
+ checkKind (kindOf nt) ks
+
TVar tv -> lookupTVar tv
TRec fs ->
@@ -143,6 +147,8 @@
exprSchema expr =
case expr of
+ ELocated rng t -> withRange rng (exprSchema t)
+
EList es t ->
do checkTypeIs KType t
forM_ es $ \e ->
@@ -367,6 +373,12 @@
| tc1 == tc2 -> goMany ts1 ts2
_ -> err
+ TNewtype nt1 ts1 ->
+ case other of
+ TNewtype nt2 ts2
+ | nt1 == nt2 -> goMany ts1 ts2
+ _ -> err
+
TRec fs ->
case other of
TRec gs ->
@@ -444,6 +456,7 @@
data RO = RO
{ roTVars :: Map Int TParam
, roAsmps :: [Prop]
+ , roRange :: Range
, roVars :: Map Name Schema
}
@@ -453,7 +466,7 @@
{ woProofObligations :: [ProofObligation]
}
-newtype TcM a = TcM (ReaderT RO (ExceptionT Error (StateT RW Id)) a)
+newtype TcM a = TcM (ReaderT RO (ExceptionT (Range, Error) (StateT RW Id)) a)
instance Functor TcM where
fmap = liftM
@@ -468,7 +481,7 @@
let TcM m1 = f a
m1)
-runTcM :: InferInput -> TcM a -> Either Error (a, [ProofObligation])
+runTcM :: InferInput -> TcM a -> Either (Range, Error) (a, [ProofObligation])
runTcM env (TcM m) =
case runM m ro rw of
(Left err, _) -> Left err
@@ -478,6 +491,7 @@
| tp <- Map.elems (inpParamTypes env)
, let x = mtpParam tp ]
, roAsmps = map thing (inpParamConstraints env)
+ , roRange = emptyRange
, roVars = Map.union
(fmap mvpType (inpParamFuns env))
(inpVars env)
@@ -511,12 +525,19 @@
deriving Show
reportError :: Error -> TcM a
-reportError e = TcM (raise e)
+reportError e = TcM $
+ do ro <- ask
+ raise (roRange ro, e)
withTVar :: TParam -> TcM a -> TcM a
withTVar a (TcM m) = TcM $
do ro <- ask
local ro { roTVars = Map.insert (tpUnique a) a (roTVars ro) } m
+
+withRange :: Range -> TcM a -> TcM a
+withRange rng (TcM m) = TcM $
+ do ro <- ask
+ local ro { roRange = rng } m
withAsmp :: Prop -> TcM a -> TcM a
withAsmp p (TcM m) = TcM $
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
@@ -19,6 +19,7 @@
| otherwise -> go t
TVar _ -> ty
TRec xs -> TRec (fmap go xs)
+ TNewtype nt xs -> TNewtype nt (map go xs)
TCon tc ts -> tCon tc (map go ts)
tRebuild :: 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
@@ -11,6 +11,7 @@
, solveIntegralInst, solveFieldInst, solveRoundInst
, solveEqInst, solveCmpInst, solveSignedCmpInst
, solveLiteralInst
+ , solveLiteralLessThanInst
, solveValidFloat, solveFLiteralInst
)
@@ -55,6 +56,7 @@
TCon (PC PCmp) [ty] -> solveCmpInst ty
TCon (PC PSignedCmp) [ty] -> solveSignedCmpInst ty
TCon (PC PLiteral) [t1,t2] -> solveLiteralInst t1 t2
+ TCon (PC PLiteralLessThan) [t1,t2] -> solveLiteralLessThanInst t1 t2
TCon (PC PFLiteral) [t1,t2,t3,t4] -> solveFLiteralInst t1 t2 t3 t4
TCon (PC PValidFloat) [t1,t2] -> solveValidFloat t1 t2
diff --git a/src/Cryptol/TypeCheck/Solver/Class.hs b/src/Cryptol/TypeCheck/Solver/Class.hs
--- a/src/Cryptol/TypeCheck/Solver/Class.hs
+++ b/src/Cryptol/TypeCheck/Solver/Class.hs
@@ -20,14 +20,15 @@
, solveCmpInst
, solveSignedCmpInst
, solveLiteralInst
+ , solveLiteralLessThanInst
, solveFLiteralInst
, solveValidFloat
) where
import qualified LibBF as FP
-import Cryptol.TypeCheck.Type
-import Cryptol.TypeCheck.SimpType (tAdd,tWidth)
+import Cryptol.TypeCheck.Type hiding (tSub)
+import Cryptol.TypeCheck.SimpType (tAdd,tSub,tWidth,tMax)
import Cryptol.TypeCheck.Solver.Types
import Cryptol.Utils.RecordMap
@@ -99,6 +100,9 @@
-- (Zero a, Zero b) => Zero { x1 : a, x2 : b }
TRec fs -> SolvedIf [ pZero ety | ety <- recordElements fs ]
+ -- Zero -> fails
+ TNewtype{} -> Unsolvable
+
_ -> Unsolved
-- | Solve a Logic constraint by instance, if possible.
@@ -135,6 +139,9 @@
-- (Logic a, Logic b) => Logic { x1 : a, x2 : b }
TRec fs -> SolvedIf [ pLogic ety | ety <- recordElements fs ]
+ -- Logic -> fails
+ TNewtype{} -> Unsolvable
+
_ -> Unsolved
@@ -172,6 +179,9 @@
-- (Ring a, Ring b) => Ring { x1 : a, x2 : b }
TRec fs -> SolvedIf [ pRing ety | ety <- recordElements fs ]
+ -- Ring -> fails
+ TNewtype{} -> Unsolvable
+
_ -> Unsolved
@@ -256,6 +266,9 @@
-- Field {x : a, y : b, ...} fails
TRec _ -> Unsolvable
+ -- Field -> fails
+ TNewtype{} -> Unsolvable
+
_ -> Unsolved
@@ -295,6 +308,9 @@
-- Round {x : a, y : b, ...} fails
TRec _ -> Unsolvable
+ -- Round -> fails
+ TNewtype{} -> Unsolvable
+
_ -> Unsolved
@@ -333,6 +349,9 @@
-- (Eq a, Eq b) => Eq { x:a, y:b }
TRec fs -> SolvedIf [ pEq e | e <- recordElements fs ]
+ -- Eq -> fails
+ TNewtype{} -> Unsolvable
+
_ -> Unsolved
@@ -370,6 +389,9 @@
-- (Cmp a, Cmp b) => Cmp { x:a, y:b }
TRec fs -> SolvedIf [ pCmp e | e <- recordElements fs ]
+ -- Cmp -> fails
+ TNewtype{} -> Unsolvable
+
_ -> Unsolved
@@ -422,6 +444,9 @@
-- (SignedCmp a, SignedCmp b) => SignedCmp { x:a, y:b }
TRec fs -> SolvedIf [ pSignedCmp e | e <- recordElements fs ]
+ -- SignedCmp -> fails
+ TNewtype{} -> Unsolvable
+
_ -> Unsolved
@@ -459,6 +484,7 @@
_ -> Unsolvable
+
-- | Solve Literal constraints.
solveLiteralInst :: Type -> Type -> Solved
solveLiteralInst val ty
@@ -490,12 +516,11 @@
| otherwise -> Unsolved
-
-- (fin val, fin m, m >= val + 1) => Literal val (Z m)
TCon (TC TCIntMod) [modulus] ->
SolvedIf [ pFin val, pFin modulus, modulus >== tAdd val tOne ]
- -- (fin bits, bits => width n) => Literal n [bits]
+ -- (fin bits, bits >= width n) => Literal n [bits]
TCon (TC TCSeq) [bits, elTy]
| TCon (TC TCBit) [] <- ety ->
SolvedIf [ pFin val, pFin bits, bits >== tWidth val ]
@@ -507,3 +532,50 @@
_ -> Unsolvable
+-- | Solve Literal constraints.
+solveLiteralLessThanInst :: Type -> Type -> Solved
+solveLiteralLessThanInst val ty
+ | TCon (TError {}) _ <- tNoUser val = Unsolvable
+ | otherwise =
+ case tNoUser ty of
+
+ -- Literal n Error -> fails
+ TCon (TError {}) _ -> Unsolvable
+
+ -- (2 >= val) => LiteralLessThan val Bit
+ TCon (TC TCBit) [] -> SolvedIf [ tTwo >== val ]
+
+ -- LiteralLessThan val Integer
+ TCon (TC TCInteger) [] -> SolvedIf [ ]
+
+ -- LiteralLessThan val Rational
+ TCon (TC TCRational) [] -> SolvedIf [ ]
+
+ -- ValidFloat e p => LiteralLessThan val (Float e p) if `val-1` is representable
+ -- RWD Should we remove this instance for floats?
+ TCon (TC TCFloat) [e, p]
+ | Just n <- tIsNum val
+ , n > 0
+ , Just opts <- knownSupportedFloat e p ->
+ let bf = FP.bfFromInteger (n-1)
+ in case FP.bfRoundFloat opts bf of
+ (bf1,FP.Ok) | bf == bf1 -> SolvedIf []
+ _ -> Unsolvable
+
+ | otherwise -> Unsolved
+
+ -- (fin val, fin m, m >= val) => LiteralLessThan val (Z m)
+ TCon (TC TCIntMod) [modulus] ->
+ SolvedIf [ pFin val, pFin modulus, modulus >== val ]
+
+ -- (fin bits, bits >= lg2 n) => LiteralLessThan n [bits]
+ TCon (TC TCSeq) [bits, elTy]
+ | TCon (TC TCBit) [] <- ety ->
+ SolvedIf [ pFin val, pFin bits, bits >== tWidth val' ]
+ | TVar _ <- ety -> Unsolved
+ where ety = tNoUser elTy
+ val' = tSub (tMax val tOne) tOne
+
+ TVar _ -> Unsolved
+
+ _ -> Unsolvable
diff --git a/src/Cryptol/TypeCheck/Solver/Improve.hs b/src/Cryptol/TypeCheck/Solver/Improve.hs
--- a/src/Cryptol/TypeCheck/Solver/Improve.hs
+++ b/src/Cryptol/TypeCheck/Solver/Improve.hs
@@ -45,6 +45,8 @@
improveLit impSkol prop
-- XXX: others
+-- Whenever we have `Literal n [m]a`,
+-- we can learn that `a = Bit`
improveLit :: Bool -> Prop -> Match (Subst, [Prop])
improveLit impSkol prop =
do (_,t) <- aLiteral prop
@@ -53,7 +55,6 @@
unless impSkol $ guard (isFreeTV a)
let su = uncheckedSingleSubst a tBit
return (su, [])
-
-- | Improvements from equality constraints.
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
@@ -16,6 +16,8 @@
( -- * Setup
Solver
, withSolver
+ , startSolver
+ , stopSolver
, isNumeric
-- * Debugging
@@ -65,21 +67,20 @@
-- ^ For debugging
}
--- | Execute a computation with a fresh solver instance.
-withSolver :: SolverConfig -> (Solver -> IO a) -> IO a
-withSolver SolverConfig{ .. } =
- bracket
- (do logger <- if solverVerbose > 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
- return sol)
- (\s -> void $ SMT.stop (solver s))
+-- | Start a fresh solver instance
+startSolver :: SolverConfig -> IO Solver
+startSolver SolverConfig { .. } =
+ do logger <- if solverVerbose > 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
+ return sol
+
where
quietLogger = SMT.Logger { SMT.logMessage = \_ -> return ()
, SMT.logLevel = return 0
@@ -88,7 +89,14 @@
, SMT.logUntab = return ()
}
+-- | Shut down a solver instance
+stopSolver :: Solver -> IO ()
+stopSolver s = void $ SMT.stop (solver s)
+-- | Execute a computation with a fresh solver instance.
+withSolver :: SolverConfig -> (Solver -> IO a) -> IO a
+withSolver cfg = bracket (startSolver cfg) stopSolver
+
-- | Load the definitions used for type checking.
loadTcPrelude :: Solver -> [FilePath] {- ^ Search in this paths -} -> IO ()
loadTcPrelude s [] = loadString s cryptolTcContents
@@ -388,8 +396,3 @@
mk tvs f (x,y,z) = SMT.fun f [ toSMT tvs x, toSMT tvs y, toSMT tvs z ]
--------------------------------------------------------------------------------
-
-
-
-
-
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
@@ -10,7 +10,7 @@
import Cryptol.TypeCheck.AST
import Cryptol.TypeCheck.InferTypes
-import Cryptol.TypeCheck.Monad( InferM, unify, newGoals, lookupNewtype
+import Cryptol.TypeCheck.Monad( InferM, unify, newGoals
, newType, applySubst, solveHasGoal
, newParamName
)
@@ -66,21 +66,18 @@
(RecordSel l _, ty) ->
case ty of
- TRec fs -> return (lookupField l fs)
+ TRec fs -> return (lookupField l fs)
+ TNewtype nt ts ->
+ case lookupField l (ntFields nt) of
+ Nothing -> return Nothing
+ Just t ->
+ do let su = listParamSubst (zip (ntParams nt) ts)
+ newGoals (CtPartialTypeFun (ntName nt))
+ $ apSubst su $ ntConstraints nt
+ return $ Just $ apSubst su t
+
TCon (TC TCSeq) [len,el] -> liftSeq len el
TCon (TC TCFun) [t1,t2] -> liftFun t1 t2
- TCon (TC (TCNewtype (UserTC x _))) ts ->
- do mb <- lookupNewtype x
- case mb of
- Nothing -> return Nothing
- Just nt ->
- case lookup l (ntFields nt) of
- Nothing -> return Nothing
- Just t ->
- do let su = listParamSubst (zip (ntParams nt) ts)
- newGoals (CtPartialTypeFun x)
- $ apSubst su $ ntConstraints nt
- return $ Just $ apSubst su t
_ -> return Nothing
(TupleSel n _, ty) ->
diff --git a/src/Cryptol/TypeCheck/Solver/Utils.hs b/src/Cryptol/TypeCheck/Solver/Utils.hs
--- a/src/Cryptol/TypeCheck/Solver/Utils.hs
+++ b/src/Cryptol/TypeCheck/Solver/Utils.hs
@@ -22,6 +22,7 @@
go ty = case ty of
TVar x -> return (x, tNum (0::Int))
TRec {} -> []
+ TNewtype{} -> []
TUser _ _ t -> go t
TCon (TF TCAdd) [t1,t2] ->
do (a,yes) <- go t1
@@ -45,6 +46,7 @@
case ty of
TVar {} -> Nothing
TRec {} -> Nothing
+ TNewtype{} -> Nothing
TUser _ _ t -> splitConstSummand t
TCon (TF TCAdd) [t1,t2] ->
do (k,t1') <- splitConstSummand t1
@@ -63,6 +65,7 @@
case ty of
TVar {} -> Nothing
TRec {} -> Nothing
+ TNewtype{} -> Nothing
TUser _ _ t -> splitConstFactor t
TCon (TF TCMul) [t1,t2] ->
do (k,t1') <- splitConstFactor t1
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
@@ -240,7 +240,8 @@
do (ts1, t1) <- anyJust2 (anyJust (apSubstMaybe su)) (apSubstMaybe su) (ts, t)
Just (TUser f ts1 t1)
- TRec fs -> TRec `fmap` (anyJust (apSubstMaybe su) fs)
+ TRec fs -> TRec `fmap` (anyJust (apSubstMaybe su) fs)
+ TNewtype nt ts -> TNewtype nt `fmap` anyJust (apSubstMaybe su) ts
TVar x -> applySubstToVar su x
lookupSubst :: TVar -> Subst -> Maybe Type
@@ -315,6 +316,7 @@
tm' = TM { tvar = Map.fromList vars
, tcon = fmap (lgo merge atNode) tcon
, trec = fmap (lgo merge atNode) trec
+ , tnewtype = fmap (lgo merge atNode) tnewtype
}
-- partition out variables that have been replaced with more specific types
@@ -348,6 +350,7 @@
where
go expr =
case expr of
+ ELocated r e -> ELocated r !$ (go e)
EApp e1 e2 -> EApp !$ (go e1) !$ (go e2)
EAbs x t e1 -> EAbs x !$ (apSubst su t) !$ (go e1)
ETAbs a e -> ETAbs a !$ (go e)
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
@@ -80,6 +80,7 @@
, "Cmp" ~> PC PCmp
, "SignedCmp" ~> PC PSignedCmp
, "Literal" ~> PC PLiteral
+ , "LiteralLessThan" ~> PC PLiteralLessThan
, "FLiteral" ~> PC PFLiteral
-- Type functions
@@ -142,7 +143,6 @@
TCSeq -> KNum :-> KType :-> KType
TCFun -> KType :-> KType :-> KType
TCTuple n -> foldr (:->) KType (replicate n KType)
- TCNewtype x -> kindOf x
TCAbstract x -> kindOf x
instance HasKind PC where
@@ -164,6 +164,7 @@
PCmp -> KType :-> KProp
PSignedCmp -> KType :-> KProp
PLiteral -> KNum :-> KType :-> KProp
+ PLiteralLessThan -> KNum :-> KType :-> KProp
PFLiteral -> KNum :-> KNum :-> KNum :-> KType :-> KProp
PValidFloat -> KNum :-> KNum :-> KProp
PAnd -> KProp :-> KProp :-> KProp
@@ -214,6 +215,7 @@
| PCmp -- ^ @Cmp _@
| PSignedCmp -- ^ @SignedCmp _@
| PLiteral -- ^ @Literal _ _@
+ | PLiteralLessThan -- ^ @LiteralLessThan _ _@
| PFLiteral -- ^ @FLiteral _ _ _@
| PValidFloat -- ^ @ValidFloat _ _@ constraints on supported
@@ -237,7 +239,6 @@
| TCFun -- ^ @_ -> _@
| TCTuple Int -- ^ @(_, _, _)@
| TCAbstract UserTC -- ^ An abstract type
- | TCNewtype UserTC -- ^ user-defined, @T@
deriving (Show, Eq, Ord, Generic, NFData)
@@ -316,6 +317,7 @@
PCmp -> text "Cmp"
PSignedCmp -> text "SignedCmp"
PLiteral -> text "Literal"
+ PLiteralLessThan -> text "LiteralLessThan"
PFLiteral -> text "FLiteral"
PValidFloat -> text "ValidFloat"
PTrue -> text "True"
@@ -337,7 +339,6 @@
TCTuple 0 -> text "()"
TCTuple 1 -> text "(one tuple?)"
TCTuple n -> parens $ hcat $ replicate (n-1) comma
- TCNewtype u -> pp u
TCAbstract u -> pp u
instance PP UserTC 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
@@ -49,7 +49,12 @@
deriving (Generic, NFData, Show)
data TPFlavor = TPModParam Name
- | TPOther (Maybe Name)
+ | TPUnifyVar
+ | TPSchemaParam Name
+ | TPTySynParam Name
+ | TPPropSynParam Name
+ | TPNewtypeParam Name
+ | TPPrimParam Name
deriving (Generic, NFData, Show)
tMono :: Type -> Schema
@@ -62,18 +67,17 @@
_ -> Nothing
-
schemaParam :: Name -> TPFlavor
-schemaParam x = TPOther (Just x)
+schemaParam = TPSchemaParam
tySynParam :: Name -> TPFlavor
-tySynParam x = TPOther (Just x)
+tySynParam = TPTySynParam
propSynParam :: Name -> TPFlavor
-propSynParam x = TPOther (Just x)
+propSynParam = TPPropSynParam
newtypeParam :: Name -> TPFlavor
-newtypeParam x = TPOther (Just x)
+newtypeParam = TPNewtypeParam
modTyParam :: Name -> TPFlavor
modTyParam = TPModParam
@@ -82,8 +86,13 @@
tpfName :: TPFlavor -> Maybe Name
tpfName f =
case f of
- TPModParam x -> Just x
- TPOther x -> x
+ TPUnifyVar -> Nothing
+ TPModParam x -> Just x
+ TPSchemaParam x -> Just x
+ TPTySynParam x -> Just x
+ TPPropSynParam x -> Just x
+ TPNewtypeParam x -> Just x
+ TPPrimParam x -> Just x
tpName :: TParam -> Maybe Name
tpName = tpfName . tpFlav
@@ -106,6 +115,9 @@
| TRec !(RecordMap Ident Type)
-- ^ Record type
+ | TNewtype !Newtype ![Type]
+ -- ^ A newtype
+
deriving (Show, Generic, NFData)
@@ -209,11 +221,18 @@
data Newtype = Newtype { ntName :: Name
, ntParams :: [TParam]
, ntConstraints :: [Prop]
- , ntFields :: [(Ident,Type)]
+ , ntFields :: RecordMap Ident Type
, ntDoc :: Maybe Text
} deriving (Show, Generic, NFData)
+instance Eq Newtype where
+ x == y = ntName x == ntName y
+
+instance Ord Newtype where
+ compare x y = compare (ntName x) (ntName y)
+
+
-- | Information about an abstract type.
data AbstractType = AbstractType
{ atName :: Name
@@ -240,6 +259,7 @@
TCon c ts -> quickApply (kindOf c) ts
TUser _ _ t -> kindOf t
TRec {} -> KType
+ TNewtype{} -> KType
instance HasKind TySyn where
kindOf ts = foldr (:->) (kindOf (tsDef ts)) (map kindOf (tsParams ts))
@@ -270,6 +290,7 @@
TCon x xs == TCon y ys = x == y && xs == ys
TVar x == TVar y = x == y
TRec xs == TRec ys = xs == ys
+ TNewtype ntx xs == TNewtype nty ys = ntx == nty && xs == ys
_ == _ = False
@@ -288,7 +309,10 @@
(_,TCon {}) -> GT
(TRec xs, TRec ys) -> compare xs ys
+ (TRec{}, _) -> LT
+ (_, TRec{}) -> GT
+ (TNewtype x xs, TNewtype y ys) -> compare (x,xs) (y,ys)
instance Eq TParam where
x == y = tpUnique x == tpUnique y
@@ -332,7 +356,7 @@
newtypeConType :: Newtype -> Schema
newtypeConType nt =
Forall as (ntConstraints nt)
- $ TRec (recordFromFields (ntFields nt)) `tFun` TCon (newtypeTyCon nt) (map (TVar . tpVar) as)
+ $ TRec (ntFields nt) `tFun` TNewtype nt (map (TVar . tpVar) as)
where
as = ntParams nt
@@ -538,6 +562,12 @@
TCon (PC PLiteral) [t1, t2] -> Just (t1, t2)
_ -> Nothing
+pIsLiteralLessThan :: Prop -> Maybe (Type, Type)
+pIsLiteralLessThan ty =
+ case tNoUser ty of
+ TCon (PC PLiteralLessThan) [t1, t2] -> Just (t1, t2)
+ _ -> Nothing
+
pIsFLiteral :: Prop -> Maybe (Type,Type,Type,Type)
pIsFLiteral ty = case tNoUser ty of
TCon (PC PFLiteral) [t1,t2,t3,t4] -> Just (t1,t2,t3,t4)
@@ -584,6 +614,9 @@
tAbstract :: UserTC -> [Type] -> Type
tAbstract u ts = TCon (TC (TCAbstract u)) ts
+tNewtype :: Newtype -> [Type] -> Type
+tNewtype nt ts = TNewtype nt ts
+
tBit :: Type
tBit = TCon (TC TCBit) []
@@ -620,10 +653,6 @@
tTuple :: [Type] -> Type
tTuple ts = TCon (TC (TCTuple (length ts))) ts
-newtypeTyCon :: Newtype -> TCon
-newtypeTyCon nt = TC $ TCNewtype $ UserTC (ntName nt) (kindOf nt)
-
-
-- | Make a function type.
tFun :: Type -> Type -> Type
tFun a b = TCon (TC TCFun) [a,b]
@@ -725,6 +754,9 @@
pLiteral :: Type -> Type -> Prop
pLiteral x y = TCon (PC PLiteral) [x, y]
+pLiteralLessThan :: Type -> Type -> Prop
+pLiteralLessThan x y = TCon (PC PLiteralLessThan) [x, y]
+
-- | Make a greater-than-or-equal-to constraint.
(>==) :: Type -> Type -> Prop
x >== y = TCon (PC PGeq) [x,y]
@@ -801,6 +833,7 @@
TVar x -> Set.singleton x
TUser _ _ t -> go t
TRec fs -> fvs (recordElements fs)
+ TNewtype _nt ts -> fvs ts
instance FVS a => FVS (Maybe a) where
fvs Nothing = Set.empty
@@ -915,6 +948,7 @@
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
[ pp l <+> text ":" <+> go 0 t | (l,t) <- displayFields fs ]
@@ -972,6 +1006,7 @@
(PCmp, [t1]) -> pp pc <+> go 5 t1
(PSignedCmp, [t1]) -> pp pc <+> go 5 t1
(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)
@@ -1011,10 +1046,15 @@
| otherwise =
case tv of
TVBound x ->
+ let declNm n = pp n <.> "`" <.> int (tpUnique x) in
case tpFlav x of
TPModParam n -> ppPrefixName n
- TPOther (Just n) -> pp n <.> "`" <.> int (tpUnique x)
- _ -> pickTVarName (tpKind x) (tvarDesc (tpInfo x)) (tpUnique x)
+ TPUnifyVar -> pickTVarName (tpKind x) (tvarDesc (tpInfo x)) (tpUnique x)
+ TPSchemaParam n -> declNm n
+ TPTySynParam n -> declNm n
+ TPPropSynParam n -> declNm n
+ TPNewtypeParam n -> declNm n
+ TPPrimParam n -> declNm n
TVFree x k _ d -> pickTVarName k (tvarDesc d) x
diff --git a/src/Cryptol/TypeCheck/TypeMap.hs b/src/Cryptol/TypeCheck/TypeMap.hs
--- a/src/Cryptol/TypeCheck/TypeMap.hs
+++ b/src/Cryptol/TypeCheck/TypeMap.hs
@@ -118,14 +118,17 @@
data TypeMap a = TM { tvar :: Map TVar a
, tcon :: Map TCon (List TypeMap a)
, trec :: Map [Ident] (List TypeMap a)
+ , tnewtype :: Map Newtype (List TypeMap a)
} deriving (Functor, Foldable, Traversable)
instance TrieMap TypeMap Type where
- emptyTM = TM { tvar = emptyTM, tcon = emptyTM, trec = emptyTM }
+ emptyTM = TM { tvar = emptyTM, tcon = emptyTM, trec = emptyTM, tnewtype = emptyTM }
nullTM ty = and [ nullTM (tvar ty)
, nullTM (tcon ty)
- , nullTM (trec ty) ]
+ , nullTM (trec ty)
+ , nullTM (tnewtype ty)
+ ]
lookupTM ty =
case ty of
@@ -134,6 +137,7 @@
TCon c ts -> lookupTM ts <=< lookupTM c . tcon
TRec fs -> let (xs,ts) = unzip $ canonicalFields fs
in lookupTM ts <=< lookupTM xs . trec
+ TNewtype nt ts -> lookupTM ts <=< lookupTM nt . tnewtype
alterTM ty f m =
case ty of
@@ -142,6 +146,7 @@
TCon c ts -> m { tcon = alterTM c (updSub ts f) (tcon m) }
TRec fs -> let (xs,ts) = unzip $ canonicalFields fs
in m { trec = alterTM xs (updSub ts f) (trec m) }
+ TNewtype nt ts -> m { tnewtype = alterTM nt (updSub ts f) (tnewtype m) }
toListTM m =
[ (TVar x, v) | (x,v) <- toListTM (tvar m) ] ++
@@ -152,11 +157,16 @@
-- It's not clear if we should try to fix this.
[ (TRec (recordFromFields (zip fs ts)), v)
| (fs,m1) <- toListTM (trec m)
- , (ts,v) <- toListTM m1 ]
+ , (ts,v) <- toListTM m1 ] ++
+ [ (TNewtype nt ts, v) | (nt,m1) <- toListTM (tnewtype m)
+ , (ts,v) <- toListTM m1
+ ]
+
unionTM f m1 m2 = TM { tvar = unionTM f (tvar m1) (tvar m2)
, tcon = unionTM (unionTM f) (tcon m1) (tcon m2)
, trec = unionTM (unionTM f) (trec m1) (trec m2)
+ , tnewtype = unionTM (unionTM f) (tnewtype m1) (tnewtype m2)
}
mapMaybeWithKeyTM f m =
@@ -167,6 +177,8 @@
(\ts a -> f (TRec (recordFromFields (zip fs ts))) a) l) (trec m)
-- NB: this step loses 'displayOrder' information.
-- It's not clear if we should try to fix this.
+ , tnewtype = mapWithKeyTM (\nt l -> mapMaybeWithKeyTM
+ (\ts a -> f (TNewtype nt ts) a) l) (tnewtype m)
}
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
@@ -30,6 +30,7 @@
fastTypeOf tyenv expr =
case expr of
-- Monomorphic fragment
+ ELocated _ t -> fastTypeOf tyenv t
EList es t -> tSeq (tNum (length es)) t
ETuple es -> tTuple (map (fastTypeOf tyenv) es)
ERec fields -> tRec (fmap (fastTypeOf tyenv) fields)
@@ -59,6 +60,8 @@
fastSchemaOf :: Map Name Schema -> Expr -> Schema
fastSchemaOf tyenv expr =
case expr of
+ ELocated _ e -> fastSchemaOf tyenv e
+
-- Polymorphic fragment
EVar x -> case Map.lookup x tyenv of
Just ty -> ty
@@ -113,10 +116,11 @@
plainSubst :: Subst -> Type -> Type
plainSubst s ty =
case ty of
- TCon tc ts -> TCon tc (map (plainSubst s) ts)
- TUser f ts t -> TUser f (map (plainSubst s) ts) (plainSubst s t)
- TRec fs -> TRec (fmap (plainSubst s) fs)
- TVar x -> apSubst s (TVar x)
+ TCon tc ts -> TCon tc (map (plainSubst s) ts)
+ TUser f ts t -> TUser f (map (plainSubst s) ts) (plainSubst s t)
+ TRec fs -> TRec (fmap (plainSubst s) fs)
+ TNewtype nt ts -> TNewtype nt (map (plainSubst s) ts)
+ TVar x -> apSubst s (TVar x)
-- | Yields the return type of the selector on the given argument type.
typeSelect :: Type -> Selector -> Type
diff --git a/src/Cryptol/TypeCheck/TypePat.hs b/src/Cryptol/TypeCheck/TypePat.hs
--- a/src/Cryptol/TypeCheck/TypePat.hs
+++ b/src/Cryptol/TypeCheck/TypePat.hs
@@ -7,7 +7,9 @@
, aCeilDiv, aCeilMod
, aLenFromThenTo
- , aLiteral, aLogic
+ , aLiteral
+ , aLiteralLessThan
+ , aLogic
, aTVar
, aFreeTVar
@@ -177,6 +179,9 @@
aLiteral :: Pat Prop (Type,Type)
aLiteral = tp PLiteral ar2
+
+aLiteralLessThan :: Pat Prop (Type,Type)
+aLiteralLessThan = tp PLiteralLessThan ar2
aLogic :: Pat Prop Type
aLogic = tp PLogic ar1
diff --git a/src/Cryptol/TypeCheck/Unify.hs b/src/Cryptol/TypeCheck/Unify.hs
--- a/src/Cryptol/TypeCheck/Unify.hs
+++ b/src/Cryptol/TypeCheck/Unify.hs
@@ -74,6 +74,9 @@
mgu (TRec fs1) (TRec fs2)
| fieldSet fs1 == fieldSet fs2 = mguMany (recordElements fs1) (recordElements fs2)
+mgu (TNewtype ntx xs) (TNewtype nty ys)
+ | ntx == nty = mguMany xs ys
+
mgu t1 t2
| not (k1 == k2) = uniError $ UniKindMismatch k1 k2
| otherwise = uniError $ UniTypeMismatch t1 t2
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
@@ -27,6 +27,38 @@
import Prelude ()
import Prelude.Compat
+
+-- | How to pretty print things when evaluating
+data PPOpts = PPOpts
+ { useAscii :: Bool
+ , useBase :: Int
+ , useInfLength :: Int
+ , useFPBase :: Int
+ , useFPFormat :: PPFloatFormat
+ }
+ deriving Show
+
+asciiMode :: PPOpts -> Integer -> Bool
+asciiMode opts width = useAscii opts && (width == 7 || width == 8)
+
+data PPFloatFormat =
+ FloatFixed Int PPFloatExp -- ^ Use this many significant digis
+ | FloatFrac Int -- ^ Show this many digits after floating point
+ | FloatFree PPFloatExp -- ^ Use the correct number of digits
+ deriving Show
+
+data PPFloatExp = ForceExponent -- ^ Always show an exponent
+ | AutoExponent -- ^ Only show exponent when needed
+ deriving Show
+
+
+defaultPPOpts :: PPOpts
+defaultPPOpts = PPOpts { useAscii = False, useBase = 10, useInfLength = 5
+ , useFPBase = 16
+ , useFPFormat = FloatFree AutoExponent
+ }
+
+
-- Name Displaying -------------------------------------------------------------
{- | How to display names, inspired by the GHC `Outputable` module.
diff --git a/src/GitRev.hs b/src/GitRev.hs
--- a/src/GitRev.hs
+++ b/src/GitRev.hs
@@ -24,4 +24,3 @@
dirty :: Bool
dirty = $(gitDirty)
--- Last build Fri Sep 11 16:44:33 PDT 2020
diff --git a/utils/CryHtml.hs b/utils/CryHtml.hs
--- a/utils/CryHtml.hs
+++ b/utils/CryHtml.hs
@@ -1,6 +1,7 @@
#!/usr/bin/env runhaskell
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ViewPatterns #-}
-- |
-- Module : Main
@@ -11,13 +12,14 @@
-- Portability : portable
import Cryptol.Parser.Lexer
+import Cryptol.Parser.Position
import Cryptol.Utils.PP
import qualified Data.Text.IO as Text
-import Text.Blaze.Html (Html, AttributeValue, toValue, toHtml, (!))
+import Text.Blaze.Html (Html, AttributeValue, toHtml, (!), toValue)
import qualified Text.Blaze.Html as H
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as A
-import Text.Blaze.Html.Renderer.Pretty (renderHtml)
+import Text.Blaze.Html.Renderer.String (renderHtml)
main :: IO ()
@@ -41,8 +43,9 @@
toBlaze :: Located Token -> Html
+toBlaze (Located _ (tokenType -> EOF)) = mempty
toBlaze tok = H.span ! (A.class_ $ cl $ tokenType $ thing tok)
- ! (A.title $ toValue $ show $ pp $ srcRange tok)
+ ! (A.id $ toValue $ show $ pp $ from $ srcRange tok)
$ H.toHtml
$ tokenText
$ thing tok
@@ -70,7 +73,7 @@
sty :: String
sty = unlines
- [ "body { font-family: monospace }"
+ [ "body { font-family: monospace; white-space: pre; }"
, ".number { color: #cc00cc }"
, ".identifier { }"
, ".selector { color: #33033 }"